[wadalabfont-kit] / renderer / apply.l  

View of /renderer/apply.l

Parent Directory | Revision Log
Revision: 1.8 - (download) (annotate)
Thu Jul 3 13:38:09 2003 UTC (20 years, 10 months ago) by ktanaka
Branch: MAIN
CVS Tags: SNAP-20040518, HEAD
Changes since 1.7: +1 -0 lines 
*** empty log message ***

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

;
; pointsのn番目を取り，floatに変換する
;
(defun point-n (n points)
  (let ((point (nth n points)))
    `(,(float (car point)),(float (cadr point)) .,(cddr point))))

;
; points全体をfloatに変換する
;
(defun floatlist (list)
  (mapcar list 
    (function (lambda (x) `(,(float (car x)),(float (cadr x)).,(cddr x))))))
;
; 見てのとおり
;
(defun appendrev (a b) (append a (reverse b)))
;
;
;
(defun skeleton2list (l tag)
  ; 仮想的なエレメント xlimit, ylimitを取り除く
  (setq l (rm-limit l))
  ; 書体固有のスケルトン変形関数が定義されている場合は呼び出す
  (let ((func (get-def 'typehook tag)))
    (and func (setq l (funcall func l))))
  (let ((linkpoints nil)
	(linelist nil)
	(outline nil)
	(points (floatlist(car l)))
	(part nil)(type nil)(cpoint nil)(lpoint nil)(partpoint nil)
	(tmppoint nil)(flag nil)(link nil)(part1 nil)(part2 nil)
	(tmpline nil)(type3 nil)
	(type1 nil)(type2 nil)(cross nil)(kazari nil)(part3 nil)
	(lines (cadr l)))
    ; 配列linkpointsの初期化
    (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)
	(push (nth (car lll) points) partpoint))
      (setq partpoint (nreverse partpoint))

;; tag に対するプロパティが未定義のときのため(石井)
;; if を使わないように直す(田中)
      (setq tmpline 
	    (lets ((funcname (get-def type tag))
		   (result (cond (funcname
				  (funcall funcname
					   partpoint(cddr part)))
				 (t
				  (print (list 'undefined tag))
				  (funcall (get type 'mincho)
					   partpoint(cddr part))))))
	      `(lines ,result)))

      (push tmpline linelist)
      (do ((lll cpoint (cdr lll))
	   (i 0 (1+ i)))
	  ((atom lll))
	  (cond ((zerop i)
		 (setq flag 0))
		((atom (cdr lll));(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 4 (length link))
	(setq part1 (second link) part2 (third link) part3 (fourth link))
	(setq type1 (cadr part1) type2 (cadr part2) type3 (cadr part3))
	(and (memq type1 '(0 1))(memq type2 '(0 1))(memq type3 '(0 1))
	     (lets ((ass1 (assq 'lines (cddr part1)))
		    (lines1 (second ass1))
		    (line10 (selectq type1
			      (0 (first lines1))
			      (1 (reverse (second lines1)))))
		    (line11 (selectq type1
			      (0 (second lines1))
			      (1 (reverse (first lines1)))))
		    (dir1 (diff2 (cdr (second line10))
				 (cdr (first line10))))
		    (ass2 (assq 'lines (cddr part2)))
		    (lines2 (second ass2))
		    (line20 (selectq type2
			      (0 (first lines2))
			      (1 (reverse (second lines2)))))
		    (line21 (selectq type2
			      (0 (second lines2))
			      (1 (reverse (first lines2)))))
		    (dir2 (diff2 (cdr (second line20))
				 (cdr (first line20))))
		    (ass3 (assq 'lines (cddr part3)))
		    (lines3 (second ass3))
		    (line30 (selectq type3
			      (0 (first lines3))
			      (1 (reverse (second lines3)))))
		    (line31 (selectq type3
			      (0 (second lines3))
			      (1 (reverse (first lines3)))))
		    (dir3 (diff2 (cdr (second line30))
				 (cdr (first line30))))
		    (theta12 (theta dir2 dir1))
		    (theta12 (cond ((minusp theta12)
				    (plus theta12 (times 2 3.14159265)))
				   (t theta12)))
		    (theta13 (theta dir3 dir1))
		    (theta13 (cond ((minusp theta13)
				    (plus theta13 (times 2 3.14159265)))
				   (t theta13)))
		    (next1 (cond ((lessp theta12 theta13)
				  2)
				 (t 3)))
		    (linesall (selectq next1
				(2
				 `(((,line11 ,line20)
				    ((,type1 ,ass1)(,type2 ,ass2)))
				   ((,line21 ,line30)
				    ((,type2 ,ass2)(,type3 ,ass3)))
				   ((,line31 ,line10)
				    ((,type3 ,ass3)(,type1 ,ass1)))))
				(3
				 `(
				   ((,line11 ,line30)
				    ((,type1 ,ass1)(,type3 ,ass3)))
				   ((,line31 ,line20)
				    ((,type3 ,ass3)(,type2 ,ass2)))
				   ((,line21 ,line10)
				    ((,type2 ,ass2)
				     (,type1 ,ass1))))))))
	       (do ((l linesall (cdr l))
		    (line0)(type0)(lines0)
		    (line1)(type1)(lines1)(p)(plist)(flag1)(flag2))
		 ((atom l)
		  (setq plist (nreverse plist))
		  (do ((ll plist (cdr ll))(i 0 (1+ i))
		       (start (car plist))(maxlen)(len0)(max))
		    ((atom (cdr ll))
		     (setq len0 (metric2 (car ll) start))
		     (and (greaterp len0 maxlen)(setq max i))
		     (setq max (remainder (1+ max) 3))
;		     (prind max)
;		     (prind plist)
;		     (prind linesall)
		     (setq type1 (car (first (second (nth max linesall)))))
		     (setq lines1 (cadr (first (second (nth max linesall)))))
		     (setq line1 `((angle .,(nth max plist))
				   (angle .,(nth (remainder (1+ max) 3) 
						 plist))
				   (angle .,(nth (remainder (+ 2 max) 3) 
						 plist))))
		     (nconc lines1 `((,(difference -1 type1)
				      .,(cond ((zerop type1)
					       (nreverse line1))
					      (t line1))
				      )))
;		     (prind `(,type1 ,lines1))
		     )
		    (setq len0 (metric2 (car ll) (cadr ll)))
		    (and (or (null maxlen)(greaterp len0 maxlen))
			 (setq maxlen len0)(setq max i))))
		 (setq line0 (first (caar l)) line1 (second (caar l)))
		 (setq type1 (caar (cadar l)) lines1 (cadar (cadar l)))
		 (setq type2 (caadr (cadar l)) lines2 (cadadr (cadar l)))
		 (setq flag1 (cond ((equal type1 0) 1)
				   (t 2)))
		 (setq flag2 (cond ((equal type2 0) 0)
				   (t 3)))
		 (setq p (linecross line0 line1))
		 (push p plist)
;		 (prind p)
		 (nconc lines1 `((,flag1 .,p)))
		 (nconc lines2 `((,flag2 .,p)))))))
       ((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
		    (appendrev
		     (findkazari part1 part2 0 1 cross tag)
		     (findkazari part1 part2 1 0 cross tag)))
		   (0
		    (appendrev
		     (findkazari part1 part2 0 0 cross tag)
		     (findkazari part1 part2 1 1 cross tag)))
		   (2
		    (find-last part1 part2))))
		(0
		 (selectq type2
		   (1
		    (appendrev
		     (findkazari part1 part2 1 1 cross tag)
		     (findkazari part1 part2 0 0 cross tag)))
		   (0
		    (appendrev
		     (findkazari part1 part2 1 0 cross tag)
		     (findkazari part1 part2 0 1 cross tag)))
		   (2 
		    (find-first part1 part2))))
		(2 (selectq type2
		     (0 (find-first part2 part1))
		     (1 (find-last part2 part1))))))
	(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 cross (cross2point part1 (nth (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)
;      (prind (cddar ll))
      (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))))
