View of /lisp/disp.l

Parent Directory

Revision Log

*** empty log message ***

; X-Windowを扱うためのCの関数をロードする
;
;
;(code-load '("/home/ktanaka/work/wadalabfont/lisp/window.o") "/usr/X11R6/lib/libX11.so")
; (code-load "/usr/X11R6/lib/libX11.so" "/home/ktanaka/work/wadalabfont/lisp/window.o")
;
(declare (err:argument-type err:number-of-arguments err:unbound-variable 
			    err:zero-division err:undefined-function) special)

;
; PSファイルの出力
;

(comment
(defun out-to-ps-all (outlines tag psfile 
			       (nameflag)
			       (col 9)(line (fix (times 0.67 col)))
			       (printfile t))
  (let ((standard-output (outopen (stream psfile)))
	(scale (fix (times 160.0 (min (//$ 9.0 (float col))
				      (//$ 6.0 (float line))))))
	(ii nil)(jj nil)(page nil)(last nil)
	(next nil)(nextnext nil)(x1 nil)(y1 nil)(x2 nil)(y2 nil)
	(date (date-time)))
    (format "%!/n%%BoundingBox: 45 45 /c /c/n" 
	    (plus 55 (fix (times 0.001 scale (- (* line 500) 100))))
	    (plus 55 (fix (times 0.001 scale (- (* col 500) 100)))))
    (format "50 50 translate/n0.001 /c mul dup scale/n" scale)
    (format "//Helvetica findfont 70 scalefont setfont/n")
    (setq ii 0 jj 0 page 1)
    (and printfile
	 (format "0 -70 moveto (/c-/c-/c /c:/c File: /c Page: /c) show/n" 
		 (substring date 0 2)
		 (substring date 2 4)(substring date 4 6)
		 (substring date 6 8)(substring date 8 10)
		 psfile page))
    (do 
	((ol outlines (cdr ol))
	 (l nil))
      ((atom ol))
      (princ ";" terminal-output)
;     (princ (gccount) terminal-output)
      (print (car ol) terminal-output)
      (setq l
	    (let ((err:argument-type #'(lambda (x (y))(throw 'err)))
		  (err:number-of-arguments #'(lambda (x (y))(throw 'err)))
		  (err:unbound-variable #'(lambda (x (y))(throw 'err)))
		  (err:undefined-function #'(lambda (x (y))(throw 'err)))
		  (err:zero-division #'(lambda (x (y))(throw 'err))))
	      (catch 'err
		(skeleton2list (normkanji (rm-limit (applykanji (car ol) tag)) tag)))))
      (cond 
       ((atom l)
	(format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n")
	(format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n")
	(cond (nameflag
	       (format "//Ryumin-Light-Ext-H findfont /c scalefont setfont/n"
		       (cond ((lessp (string-length (car ol)) 10) 100)
			     (t
			      (fix (quotient 800 (string-length (car ol)))))))
	       (format "0 410 moveto </c> show/n" (euc2jis(car ol)))))
	)
       (t
	(format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n")
	(format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n")
	(cond (nameflag
	       (format "//Ryumin-Light-Ext-H findfont /c scalefont setfont/n"
		       (cond ((lessp (string-length (car ol)) 10) 100)
			     (t
			      (fix (quotient 800 (string-length (car ol)))))))
	       (format "0 410 moveto </c> show/n" (euc2jis (car ol)))))
	(do ((ll l (cdr ll)))
	  ((atom ll))
	  (setq last (caar ll))
	  (format "newpath /c /c moveto/n" (fix (cadr last))
		  (- 400 (fix (caddr last))))
	  (do ((lll (cdar ll) (cdr lll)))
	    ((atom lll))
	    (match 
		(car lll)
	      (('angle x y)
	       (format "/c /c lineto/n" (fix x) (- 400 (fix y))))
	      (('bezier x0 y0)
	       (setq next (cadr lll))
	       (setq nextnext 
		     (cond ((cddr lll)(setq lll (cddr lll))(car lll))
			   (t (setq lll (cdr lll))last)))
	       (setq x1 (cadr next) y1 (caddr next))
	       (setq x2 (cadr nextnext) y2 (caddr nextnext))
	       (format
		"/c /c /c /c /c /c curveto/n"
		(fix x0) (- 400 (fix y0)) (fix x1) (- 400 (fix y1)) (fix x2) (- 400 (fix y2))))))
	  (format "closepath fill/n"))))
      (setq ii (1+ ii))
      (cond ((eq ii col)
	     (format "500 /c translate/n" (* -500 (1- col)))
	     (setq ii 0)
	     (setq jj (1+ jj))
	     (cond ((and (eq jj line)(consp (cdr ol)))
		    (format "showpage/n")
		    (format "50 50 translate/n")
		    (format "0.001 /c mul dup scale/n" scale)
		    (format "//Helvetica findfont 70 scalefont setfont/n")
		    (setq page (1+ page))
		    (and printfile
			 (format "0 -70 moveto (/c-/c-/c /c:/c File: /c Page: /c) show/n" 
				 (substring date 0 2)
				 (substring date 2 4)(substring date 4 6)
				 (substring date 6 8)(substring date 8 10)
				 psfile page))
		    (format "//Ryumin-Light-Ext-H findfont 100 scalefont setfont/n")
		    (setq jj 0))))
	    (t (format "0 500 translate/n"))))
    (format "showpage/n")))
)
      
;
; アウトライン形式のデータを表示する
;
(defun showOutline (outline)
  (init_window 400 400)
  (mapcar outline '(lambda (x)(drawlines (setpart1 x))))
  (redraw)
  (checkevent)
  (close_window))
;
; スケルトンデータを renderingして表示する
;
(defun showSkeleton (skeleton tag)
  (showOutline (skeleton2list skeleton tag)))
;
; スケルトンデータを折れ線に変換する．
;
(defun skeletonToLinesList (skeleton)
  (lets ((points (car skeleton))
	 (lineslist)
	 (elements (cadr skeleton))
	 (linkPoints))
	(mapc elements 
	      #'(lambda (element) 
		  (lets ((links (assq 'link (cddr element))))
			(and links
			     (mapc (cdr links)
				   #'(lambda (p) (or (memq p linkPoints)
						     (push p linkPoints))))))))
	(mapc elements 
	      #'(lambda (element)
		  (lets ((lines))
			(mapc (cadr element)
			      #'(lambda (p) 
				  (lets ((point (nth p points))
					 (x (fix (car point)))
					 (y (fix (cadr point))))
					(push `(,x .,y) lines))))
			(push lines lineslist))))
	(mapc linkPoints
	      #'(lambda (p) (push (makeSquareLines (nth p points)) lineslist)))
	lineslist))
;
; ある点を中心に四角を書く
; (100.0 100.0) -> 
; ((98 . 98)(98 . 102)(102 . 102)(102 . 98)(98 . 98)
(defun makeSquareLines (point (d 2))
  (lets ((x (fix (car point)))
	 (y (fix (cadr point))))
	`((,(- x d).,(- y d)) 
	  (,(- x d).,(+ y d)) 
	  (,(+ x d).,(+ y d)) 
	  (,(+ x d).,(- y d)) 
	  (,(- x d).,(- y d)))))

;
;
;
(defun showSkeletonByLines (skeleton)
  (init_window 400 400)
  (mapcar (skeletonToLinesList skeleton) #'drawlines)
  (redraw)
  (checkevent)
  (close_window))
  


;
; 
;
(defun showtest (l tag)
  (showSkeleton (applykanji l tag) tag))
;
(defun showtest1 (l tag)
  (lets ((outline nil))
    (init_window 400 400)
    (setq outline (makeoutline (skeleton2list (applykanji l tag) tag)))
    (mapcar outline '(lambda (x)(drawlines (setpart1 x))))
    (redraw)
    (checkevent)
    (close_window)))
;
; 塗りつぶして表示する
;

(defun filltest (l tag)
  (init_window 400 400)
  (mapcar (skeleton2list (rm-limit (applykanji l tag)) tag)
    (function (lambda (x)(fillpolygon (setpart1 x)))))
  (redraw)
  (checkevent)
  (close_window))


(defun drawpoints (points)
  (init_window 400 400)
  (do ((l points (cdr l))
       (ret nil))
    ((atom l)(drawlines ret)(redraw)(checkevent)(close_window))
    (push (cons (fix (caar l))(fix (cadar l))) ret)))
(defun drawbezier (points bezier)
  (init_window 400 400)
  (drawlines (setpart1 bezier))
  (do ((l points (cdr l))
       (ret nil))
    ((atom l)(drawlines ret)(redraw)(checkevent)(close_window))
    (push (cons (fix (caar l))(fix (cadar l))) ret)))
(defun drawbezier1 (points bezier)
  (init_window 400 400)
  (do ((l bezier (cdr l))
       (ret nil))
    ((atom l)(drawlines ret))
    (push (cons (fix (cadr (car l)))(fix (caddr (car l)))) ret))
  (do ((l points (cdr l))
       (ret nil))
    ((atom l)(drawlines ret)(redraw)(checkevent)(close_window))
    (push (cons (fix (caar l))(fix (cadar l))) ret)))
;
(defun jointtest (prim1 prim2 affine type)
  (filltest 
   (rmlimit (appendpart prim1 
	       (affinepart prim2 affine))) type))
(defun rmlimit (x)
  (lets ((elements (cadr x))(ret))
    (do ((l elements (cdr l)))
      ((atom l)`(,(car x) ,(nreverse ret) .,(cddr x)))
      (or (memq (caar l) '(xlimit ylimit))(push (car l) ret)))))
; 
; Bezier曲線を直線群で近似する
;
(defun bez (x0 y0 x1 y1 x2 y2 x3 y3 (dlist))
  (lets ((maxx (max x0 x1 x2 x3))
	 (maxy (max y0 y1 y2 y3))
	 (minx (min x0 x1 x2 x3))
	 (miny (min y0 y1 y2 y3)))
    (cond 
     ((or (lessp (difference maxx minx) 2)
	  (lessp (difference maxy miny) 2))
      `((,(fix x3) . ,(fix y3)).,dlist))
     (t 
      (lets ((tempx (times 0.125 (plus x0 (times 3 x1)(times 3 x2) x3)))
	     (tempy (times 0.125 (plus y0 (times 3 y1)(times 3 y2) y3))))
	(bez tempx tempy 
	     (times (plus x3 x2 x2 x1) 0.25)
	     (times (plus y3 y2 y2 y1) 0.25)
	     (times (plus x3 x2) 0.5)
	     (times (plus y3 y2) 0.5) 
	     x3 y3 
	     (bez x0 y0 
		  (times (plus x0 x1) 0.5)
		  (times (plus y0 y1) 0.5)
		  (times (plus x0 x1 x1 x2) 0.25)
		  (times (plus y0 y1 y1 y2) 0.25)
		  tempx tempy dlist)))))))
;
; アウトラインから折れ線への変換を行なう
;

(defun setpart1 (l)
  (and l
  (lets ((last (car l))
	 (curx (cadr last))
	 (cury (caddr last))
	 (x0)(y0)(x1)(y1)(x2)(y2)
	 (ret `((,(fix curx).,(fix cury)))))
    (do ((ll (cdr l) (cdr ll)))
      ((atom ll)ret)
      (match ll
	((('angle x0 y0).next)
	 (setq ret `((,(fix x0).,(fix y0)).,ret))
	 (setq curx x0 cury y0))
	((('bezier x0 y0)('bezier x1 y1))
	 (exit (bez curx cury x0 y0 x1 y1 (cadr last)(caddr last) ret)))
	((('bezier x0 y0)('bezier x1 y1)('angle x2 y2).next)
	 (setq ret (bez curx cury x0 y0 x1 y1 x2 y2 ret))
	 (setq curx x2 cury y2)
	 (setq ll (cddr ll)))
	(any (break) ; 想定しない入力
	     ))))))

(defun jointtest (prim1 prim2 affine type)
  (filltest 
   (rmlimit (appendpart prim1 
	       (affinepart prim2 affine))) type))