[wadalabfont-kit] / lisp / disp.l  

Diff of /lisp/disp.l

Parent Directory | Revision Log

version 1.2, Thu Jun 19 08:15:18 2003 UTC version 1.5, Thu Jul 3 02:01:26 2003 UTC
Line 2 
Line 2 
 ;  ;
 ;  ;
 ;(code-load '("/home/ktanaka/work/wadalabfont/lisp/window.o") "/usr/X11R6/lib/libX11.so")  ;(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  (declare (err:argument-type err:number-of-arguments err:unbound-variable
                             err:zero-division err:undefined-function) special)                              err:zero-division err:undefined-function) special)
Line 47 
Line 48 
                   (err:undefined-function #'(lambda (x (y))(throw 'err)))                    (err:undefined-function #'(lambda (x (y))(throw 'err)))
                   (err:zero-division #'(lambda (x (y))(throw 'err))))                    (err:zero-division #'(lambda (x (y))(throw 'err))))
               (catch 'err                (catch 'err
                 (skelton2list (normkanji (rm-limit (applykanji (car ol) tag)) tag)))))                  (skeleton2list (normkanji (rm-limit (applykanji (car ol) tag)) tag)))))
       (cond        (cond
        ((atom l)         ((atom l)
         (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n")          (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n")
Line 126 
Line 127 
 ; スケルトンデータを renderingして表示する  ; スケルトンデータを renderingして表示する
 ;  ;
 (defun showSkeleton (skeleton tag)  (defun showSkeleton (skeleton tag)
   (showOutline (skelton2list skeleton tag)))    (showOutline (skeleton2list skeleton tag)))
 ;  ;
 ; スケルトンデータを折れ線に変換する．  ; スケルトンデータを折れ線に変換する．
 ;  ;
Line 189 
Line 190 
 (defun showtest1 (l tag)  (defun showtest1 (l tag)
   (lets ((outline nil))    (lets ((outline nil))
     (init_window 400 400)      (init_window 400 400)
     (setq outline (makeoutline (skelton2list (applykanji l tag) tag)))      (setq outline (makeoutline (skeleton2list (applykanji l tag) tag)))
     (mapcar outline '(lambda (x)(drawlines (setpart1 x))))      (mapcar outline '(lambda (x)(drawlines (setpart1 x))))
     (redraw)      (redraw)
     (checkevent)      (checkevent)
Line 200 
Line 201 
   
 (defun filltest (l tag)  (defun filltest (l tag)
   (init_window 400 400)    (init_window 400 400)
   (mapcar (skelton2list (rm-limit (applykanji l tag)) tag)    (mapcar (skeleton2list (rm-limit (applykanji l tag)) tag)
     (function (lambda (x)(fillpolygon (setpart1 x)))))      (function (lambda (x)(fillpolygon (setpart1 x)))))
   (redraw)    (redraw)
   (checkevent)    (checkevent)
   (close_window))    (close_window))
   
 ;  
 ; pointを結ぶtension 1のスプラインを求める  
 ;  
 (declare (alpha beta gamma sqrt2 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))))))  
   
 (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))))  
   
 (defun drawpoints (points)  (defun drawpoints (points)
   (init_window 400 400)    (init_window 400 400)
Line 399 
Line 232 
     ((atom l)(drawlines ret)(redraw)(checkevent)(close_window))      ((atom l)(drawlines ret)(redraw)(checkevent)(close_window))
     (push (cons (fix (caar l))(fix (cadar l))) ret)))      (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))

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

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help