;		   (t (prind (caar lll)))
		   ))
      (push (append part0 part3 (reverse part1) part2) outline))
;    (break)
  outline))

; find-first part1 part2
; part1の始点をpart2の内部に来るように変更する
; nil を返す

(defun find-first (part1 part2)
  (lets ((lines0 (cadr (assq 'lines (cddr part1))))
	 (curve0 (car lines0))
	 (curve1 (cadr lines0))
	 (line0 (list (cdar curve0)(cdadr curve0)))
	 (line1 (list (cdar curve1)(cdadr curve1)))
	 (lines1 (cadr (assq 'lines (cddr part2))))
	 (curve0 (car lines1))
	 (curve1 (cadr lines1))
	 (p00 (cross2curve line0 curve0))
	 (p01 (cross2curve line0 curve1))
	 (p0 (inter2 p00 p01 0.75))
	 (p10 (cross2curve line1 curve0))
	 (p11 (cross2curve line1 curve1))
	 (p1 (inter2 p10 p11 0.85)))
    (nconc (assq 'lines (cddr part1)) `((0 .,p0)(1 .,p1)))
    nil))
;(defun find-first (part1 part2) nil)
; lineを延長してcurveへ交わる点があるかどうか
; ある時はその点を返す
;
(defun cross2curve (line curve)
  (do ((l curve (cdr l))
       (ll nil)
       (p0 (car line))
       (tmpcross)
       (p1 (cadr line)))
    ((atom (cdr l))(car line))
    (setq tmpcross
	  (cond ((eq (caadr l) 'angle)
		 (cross2line p0 p1 (cdar l) (cdadr l)))
		(t
		 (setq ll l l (cddr l))
		 (car (cross2bez p0 p1 (cdar ll) (cdadr ll) (cdaddr ll) (cdr (cadddr ll)))))))
    (cond (tmpcross (exit tmpcross)))))
; 
;
;
(defun cross2line (p0 p1 l0 l1)
  (lets ((d0 (diff2 p1 p0))
	 (d1 (diff2 l0 p0))
	 (d2 (diff2 l1 p0))
	 (sin0 (costheta (rot90 d0) d1))
	 (sin1 (costheta (rot90 d0) d2)))
	(cond ((0<$ (*$ sin0 sin1))nil)
	      (t (linecross (list (cons nil p0)(cons nil p1))
			    (list (cons nil l0)(cons nil l1)))))))
;
;
(defun cross2bez (p0 p1 b0 b1 b2 b3 (mint 0.0)(twidth 1.0))    
  (lets ((x0 (car b0))(y0 (cadr b0))
	 (x1 (car b1))(y1 (cadr b1))
	 (x2 (car b2))(y2 (cadr b2))
	 (x3 (car b3))(y3 (cadr b3))
	 (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 nil)(tempy nil)
	 (n0 nil)(ret nil)(tt nil))
;    (prind (list p0 p1 b0 b1 b2 b3))
        (cond ((or (<$ (-$ maxx minx) 2.0)(<$ (-$ maxy miny) 2.0))
;	       (break)
	       (setq ret (cross2line p0 p1 b0 b3))
	       (cond (ret
		      (setq tt 
			    (plus mint 
				  (times twidth 
					 (quotient (metric2 b0 ret)
						   (metric2 b0 b3)))))
		      `(,ret . ,tt))
		     (t `(nil . 0.0)))
	       )
	      (t
	       (setq tempx (//$ (+$ x0 (*$ 3.0 x1)(*$ 3.0 x2) x3) 8.0))
	       (setq tempy (//$ (+$ y0 (*$ 3.0 y1)(*$ 3.0 y2) y3) 8.0))
	       (setq n0 (list tempx tempy))
	       (lets ((d0 (diff2 p1 p0))
		      (d1 (diff2 b0 p0))
		      (d2 (diff2 n0 p0))
		      (sin0 (costheta (rot90 d0) d1))
		      (sin1 (costheta (rot90 d0) d2)))
		 (cond ((0<$ (*$ sin0 sin1))
			(setq d0 (diff2 p1 p0))
			(setq d1 (diff2 n0 p0))
			(setq d2 (diff2 b3 p0))
			(setq sin0 (costheta (rot90 d0) d1))
			(setq sin1 (costheta (rot90 d0) d2))
			(cond ((0<$ (*$ sin0 sin1))`(nil . 0.0))
			      (t
			       (cross2bez p0 p1 n0
					  (list (//$ (+$ x3 x2 x2 x1) 4.0)(//$ (+$ y3 y2 y2 y1) 4.0))
					  (list (//$ (+$ x3 x2) 2.0)(//$ (+$ y3 y2) 2.0))
					  b3
					  (plus mint (times twidth 0.5))
					  (times twidth 0.5)
					  ))))
		       (t
			(cross2bez p0 p1 b0
				   (list (//$ (+$ x0 x1) 2.0)(//$ (+$ y0 y1) 2.0))
				   (list (//$ (+$ x0 x1 x1 x2) 4.0)(//$ (+$ y0 y1 y1 y2) 4.0))
				   n0
				   mint
				   (times twidth 0.5)
				   ))))))))

	
; find-last part1 part2
; part1の終点をpart2の内部に来るように変更する
; nil を返す

(defun find-last (part1 part2)
  (lets ((lines0 (cadr (assq 'lines (cddr part1))))
	 (curve0 (reverse (car lines0)))
	 (curve1 (reverse (cadr lines0)))
	 (line0 (list (cdar curve0)(cdadr curve0)))
	 (line1 (list (cdar curve1)(cdadr curve1)))
	 (lines1 (cadr (assq 'lines (cddr part2))))
	 (curve0 (car lines1))
	 (curve1 (cadr lines1))
	 (p00 (cross2curve line0 curve0))
	 (p01 (cross2curve line0 curve1))
	 (p0 (inter2 p00 p01 0.4))
	 (p10 (cross2curve line1 curve0))
	 (p11 (cross2curve line1 curve1))
	 (p1 (inter2 p10 p11 0.3)))
    (nconc (assq 'lines (cddr part1)) `((2 .,p0)(3 .,p1)))
    nil))

;
; 始点を変更する
;

(defun change-head (l c)
  (lets ((first (car l))
	 (second (cadr l)))
;    (prind (list l c))
	(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)
;  (prind `(change-bezier ,l ,c))
  (lets ((p0 (cdr (first l)))
	 (p1 (cdr (second l)))
	 (p2 (cdr (third l)))
	 (p3 (cdr (fourth l)))
	 (dp0 (times2 3.0 (diff2 p1 p0)))
	 (dp3 (times2 3.0 (diff2 p3 p2)))
	 (ret)
	 (t1 (cond ((plusp (costheta (diff2 c p0)(diff2 p1 p0)))
		    (quotient (metric2 c p0)(metric2 p1 p0)3.0))
		   (t
		    (minus (quotient (metric2 c p0)(metric2 p1 p0) 3.0)))))
	 (twidth3 (times (difference 1.0 t1) (quotient 1.0 3.0))))
    (cond ((zerop twidth3)
	   `((angle .,c)(angle .,p3)))
	  (t
	   (lets ((newdp0 (times2 twidth3 (bezierdp p0 p1 p2 p3 t1)))
		  (newdp3 (times2 twidth3 dp3)))
	     (setq ret 
		   `((angle .,c)
		     (bezier .,(plus2 c newdp0))
		     (bezier .,(diff2 p3 newdp3))
		     (angle .,p3)))
;	     (prind `(,t1 ,twidth3 ,ret))
	     ret)))))

;
; メンバーかどうか
;

(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 ((tmptag tag (get tmptag 'parent)))
     ((null tmptag))
     (do ((l (get-def 'allkazari tmptag) (cdr l))
	  (ll nil))
       ((atom l)ret)
       (setq ll (car l))
       (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 (reverse ret)))))
     (and ret (exit)))
   (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 (float (cadar line0))(float (caddar line0))))
	   (l01 (list (float (cadadr line0))(float (cadr (cdadr line0)))))
	   (l10 (list (float (cadar line1))(float (caddar line1))))
	   (l11 (list (float (cadadr line1))(float (cadr (cdadr line1))))))
	  (cond 
	   ((or (null p0)(null p1))
	    (setq p0 (list (float (car point))(float (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 (metric2 p0 p1)
			     (diff2 l01 l00))))
	    (vset ret 3 
		  (plus2 
		   p1
		   (normlen2 (metric2 p0 p1)
			     (diff2 l11 l10))))))
      ret)))
	
;
; もっとも近い点
;

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

;
; lineの交点
;

(defun linecross (line0 line1)
  (lets ((l0 nil)(l1 nil)(ll0 nil)(ll1 nil))
  (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 (float (cadr (car l0))))
	     (ay (float (caddr (car l0))))
	     (bx (-$ (float(cadr (cadr l0))) ax))
	     (by (-$ (float(caddr (cadr l0))) ay))
	     (cx (float (cadr (car l1))))
	     (cy (float (caddr (car l1))))
	     (dx (-$ (float(cadr (cadr l1))) cx))
	     (dy (-$ (float (caddr (cadr l1))) cy))
	     (mat2 (vector 4 (list bx by (-$ dx)(-$ dy))))
	     (rmat nil)
	     (rmat2 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 hex1(x)
  (string (sref "0123456789abcdef" x)))
;
(defun hex2(h)
  (string-append (hex1 (logand 15 (logshift h -4)))
		(hex1 (logand 15 h))))
;
(defun euc2jis(str)
  (lets ((len (string-length str))
	 (newstr ""))
    (do ((i 0 (1+ i)))
      ((>= i len)newstr)
      (setq newstr (string-append newstr (hex2 (logand 127 (sref str i))))))))
;
; plistにfonttypeがあるときはそちらの定義を
; そうで無いときはsymbol valueを参照する
;
(defun get-def (symbol fonttype)
  (do ((l fonttype (get l 'parent))(def))
    ((null l)
     (and (boundp symbol)(eval symbol)))
    (and (setq def (get symbol l))(exit def))))
;
; 漢字のシンボルから，joint等をおこないskeletonを得る．
;
(defun applykanji (l (tag))
;  (prind l)
  (cond ((null l)nil)
	((symbolp l) 
	 (applykanji (get-def l tag) tag))
	((stringp l) (applykanji (unpackprim l) tag))
	((atom l)l)
	(t (cond 
	    ((eq (car l) 'joint)
;	     (prind l)(flush standard-output)
	     (joint tag 
		    (cadr (second l))
		    (mapcar (cadr (third l)) 
		      #'(lambda (x) (applykanji x tag)))
		    (fourth l)))
	    ((symbolp (car l))
	     (funcall (car l) tag (cdr l)))
	    (t (unpackprim l))))))
;
; 組み合わせたものを使う
;
(defun expandkanji (l (fonttype 'mincho))
  (cond ((symbolp l) 
	 (let ((ll(eval l)))
	   (cond ((and (consp ll)(symbolp (car ll)))
		  (expandkanji ll fonttype))
		 (t l))))
	((atom l) l)
	(t (cond 
	    ((eq (car l) 'joint)l)
	    ((symbolp (car l))
	     (cond ((get (car l) 'expand)
		    (funcall (get (car l) 'expand) fonttype (cdr l)))
		   (t (funcall (car l) fonttype (cdr l)))))
	    (t (unpackprim l))))))
;
(defun expandall (list (file)(fonttype 'mincho))
  (let ((standard-output (cond (file (outopen (stream file)))
			       (t standard-output))))
    (do ((l list (cdr l))
	 (ret))
      ((atom l))
      (princ (string-append "; " (car l)) terminal-output)(terpri terminal-output)
      (setq ret nil)
      (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:zero-division #'(lambda (x (y))(throw 'err))))
	(catch 'err
	  (setq ret (expandkanji (car l) fonttype))))
      (cond ((consp ret)
	     (prind `(defjoint ,(car l) ',ret)))))))
;
(defun applycache (l)
  (cond ((null l)nil)
	((symbolp l) 
	 (cond ((get l 'joint)
		(applycache (get l 'joint)))
	       (t
		(let ((ll(eval l)))
		  (cond ((and (consp ll)(symbolp (car ll)))
			 (expandkanji ll))
			(t l))))))
	((stringp l) (applycache (unpackprim l)))
	((atom l)l)
	(t (cond ((symbolp (car l))
		  (apply (car l) (mapcar (cdr l) 'applycache)))
		 (t (unpackprim l))))))
;
(defun clearcache ()
  (do ((l (oblist) (cdr l)))
    ((atom l))
    (remprop (car l) 'prim)))
;
; pointを結ぶtension 1のスプラインを求める
;
(declare (alpha beta gamma sqrt2 sqrt5 d16 sqrt51 sqrt35)special)
(setq alpha 1.0 beta 1.0 gamma 0.0)
(defun reduce_points(points)
  (do ((l points (cdr l))
       (ret nil)
       (old '(10000.0 10000.0)))
    ((atom l)(nreverse ret))
    (cond ((>$ 1.0 (metric2 old (car l))))
	  (t (push (car l) ret)
	     (setq old (car l))))))
(defun spline (points)
  (let ((fais nil)
	(points (reduce_points points))
	(thetas nil)
	(lengthes nil)
	(npoints 2)
	(psis nil)
	(array nil)
	(x nil)
	(ret nil)
	(b nil))
    (do ((l points (cdr l))
	 (p0 nil)
	 (p1 nil)
	 (p2 nil)
	 (d0 nil)
	 (d1 nil)
	 (theta nil)
	 (costheta nil)
	 (sintheta nil))
      ((atom (cddr l))
       (push (metric2 (car l)(cadr l)) lengthes)
       (setq lengthes (nreverse lengthes))
       (push 0.0 psis)
       (setq psis (nreverse psis)))
      (setq p0 (car l) p1 (cadr l) p2 (caddr l))
      (setq d1 (diff2 p2 p1) d0 (diff2 p1 p0))
      (setq theta (theta d1 d0))
      (setq npoints (1+ npoints))
      (push (metric2 (car l)(cadr l)) lengthes)
;      (print (list costheta sintheta theta lengthes))
      (push theta psis))
    (setq array (vector (* npoints npoints) 0.0))
    (setq x (vector npoints 0.0) b (vector npoints 0.0))
    (vset array 0 (-$ (//$ (*$ alpha alpha) beta) 
		      (*$ 3.0 (*$ alpha alpha))
		      (//$ (*$ gamma beta beta) alpha)))
    (vset array 1 (-$ (//$ (*$ gamma beta beta) alpha)
		      (*$ 3.0 (*$ beta beta gamma))
		      (//$ (*$ alpha alpha) beta)))
    (vset b 0 (*$ (-$ (car psis))(vref array 1)))
    (do ((i 1 (1+ i))
	 (tmppsi psis (cdr tmppsi))
	 (lk nil)
	 (lk1 nil)
	 (psi nil)
	 (psi1 nil)
	 (tmplen lengthes (cdr tmplen))
	 (offset (+ npoints 1) (+ offset npoints 1)))
      ((>= i (1- npoints)))
      (setq lk (car tmplen) lk1 (cadr tmplen))
      (setq psi (car tmppsi) psi1 (cadr tmppsi))
      (vset array (1- offset) (//$ (*$ beta beta) lk alpha))
      (vset array offset (+$ (*$ beta beta (//$ 1.0 lk)
				 (-$ 3.0 (//$ 1.0 alpha)))
			     (*$ alpha alpha (//$ 1.0 lk1)
				 (-$ 3.0 (//$ 1.0 beta)))))
      (vset array (1+ offset) (//$ (*$ alpha alpha) lk1 beta))
      (vset b i (-$ (*$ psi beta beta (//$ 1.0 lk)
			(-$ (//$ 1.0 alpha) 3.0))
		    (//$ (*$ psi1 alpha alpha) lk1 beta))))
    (vset array (- (* npoints npoints) 2)
	  (-$ (//$ (*$ gamma alpha alpha) beta)
	      (*$ 3.0 gamma alpha alpha)
	      (//$ (*$ beta beta) alpha)))
    (vset array (- (* npoints npoints) 1)
	  (-$ (//$ (*$ beta beta) alpha)
	      (*$ gamma alpha alpha)
	      (*$ 3.0 beta beta)))
;    (print "psis")
;    (print psis)
;    (print "lengthes")
;    (print lengthes)
;    (print "array")
    (do ((i 0 (1+ i)))
      ((>= i npoints))
      (do ((j 0 (1+ j))
	   (ret nil))
	((>= j npoints)(nreverse ret))
	(push (vref array (+ (* npoints i) j)) ret)))
;    (print "b")
    (do ((i 0 (1+ i))
	 (ret nil))
      ((>= i npoints)(nreverse ret))
      (push (vref b i) ret))
;    (print "gs")
    (gs npoints array x b)
    (do ((i 0 (1+ i))
	 (ret nil))
      ((>= i npoints)(setq thetas (nreverse ret)))
      (push (vref x i) ret))
;    (print "thetas")(print thetas)
    (setq ret `((angle .,(car points))))
    (do ((l points (cdr l))
	 (tmptheta thetas (cdr tmptheta))
	 (tmppsi psis (cdr tmppsi))
	 (diff nil)(p0 nil)(p1 nil)(fai nil)(f nil)(r nil)
	 (rotdiff nil)(sintheta nil)(costheta nil)(sinfai nil)(cosfai nil))
      ((atom (cdr l))(nreverse ret))
      (setq p0 (car l) p1 (cadr l))
      (setq diff (diff2 p1 p0))
      (setq rotdiff (rot90 diff))
      (setq sintheta (sin (car tmptheta)) costheta (cos (car tmptheta)))
      (setq fai (-$ 0.0 (car tmppsi)(cadr tmptheta)))
;      (print (list (car tmppsi)(cadr tmptheta)fai))
      (setq sinfai (sin fai) cosfai (-$ (cos fai)))
      (setq f (_f (car tmptheta) fai))
      (setq r (//$ f alpha))
      (push `(bezier .,(plus2 p0 (times2 (*$ r costheta) diff)
			      (times2 (*$ r sintheta) rotdiff))) ret)
      (setq f (_f fai (car tmptheta)))
      (setq r (//$ f beta))
      (push `(bezier .,(plus2 p1 (times2 (*$ r cosfai) diff)
			      (times2 (*$ r sinfai) rotdiff))) ret)
      (push `(angle .,p1) ret))))
      
(setq sqrt2 (sqrt 2.0) sqrt5 (sqrt 5.0) d16 (//$ 1.0 16.0))
(setq sqrt51 (-$ sqrt5 1.0) sqrt35 (-$ 3.0 sqrt5))
(defun _f (theta fai)
  (let ((sinfai (sin fai))
	(cosfai (cos fai))
	(sintheta (sin theta))
	(costheta (cos theta)))
    (//$ (+$ 2.0 (*$ sqrt2 
		     (-$ sintheta (*$ d16 sinfai))
		     (-$ sinfai (*$ d16 sintheta))
		     (-$ costheta cosfai)))
	 (*$ 3.0 (+$ 1.0
		     (*$ 0.5 sqrt51 costheta)
		     (*$ 0.5 sqrt35 cosfai))))))
    
;
; Gauss-Seidel 法により三重対角行列の解を求めているが，
; 優対角行列でない場合は問題があり
; LU分解の方が良い?
;
(defun gs (n array x b)
  (do ((i 0 (1+ i)))
    ((> i 10))
    (vset x 0 (//$ (-$ (vref b 0)
		       (*$ (vref array 1)(vref x 1))
		       (*$ (vref array (1- n))(vref x (1- n)))
		       )
		   (vref array 0)))
    (do ((j 1 (1+ j))
	 (offset (+ n 1) (+ offset n 1)))
      ((>= j (1- n)))
      (vset x j
	   (//$ (-$ (vref b j)
		    (+$ (*$ (vref array (1- offset))(vref x (1- j)))
			(*$ (vref array (1+ offset))(vref x (1+ j)))))
		     (vref array offset))))
    (vset x (1- n) (//$ (-$ (vref b (1- n))
			    (*$ (vref array (* (1- n) n))(vref x 0))
			    (*$ (vref array (- (* n n) 2))(vref x (- n 2))))
			    (vref array (1- (* n n)))))
    (do ((j 0 (1+ j))
	 (ret nil))
      ((>= j n)(nreverse ret))
      (push (vref x j)ret))))
ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help