[wadalabfont-kit] / lisp / test / maketestdata.l  

Diff of /lisp/test/maketestdata.l

Parent Directory | Revision Log

version 1.1, Thu Dec 28 08:54:19 2000 UTC version 1.2, Fri Jun 20 11:40:23 2003 UTC
Line 1 
Line 1 
 (defun show-skelton (outline)  (defun show-skeleton (outline)
 ;  (format "%!/n50 50 translate/n0.001 /c mul dup scale/n" 160)  ;  (format "%!/n50 50 translate/n0.001 /c mul dup scale/n" 160)
 ;  (princ "/dot { /y exch def /x exch def")(terpri)  ;  (princ "/dot { /y exch def /x exch def")(terpri)
 ;  (princ "newpath x 400 y sub 4 0 360 arc closepath fill } def")(terpri)  ;  (princ "newpath x 400 y sub 4 0 360 arc closepath fill } def")(terpri)
Line 15 
Line 15 
       (format "10 setlinewidth newpath /c /c moveto/n" (fix (car p))(- 400 (fix (cadr p))))        (format "10 setlinewidth newpath /c /c moveto/n" (fix (car p))(- 400 (fix (cadr p))))
       (format "/c /c lineto closepath stroke/n"        (format "/c /c lineto closepath stroke/n"
               (fix (car p1))(- 400 (fix (cadr p1)))))))                (fix (car p1))(- 400 (fix (cadr p1)))))))
 (defun cross-skelton (outline tag)  (defun cross-skeleton (outline tag)
   (format "%!/n50 50 translate/n0.001 /c mul dup scale/n" 160)    (format "%!/n50 50 translate/n0.001 /c mul dup scale/n" 160)
   (princ "/dot { /y exch def /x exch def")(terpri)    (princ "/dot { /y exch def /x exch def")(terpri)
   (princ "newpath x 400 y sub 4 0 360 arc closepath fill } def")(terpri)    (princ "newpath x 400 y sub 4 0 360 arc closepath fill } def")(terpri)
   (setq crosses (skelton2cross outline tag))    (setq crosses (skeleton2cross outline tag))
   (do ((l crosses (cdr l)))    (do ((l crosses (cdr l)))
     ((atom l))      ((atom l))
     (format "/c /c dot/n" (fix(caar l))(fix(cadar l)))))      (format "/c /c dot/n" (fix(caar l))(fix(cadar l)))))
Line 44 
Line 44 
      ((atom ol))       ((atom ol))
      (princ ";" terminal-output)       (princ ";" terminal-output)
      (print (car ol) terminal-output)       (print (car ol) terminal-output)
      (setq l (skelton2list (applykanji (car ol) tag) tag))       (setq l (skeleton2list (applykanji (car ol) tag) tag))
      (and numberflag       (and numberflag
           (format "0 0 moveto (/c) show/n" (plus 1 i (times j col))))            (format "0 0 moveto (/c) show/n" (plus 1 i (times j col))))
      (format "0 setlinewidth/n")       (format "0 setlinewidth/n")
 ;     (format "newpath 0 0 moveto 400 0 lineto/n")  ;     (format "newpath 0 0 moveto 400 0 lineto/n")
 ;     (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n")  ;     (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n")
      (show-skelton (car ol))       (show-skeleton (car ol))
      (do ((ll l (cdr ll)))       (do ((ll l (cdr ll)))
        ((atom ll))         ((atom ll))
        (setq last (caar ll))         (setq last (caar ll))
Line 78 
Line 78 
             (setq i 0 j (1+ j))              (setq i 0 j (1+ j))
             (format "500 /c translate/n" (* -500 (1- col))))              (format "500 /c translate/n" (* -500 (1- col))))
            (t (format "0 500 translate/n"))))))             (t (format "0 500 translate/n"))))))
 (defun skelton2list1 (l tag)  (defun skeleton2list1 (l tag)
   (let ((linkpoints nil)    (let ((linkpoints nil)
         (linelist nil)          (linelist nil)
         (outline nil)          (outline nil)
Line 144 
Line 144 
       (push part1 outline))        (push part1 outline))
   outline))    outline))
   
 (defun skelton2cross (l tag)  (defun skeleton2cross (l tag)
   (let ((linkpoints nil)    (let ((linkpoints nil)
         (linelist nil)          (linelist nil)
         (retcross nil)          (retcross nil)
Line 298 
Line 298 
                  (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 (applykanji (car ol) tag) tag))))                 (skeleton2list (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")

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

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help