[wadalabfont-kit] / renderer / out2ps.l  

Diff of /renderer/out2ps.l

Parent Directory | Revision Log

version 1.1, Thu Jun 19 08:15:20 2003 UTC version 1.7, Thu Jul 3 11:42:38 2003 UTC
Line 1 
Line 1 
 (defun rm-limit (prim)  ;
   (do ((l (cadr prim) (cdr l))(ret))  ; ファイルのヘッダの出力
     ((atom l)`(,(car prim) ,(nreverse ret).,(cddr prim)))  ;
     (or (memq (caar l) '(xlimit ylimit))  
         (push (car l) ret))))  (defun outputFileHeader (scale line col)
 (defun out-to-ps-all (outlines tag psfile  
                                (nameflag)  
                                (col 9)(line (fix (times 0.67 col)))  
                                (printfile t))  
   (lets ((standard-output (outopen (stream psfile)))  
         (scale (fix (times 160.0 (min (//$ 9.0 (float col))  
                                       (//$ 6.0 (float line))))))  
         (ii nil)(jj nil)(page nil)(last nil)  
         (skelton)(hints)(type1)(kstr)  
         (next nil)(nextnext nil)(x1 nil)(y1 nil)(x2 nil)(y2 nil)  
         (date (date-time)))  
     (format "%!/n%%BoundingBox: 45 45 /c /c/n"      (format "%!/n%%BoundingBox: 45 45 /c /c/n"
             (plus 55 (fix (times 0.001 scale (- (* line 500) 100))))              (plus 55 (fix (times 0.001 scale (- (* line 500) 100))))
             (plus 55 (fix (times 0.001 scale (- (* col 500) 100)))))              (plus 55 (fix (times 0.001 scale (- (* col 500) 100)))))
     (lets ((s (inopen (stream "../psfiles/compfont.ps")))      (princ
            (err:end-of-file #'(lambda (x (y))(throw 'eof))))  "%!
       (catch 'eof (loop (princ (readline s))(terpri))))  /KanjiEncoding
   [
   % \x00
           0       0       0       0       0       0       0       0
           0       0       0       0       0       0       0       0
           0       0       0       0       0       0       0       0
           0       0       0       0       0       0       0       0
   % \x20
           0       1       2       3       4       5       6       7
           8       0       0       0       0       0       0       0
           9       10      11      12      13      14      15      16
           17      18      19      20      21      22      23      24
   % \x40
           25      26      27      28      29      30      31      32
           33      34      35      36      37      38      39      40
           41      42      43      44      45      46      47      48
           49      50      51      52      53      54      55      56
   % \x60
           57      58      59      60      61      62      63      64
           65      66      67      68      69      70      71      72
           73      74      75      76      77      0       0       0
           0       0       0       0       0       0       0       0
   % \x80
           0       0       0       0       0       0       0       0
           0       0       0       0       0       0       0       0
           0       0       0       0       0       0       0       0
           0       0       0       0       0       0       0       0
   % \xA0
           0       1       2       3       4       5       6       7
           8       0       0       0       0       0       0       0
           9       10      11      12      13      14      15      16
           17      18      19      20      21      22      23      24
   % \xC0
           25      26      27      28      29      30      31      32
           33      34      35      36      37      38      39      40
           41      42      43      44      45      46      47      48
           49      50      51      52      53      54      55      56
   % \xE0
           57      58      59      60      61      62      63      64
           65      66      67      68      69      70      71      72
           73      74      75      76      77      0       0       0
           0       0       0       0       0       0       0       0
   ] readonly def
   /KanjiSubEncoding {
   %\x00
       /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
       /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
       /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
       /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
   %\x20
       /.notdef /c21     /c22     /c23     /c24     /c25     /c26     /c27
       /c28     /c29     /c2A     /c2B     /c2C     /c2D     /c2E     /c2F
       /c30     /c31     /c32     /c33     /c34     /c35     /c36     /c37
       /c38     /c39     /c3A     /c3B     /c3C     /c3D     /c3E     /c3F
   %\x40
       /c40     /c41     /c42     /c43     /c44     /c45     /c46     /c47
       /c48     /c49     /c4A     /c4B     /c4C     /c4D     /c4E     /c4F
       /c50     /c51     /c52     /c53     /c54     /c55     /c56     /c57
       /c58     /c59     /c5A     /c5B     /c5C     /c5D     /c5E     /c5F
   %\x60
       /c60     /c61     /c62     /c63     /c64     /c65     /c66     /c67
       /c68     /c69     /c6A     /c6B     /c6C     /c6D     /c6E     /c6F
       /c70     /c71     /c72     /c73     /c74     /c75     /c76     /c77
       /c78     /c79     /c7A     /c7B     /c7C     /c7D     /c7E     /.notdef
   %\x80
       /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
       /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
       /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
       /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
   %\xA0
       /.notdef /c21     /c22     /c23     /c24     /c25     /c26     /c27
       /c28     /c29     /c2A     /c2B     /c2C     /c2D     /c2E     /c2F
       /c30     /c31     /c32     /c33     /c34     /c35     /c36     /c37
       /c38     /c39     /c3A     /c3B     /c3C     /c3D     /c3E     /c3F
   %\xC0
       /c40     /c41     /c42     /c43     /c44     /c45     /c46     /c47
       /c48     /c49     /c4A     /c4B     /c4C     /c4D     /c4E     /c4F
       /c50     /c51     /c52     /c53     /c54     /c55     /c56     /c57
       /c58     /c59     /c5A     /c5B     /c5C     /c5D     /c5E     /c5F
   %\xE0
       /c60     /c61     /c62     /c63     /c64     /c65     /c66     /c67
       /c68     /c69     /c6A     /c6B     /c6C     /c6D     /c6E     /c6F
       /c70     /c71     /c72     /c73     /c74     /c75     /c76     /c77
       /c78     /c79     /c7A     /c7B     /c7C     /c7D     /c7E     /.notdef
   } cvlit readonly def
   /T1NF
   {
   /newname exch def
   newname 20 dict def
   newname load begin
   /FontType 1 def
   /FontInfo 8 dict def
   FontInfo begin
   /version (001.001) readonly def
   /FullName (PROLKANJI) readonly def
   /FamilyName (PROLKANJI) readonly def
   /Weight (Medium) readonly def
   /ItalicAngle 0 def
   /isFixedPitch false def
   /UnderlinerPosition 0 def
   /UnderlineThichness 0 def
   end
   %/FontMatrix [.001 0 0 .001 0 0] def
   /FontMatrix [.001 0 0 .001 0 -0.16] def
   /FontBBox [0 0 1000 1000] def
   /Encoding KanjiSubEncoding def
   /CharStrings 256 dict def CharStrings /.notdef <10bf317079ca388fe763> put
   /FontName newname def
   /PaintType 0 def
   /UniqueId 9876 def
   /Private 8 dict def
   Private begin
   /BlueValues [] def
   /password 5839 def
   end
   end
   newname dup dup load definefont
   %[lw-h 0 0 lw-v 0 0] makefont
   def
   } def
   /T0NF
   {
   /newname exch def
   /fdepvector exch def
   newname 20 dict def
   newname load begin
   /FontType 0 def
   /FontMatrix [1 0 0 1 0 0] def
   /FMapType 2 def
   /Encoding KanjiEncoding def
   /FDepVector fdepvector def
   /FontName newname def
   /UniqueId 9876 def
   end
   newname dup dup load definefont
   def
   } def
   /T1D
   {
   2 dict begin
   /ch-code exch def
   /ch-data exch def
   currentfont /CharStrings get ch-code ch-data put
   } def
   
   /CompNF
   {
   /newname1 exch def
   newname1 dup length string cvs /str exch def
   str length /len exch def
   /fdepvector 78 array def
   /j 1 def
   16#21 1 16#74 {
   /i exch def
   KanjiEncoding i get 0 gt {
   len 4 add string /newstr exch def
   newstr 0 str putinterval
   newstr len (.r) putinterval
   newstr len 2 add  i 16 2 string cvrs putinterval
   newstr cvn /newlit exch def
   newlit T1NF /newfont newlit findfont def
   fdepvector j newfont put
   /j j 1 add def
   } if
   } for
   fdepvector 0 fdepvector 1 get put
   /j 0 def
   fdepvector newname1 T0NF
   } def
   
   /CompD
   {
   20 dict begin
   /code exch def
   /charstr exch def
   code 0 get /high exch def
   code 1 get /low exch def
   currentfont /Encoding get high get /index exch def
   currentfont /FDepVector get index get /lowfont exch def
   lowfont /Encoding get low get /tmpkey exch def
   lowfont /CharStrings get tmpkey charstr put
   end
   } def
   /show1 {false charpath 0 setlinewidth stroke} def
   "
   )
   )
   ;
   ; ページごとのヘッダの出力
   ;
   (defun outputPageHeader (page psfile printfile scale )
     (lets ((date (date-time)))
     (format "50 50 translate/n0.001 /c mul dup scale/n" scale)      (format "50 50 translate/n0.001 /c mul dup scale/n" scale)
     (format "//Helvetica findfont 70 scalefont setfont/n")      (format "//Helvetica findfont 70 scalefont setfont/n")
     (setq ii 0 jj 0 page 1)  
     (and printfile      (and printfile
          (format "0 -70 moveto (/c-/c-/c /c:/c File: /c Page: /c) show/n"           (format "0 -70 moveto (/c-/c-/c /c:/c File: /c Page: /c) show/n"
                  (substring date 0 2)                   (substring date 0 2)
Line 30 
Line 209 
                  (substring date 6 8)(substring date 8 10)                   (substring date 6 8)(substring date 8 10)
                  psfile page))                   psfile page))
     (format "//Wadalab-mincho-10 CompNF/n")      (format "//Wadalab-mincho-10 CompNF/n")
     (format "//Wadalab-mincho-10 findfont 400 scalefont setfont/n")      (format "//Wadalab-mincho-10 findfont 400 scalefont setfont/n")))
   ;
   ; ファイルの生成
   ;
   (defun out-to-ps-all (outlines tag psfile
                                  (nameflag)
                                  (col 9)(line (fix (times 0.67 col)))
                                  (printfile t))
     (lets ((standard-output (outopen (stream psfile)))
           (scale (fix (times 160.0 (min (//$ 9.0 (float col))
                                         (//$ 6.0 (float line))))))
           (ii nil)(jj nil)(page nil)(last nil)
           (skeleton)(hints)(type1)(kstr)
           (next nil)(nextnext nil)(x1 nil)(y1 nil)(x2 nil)(y2 nil))
       (outputFileHeader scale line col)
       (setq ii 0 jj 0 page 1)
       (outputPageHeader page psfile printfile scale)
     (do      (do
         ((ol outlines (cdr ol))          ((ol outlines (cdr ol))
          (l nil))           (l nil)(kanji))
       ((atom ol))        ((atom ol))
         (setq kanji (car ol))
       (princ ";" terminal-output)        (princ ";" terminal-output)
 ;     (princ (gccount) terminal-output)  ;     (princ (gccount) terminal-output)
       (print (car ol) terminal-output)        (print kanji terminal-output)
       (setq l        (setq l
             (let ((err:argument-type #'(lambda (x (y))(throw 'err)))              (cond ((eq kanji '　) nil) ; スペース
                   (err:number-of-arguments #'(lambda (x (y))(throw 'err)))                    ((not (boundp kanji)) nil)
                   (err:unbound-variable #'(lambda (x (y))(throw 'err)))                    (t
                   (err:undefined-function #'(lambda (x (y))(throw 'err)))                     (let (
                   (err:zero-division #'(lambda (x (y))(throw 'err))))  ;                 (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:undefined-function #'(lambda (x (y))(throw 'err)))
   ;                 (err:zero-division #'(lambda (x (y))(throw 'err)))
                            )
               (catch 'err                (catch 'err
                 (skelton2list (setq skelton (normkanji (rm-limit (applykanji (car ol) tag)))) tag))))                         (skeleton2list (setq skeleton (normkanji (rm-limit (applykanji kanji 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 54 
Line 255 
        (t         (t
         (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n")          (format "0 setlinewidth 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")
         (setq hints (type1hints skelton tag))          (setq hints (type1hints skeleton tag))
         (setq type1 (out2type1 (makeoutline l) hints))          (setq type1 (out2type1 (makeoutline l) hints))
         (cond ((and (= 2 (string-length (car ol)))          (cond ((and (= 2 (string-length kanji))
                     (logand 128 (sref (car ol) 0)))                      (logand 128 (sref kanji 0)))
                (setq kstr (long-hex-image                 (setq kstr (long-hex-image
                            (plus (logand 127 (sref (car ol) 1))                             (plus (logand 127 (sref kanji 1))
                                  (times 256 (logand 127 (sref (car ol) 0)))))))                                   (times 256 (logand 127 (sref kanji 0)))))))
               ((and (= 7 (string-length (car ol)))                ((and (= 7 (string-length kanji))
                     (string-equal (substring (car ol) 0 2) "1-"))                      (string-equal (substring kanji 0 2) "1-"))
                (setq kstr                 (setq kstr
                      (long-hex-image                       (long-hex-image
                       (plus (logand 127 (plus 32 (number-value (substring (car ol) 5 7))))                        (plus (logand 127 (plus 32 (number-value (substring kanji 5 7))))
                             (times 256 (logand 127 (plus 32 (number-value (substring (car ol) 2 4)))))))))                              (times 256 (logand 127 (plus 32 (number-value (substring kanji 2 4)))))))))
                (t                 (t
                (setq kstr "2121")))                 (setq kstr "2121")))
         (princ type1)          (princ type1)
Line 74 
Line 275 
         (format "0 70 moveto </c> show/n" kstr)))          (format "0 70 moveto </c> show/n" kstr)))
       (setq ii (1+ ii))        (setq ii (1+ ii))
       (cond ((eq ii col)        (cond ((eq ii col)
                (gc)
              (format "500 /c translate/n" (* -500 (1- col)))               (format "500 /c translate/n" (* -500 (1- col)))
              (setq ii 0)               (setq ii 0)
              (setq jj (1+ jj))               (setq jj (1+ jj))
              (cond ((and (eq jj line)(consp (cdr ol)))               (cond ((and (eq jj line)(consp (cdr ol)))
                     (format "showpage/n")                      (format "showpage/n")
                     (format "50 50 translate/n")  
                     (format "0.001 /c mul dup scale/n" scale)  
                     (format "//Helvetica findfont 70 scalefont setfont/n")  
                     (setq page (1+ page))                      (setq page (1+ page))
                     (and printfile                      (outputPageHeader page psfile printfile scale)
                          (format "0 -70 moveto (/c-/c-/c /c:/c File: /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)  
                                  psfile page))  
                     (format "//Wadalab-mincho-10 CompNF/n")  
                     (format "//Wadalab-mincho-10 findfont 400 scalefont setfont/n")  
                     (setq jj 0))))                      (setq jj 0))))
             (t (format "0 500 translate/n"))))              (t (format "0 500 translate/n"))))
     (format "showpage/n")))      (format "showpage/n")))

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

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help