View of /lisp/samples/disp-test.l

Parent Directory

Revision Log

*** empty log message ***

; X-Windowを扱うためのCの関数をロードする
;
;

(cond ((definedp 'init_window))
      (t (code-load "window.o" "-lX11")))

; bez
; Bezier曲線を直線群で近似する
;

(defun bez (x0 y0 x1 y1 x2 y2 x3 y3)
  (let ((maxx (max x0 x1 x2 x3))
	(maxy (max y0 y1 y2 y3))
	(minx (min x0 x1 x2 x3))
	(miny (min y0 y1 y2 y3))
	(tempx 0)(tempy 0))
    (cond ((or (< (- maxx minx) 2)(< (- maxy miny) 2))
	   `((,x3 . ,y3)))
	  (t 
	   (setq tempx (// (+ x0 (* 3 x1)(* 3 x2) x3) 8))
	   (setq tempy (// (+ y0 (* 3 y1)(* 3 y2) y3) 8))
	   (append
	    (bez x0 y0 (// (+ x0 x1) 2)(// (+ y0 y1) 2)
		 (// (+ x0 x1 x1 x2) 4)(// (+ y0 y1 y1 y2) 4)
		 tempx tempy)
	    (bez tempx tempy (// (+ x3 x2 x2 x1) 4)(// (+ y3 y2 y2 y1) 4)
		 (// (+ x3 x2) 2)(// (+ y3 y2) 2) x3 y3))))))

; 
; floatとfixの間の型変換を行なう
;

(defun tofix (l)
  (cond ((floatp l)(fix l))
	(t l)))

(defun toflo (l)
  (cond ((fixp l)(float l))
	(t l)))

;
; アウトラインから折れ線への変換を行なう
;

(defun setpart1 (l)
  (lets (
	 (last (car l))
	 (x0 (cadr last))
	 (y0 (caddr last))
	 (curx (tofix x0))
	 (cury (tofix y0))
	 (ret (ncons (cons curx cury))))
    (do ((ll (cdr l) (cdr ll)))
      ((atom ll)ret)
      (match 
	  (car ll)
	(('angle x0 y0)
	 (setq x0 (tofix x0) y0 (tofix y0))
	 (setq curx x0 cury y0)
	 (nconc ret (ncons(cons x0 y0))))
	(('bezier x0 y0)
	 (setq next (cadr ll))
	 (setq nextnext 
	       (cond ((cddr ll)(setq ll (cddr ll))(car ll))
		     (t (setq ll (cdr ll))last)))
	 (setq x0 (tofix x0) y0 (tofix y0))
	 (setq x1 (tofix (cadr next)) y1 (tofix (caddr next)))
	 (setq x2 (tofix (cadr nextnext)) y2 (tofix (caddr nextnext)))
	 (nconc ret (bez curx cury x0 y0 x1 y1 x2 y2))
	 (setq curx x2 cury y2))))))

;
; スケルトンからアウトラインへの変換を行なう
;

(defun point-n (n points)
  (let ((point (nth n points)))
    `(,(toflo (car point)),(toflo (cadr point)) .,(cddr point))))

(defun skeleton2list (l tag)
  (let ((linkpoints nil)
	(linelist nil)
	(outline nil)
	(points (car l))
	(lines (cadr l)))
    (do ((ll points (cdr ll))
	 (linkcount 0 (1+ linkcount)))
      ((atom ll))
      (push (list linkcount (ncons 'link)) linkpoints))
    (do ((ll lines (cdr ll)))
      ((atom ll))
      (setq part (car ll))
      (setq type (car part))
      (setq npoint (get type 'npoint))
      (setq cpoint (cadr part))
      (setq lpoint (assq 'link (cddr part)))
      (setq lpoint (cond (lpoint (cdr lpoint))))
      (setq partpoint nil)
      (do ((lll cpoint (cdr lll)))
	((atom lll))
	(push (point-n  (car lll) points) partpoint))
      (setq tmpline 
	    `(lines ,(funcall (get type tag)(nreverse partpoint)(cddr part))))
      (push tmpline linelist)
      (do ((lll cpoint (cdr lll))
	   (i 0 (1+ i)))
	  ((atom lll))
	  (cond ((zerop i)
		 (setq flag 0))
		((eq i (1- npoint))
		 (setq flag 1))
		(t (setq flag 2)))
	  (setq link (assq 'link (cdr (assq (car lll) linkpoints))))
	  (rplacd link (cons (list type flag tmpline) (cdr link))))
      (do ((lll lpoint (cdr lll)))
	((atom lll))
	(setq link (assq 'link (cdr (assq (car lll) linkpoints))))
	(rplacd link (cons (list type 2 tmpline) (cdr link)))))
    (do ((ll linkpoints (cdr ll)))
      ((atom ll))
      (setq link (assq 'link (cdar ll)))
      (cond ((eq 3 (length link))
	     (setq part1 (cadr link) part2 (caddr link))
	     (setq type1 (cadr part1) type2 (cadr part2))
	     (setq cross (crosspoint part1 part2))
	     (setq kazari
		   (selectq type1
		    (1
		     (selectq type2
		      (1
		       (append
			(findkazari part1 part2 0 1 cross tag)
			(findkazari part1 part2 1 0 cross tag)))
		      (t
		       (append
			(findkazari part1 part2 0 0 cross tag)
			(findkazari part1 part2 1 1 cross tag)))))
		    (t
		     (selectq type2
		      (1
		       (append
			(findkazari part1 part2 0 0 cross tag)
			(findkazari part1 part2 1 1 cross tag)))
		      (t
		       (append
			(findkazari part1 part2 0 1 cross tag)
			(findkazari part1 part2 1 0 cross tag)))))))
	     (cond ((> (length kazari) 2) (push kazari outline)))
	     )
	    ((and (eq 2 (length link))(<= 0 (cadadr link) 1))
	     (setq part1 (cadr link))
	     (setq type1 (cadr part1))
	     (setq cross (cross2point part1 (point-n (caar ll) points)))
	     (setq kazari
		   (findkazari part1 part1 0 1 cross tag))
	     (nconc (assq 'lines (cddr part1)) (ncons(cons (- -1 type1) kazari))))))
    (do ((ll linelist (cdr ll))
       (part0 nil)
       (part1 nil))
      ((atom ll))
      (setq part0 (car (cadar ll)))
      (setq part1 (cadr (cadar ll)))
      (setq part2 nil part3 nil)
      (do ((lll (cddar ll) (cdr lll)))
	  ((atom lll))
	  (selectq (caar lll)
		   (-2 (setq part3 (cond ((cdar lll)(cddar lll)))))
		   (-1 (setq part2 (cond ((cdar lll)(reverse (cddar lll))))))
		   (0 (setq part0 (change-head part0 (cdar lll))))
		   (1 (setq part1 (change-head part1 (cdar lll))))
		   (2 (setq part0 (change-tail part0 (cdar lll))))
		   (3 (setq part1 (change-tail part1 (cdar lll))))))
      (push (append part0 part3 (reverse part1) part2) outline))
  outline))

;
; 始点を変更する
;

(defun change-head (l c)
  (lets ((first (car l))
	 (second (cadr l)))
	(cond ((eq 'bezier (car second))
	       (append (change-bezier l c)(cddddr l)))
	      (t (cons (cons 'angle c)(cdr l))))))

;
; 終点を変更する
; bug
; bug
; bug
(defun change-tail (ll c)
  (reverse (change-head (reverse ll) c)))

;
; Bezier曲線の制御点を始点の変化にあわせて変更する
;

(defun change-bezier (l c)
  (lets ((p0 (car l))
	 (p1 (cadr l))
	 (p2 (caddr l))
	 (p3 (cadddr l)))
	(list (cons 'angle c) p1 p2 p3)))

;
; メンバーかどうか
;

(defun eq_member (l pat)
  (cond ((eq pat '*)t)
	((atom pat)(eq l pat))
	(t (memq l pat))))

;
; 飾りのアウトラインを求める
;

(defun findkazari (part1 part2 line1 line2 cross tag)
  (lets 
   ((ret nil)
    (parttype1 (car part1))
    (parttype2 (car part2))
    (type1 (cadr part1))
    (type2 (cadr part2))
    (line1 (+ (* 2 type1)line1))
    (line2 (+ (* 2 type2)line2)))
   (do ((l (get 'allkazari tag) (cdr l))
	(ll nil))
       ((atom l)ret)
       (setq ll (car l))
;       (print (list ll type1 type2 line1 line2))
       (cond ((and (eq_member parttype1 (car ll))
		   (eq_member line1 (cadr ll))
		   (eq_member parttype2 (caddr ll))
		   (eq_member line2 (cadddr ll)))
	      (setq ret (funcall (car (cddddr ll)) cross))
	      (nconc (assq 'lines (cddr part1)) (ncons(cons line1 (cdr (car ret)))))
	      (nconc (assq 'lines (cddr part2)) (ncons (cons line2 (cdar (last ret)))))
	      (exit ret))
	     ((and (eq_member parttype2 (car ll))
		   (eq_member line2 (cadr ll))
		   (eq_member parttype1 (caddr ll))
		   (eq_member line1 (cadddr ll)))
	      (setq ret (funcall (car (cddddr ll)) (rev4 cross)))
	      (nconc (assq 'lines (cddr part1)) (ncons(cons line1 (cdar (last ret)))))
	      (nconc (assq 'lines (cddr part2)) (ncons(cons line2 (cdr (car ret)))))
	      (exit ret))))
   (cond 
    (ret)
    ((eq part1 part2)nil)
    (t
     (setq ret (ncons (append '(angle) (vref cross (+ (logand line2 1) (* 2 (logand 1 line1)))))))
     (nconc (assq 'lines (cddr part1)) (ncons(cons line1 (cdar ret))))
     (nconc (assq 'lines (cddr part2)) (ncons(cons line2 (cdar ret))))
     ret))))

;
; 転置行列
;

(defun rev4 (cross)
  (let ((ret (vector 4 cross)))
    (vset ret 2 (vref cross 1))
    (vset ret 1 (vref cross 2))
    ret))

;
; 2つのpartの間の点
;

(defun crosspoint (part1 part2)
  (let ((ret (vector 4))
	(line0 (caadr (assq 'lines (cddr part1))))
	(line1 (cadadr (assq 'lines (cddr part1))))
	(line2 (caadr (assq 'lines (cddr part2))))
	(line3 (cadadr (assq 'lines (cddr part2)))))
    (selectq (cadr part1)
	     (0
	      (setq line0 (list (car line0)(cadr line0)))
	      (setq line1 (list (car line1)(cadr line1))))
	     (1
	      (setq line0 (reverse line0) line1 (reverse line1))
	      (setq line0 (list (car line0)(cadr line0)))
	      (setq line1 (list (car line1)(cadr line1)))))
    (selectq (cadr part2)
	     (0
	      (setq line2 (list (car line2)(cadr line2)))
	      (setq line3 (list (car line3)(cadr line3))))
	     (1
	      (setq line2 (reverse line2) line3 (reverse line3))
	      (setq line2 (list (car line2)(cadr line2)))
	      (setq line3 (list (car line3)(cadr line3)))))
    (vset ret 0 (linecross line0 line2))
    (vset ret 1 (linecross line0 line3))
    (vset ret 2 (linecross line1 line2))
    (vset ret 3 (linecross line1 line3))
    ret))

;
; partからpointへの垂線とその他の2点
;

(defun cross2point (part1 point)
  (let ((ret (vector 4))
	(line0 (caadr (assq 'lines (cddr part1))))
	(line1 (cadadr (assq 'lines (cddr part1)))))
    (selectq (cadr part1)
	     (0
	      (setq line0 (list (car line0)(cadr line0)))
	      (setq line1 (list (car line1)(cadr line1))))
	     (1
	      (setq line0 (reverse line0) line1 (reverse line1))
	      (setq line0 (list (car line0)(cadr line0)))
	      (setq line1 (list (car line1)(cadr line1)))))
    (lets ((p0 (nearest line0 point))
	   (p1 (nearest line1 point))
	   (l00 (list (toflo (cadar line0))(toflo (caddar line0))))
	   (l01 (list (toflo (cadadr line0))(toflo (cadr (cdadr line0)))))
	   (l10 (list (toflo (cadar line1))(toflo (caddar line1))))
	   (l11 (list (toflo (cadadr line1))(toflo (cadr (cdadr line1))))))
	  (cond 
	   ((or (null p0)(null p1))
	    (setq p0 (list (toflo (car point))(toflo (cadr point))))
	    (vset ret 0 p0)
	    (vset ret 1 p0)
	    (vset ret 2 p0)
	    (vset ret 3 p0))
	   (t
	    (vset ret 0 p0)
	    (vset ret 1 p1)
	    (vset ret 2 
		  (plus2 
		   p0
		   (normlen2 (sqrt(fmetric (car p0)(cadr p0)(car p1)(cadr p1)))
			     (diff2 l01 l00))))
	    (vset ret 3 
		  (plus2 
		   p1
		   (normlen2 (sqrt(fmetric (car p0)(cadr p0)(car p1)(cadr p1)))
			     (diff2 l11 l10))))))
      ret)))
	
;
; もっとも近い点
;

(defun nearest (l0 point)
  (lets ((ax (toflo (cadr (car l0))))
	 (ay (toflo (caddr (car l0))))
	 (bx (-$ (toflo(cadr (cadr l0))) ax))
	 (by (-$ (toflo(caddr (cadr l0))) ay))
	 (cx (tofix (car point)))
	 (cy (tofix (cadr point))))
	(linecross l0 `((angle ,cx ,cy)(angle ,(+ cx (fix by)),(- cy (fix bx)))))))

;
; lineの交点
;

(defun linecross (line0 line1)
  (cond ((eq 2 (length line0))
	 (setq l0 line0 ll1 line1))
	(t (setq l0 line1 ll1 line0)))
  (do ((l1 ll1 (cdr l1)))
      ((atom (cdr l1)))
      (lets ((ax (toflo (cadr (car l0))))
	     (ay (toflo (caddr (car l0))))
	     (bx (-$ (toflo(cadr (cadr l0))) ax))
	     (by (-$ (toflo(caddr (cadr l0))) ay))
	     (cx (toflo (cadr (car l1))))
	     (cy (toflo (caddr (car l1))))
	     (dx (-$ (toflo(cadr (cadr l1))) cx))
	     (dy (-$ (toflo (caddr (cadr l1))) cy))
	     (mat2 (vector 4 (list bx by (-$ dx)(-$ dy))))
	     (rmat nil)
	     (s nil))
	     (cond 
	      ((0=$ (-$ (*$ bx dy)(*$ by dx)))
	       (cond ((0=$ (-$ (*$ (-$ cx ax)by)(*$ (-$ cy ay)bx)))
		      (exit (list ax ay)))))
	      (t
	       (setq rmat2 (rmat mat2))
	       (setq s (+$ 
		   (*$ (vref rmat2 1)(-$ cx ax))
		   (*$ (vref rmat2 3)(-$ cy ay))))
	      (cond ((eq 2 (length l1))
		     (exit(list (+$ cx (*$ s dx))(+$ cy (*$ s dy)))))
		    ((and (0<$ s)(<$ s 1.0))
		     (exit(list (+$ cx (*$ s dx))(+$ cy (*$ s dy)))))))))))

;
; 逆行列
;

(defun rmat (mat)
  (let ((eigen (//$ 1.0 (-$ (*$ (vref mat 0)(vref mat 3))(*$ (vref mat 1)(vref mat 2)))))
	(ret (vector 4)))
    (vset ret 0 (*$ eigen (vref mat 3)))
    (vset ret 1 (*$ eigen -1.0 (vref mat 1)))
    (vset ret 2 (*$ eigen -1.0 (vref mat 2)))
    (vset ret 3 (*$ eigen (vref mat 0)))
    ret))

;
; PSファイルの出力
;

(defun out-to-ps-all (outlines tag psfile (col 9)(line 6))
  (let ((standard-output (outopen (stream psfile)))
	(date (date-time)))
    (format "%!/n50 50 translate/n0.2 0.2 scale/n")
    (format "//Helvetica findfont 70 scalefont setfont/n")
    (setq i 0 j 0 page 1)
    (format "0 -70 moveto (/c-/c-/c /c:/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) page)
    (do 
     ((ol outlines (cdr ol))
      (l nil))
     ((atom ol))
     (setq l (skeleton2list (applykanji (car ol)) tag))
     (cond 
      ((atom l))
      (t
       (do ((ll l (cdr ll)))
	   ((atom ll))
	   (setq last (caar ll))
	   (format "newpath /c /c moveto/n" (tofix (cadr last))
		   (- 400 (tofix (caddr last))))
	   (do ((lll (cdar ll) (cdr lll)))
	       ((atom lll))
	       (match 
		(car lll)
		(('angle x y)
		 (format "/c /c lineto/n" (tofix x) (- 400 (tofix 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"
		  (tofix x0) (- 400 (tofix y0)) (tofix x1) (- 400 (tofix y1)) (tofix x2) (- 400 (tofix y2))))))
	   (format "closepath fill/n"))
       (setq i (1+ i))
       (cond ((eq i col)
	      (format "400 /c translate/n" (* -400 (1- col)))
	      (setq i 0)
	      (setq j (1+ j))
	      (cond ((eq j line)
		     (format "showpage/n50 50 translate/n0.2 0.2 scale/n")
		     (format "//Helvetica findfont 70 scalefont setfont/n")
		     (setq page (1+ page))
		     (format "0 -70 moveto (/c-/c-/c /c:/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)page)
		     (setq j 0))))
	     (t (format "0 400 translate/n"))))))
    (format "showpage/n"))
)

;
; 組み合わせたものを使う
;

(defun applykanji (l)
  (cond ((null l)nil)
	((symbolp l) (applykanji (eval l)))
	((atom l)l)
	(t (cond ((eq (car l) 'lisp)
		  (eval (cadr l))
		  (applykanji (caddr l)))
		 ((atom (car l))
		  (apply (car l) (mapcar (cdr l) 'applykanji)))
		 (t l)))))

;
; アウトライン形式で表示する
;

(defun showtest (l tag)
  (setq outline (skeleton2list (applykanji l) tag))
  (show (mapcar outline '(lambda (x) (link-to-out (list-to-link x))))))

;
; 塗りつぶして表示する
;

(defun filltest (l tag)
  (init_window 400 400)
  (setq outline (skeleton2list (applykanji l) tag))
  (mapcar outline '(lambda (x)(fillpolygon (setpart1 x))))
  (redraw)
  (checkevent)
  (close_window))