[wadalabfont-kit] / renderer / apply.l  

Diff of /renderer/apply.l

Parent Directory | Revision Log

version 1.4, Mon Jun 30 13:27:02 2003 UTC version 1.6, Wed Jul 2 12:37:45 2003 UTC
Line 62 
Line 62 
 ; スケルトンからアウトラインへの変換を行なう  ; スケルトンからアウトラインへの変換を行なう
 ;  ;
   
   ;
   ; pointsのn番目を取り，floatに変換する
   ;
 (defun point-n (n points)  (defun point-n (n points)
   (let ((point (nth n points)))    (let ((point (nth n points)))
     `(,(float (car point)),(float (cadr point)) .,(cddr point))))      `(,(float (car point)),(float (cadr point)) .,(cddr point))))
   
   ;
   ; points全体をfloatに変換する
   ;
 (defun floatlist (list)  (defun floatlist (list)
   (mapcar list    (mapcar list
     (function (lambda (x) `(,(float (car x)),(float (cadr x)).,(cddr x))))))      (function (lambda (x) `(,(float (car x)),(float (cadr x)).,(cddr x))))))
   ;
   ; 見てのとおり
   ;
 (defun appendrev (a b) (append a (reverse b)))  (defun appendrev (a b) (append a (reverse b)))
   ;
   ;
   ;
 (defun skeleton2list (l tag)  (defun skeleton2list (l tag)
   (setq l (rm-limit l))    (setq l (rm-limit l))
   (let ((func (get-def 'typehook tag)))    (let ((func (get-def 'typehook tag)))
Line 781 
Line 793 
   (do ((l (oblist) (cdr l)))    (do ((l (oblist) (cdr l)))
     ((atom l))      ((atom l))
     (remprop (car l) 'prim)))      (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))))

Generate output suitable for use with a patch program
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.6
ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help