[wadalabfont-kit] / renderer / out2ps.l  

Diff of /renderer/out2ps.l

Parent Directory | Revision Log

version 1.5, Wed Jul 2 12:37:45 2003 UTC version 1.8, Tue Aug 26 07:06:51 2003 UTC
Line 1 
Line 1 
 ;  ;
 ; $BAH9g$o$;$N$?$a$@$1$KB8:_$9$k2>A[E*$J(Bxlimit, ylimit  ; ファイルのヘッダの出力
 ; $B$H$$$&%(%l%a%s%H$r=|$/(B  
 ;  
 (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))))  
 ;  
 ; $B%U%!%$%k$N%X%C%@$N=PNO(B  
 ;  ;
   
 (defun outputFileHeader (scale)  (defun outputFileHeader (scale line col)
     (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)))))
Line 126 
Line 117 
 /CharStrings 256 dict def CharStrings /.notdef <10bf317079ca388fe763> put  /CharStrings 256 dict def CharStrings /.notdef <10bf317079ca388fe763> put
 /FontName newname def  /FontName newname def
 /PaintType 0 def  /PaintType 0 def
 /UniqueId 9876 def  /UniqueID 9876 def
 /Private 8 dict def  /Private 8 dict def
 Private begin  Private begin
 /BlueValues [] def  /BlueValues [] def
Line 149 
Line 140 
 /Encoding KanjiEncoding def  /Encoding KanjiEncoding def
 /FDepVector fdepvector def  /FDepVector fdepvector def
 /FontName newname def  /FontName newname def
 /UniqueId 9876 def  /UniqueID 9876 def
 end  end
 newname dup dup load definefont  newname dup dup load definefont
 def  def
Line 205 
Line 196 
 )  )
 )  )
 ;  ;
 ; $B%Z!<%8$4$H$N%X%C%@$N=PNO(B  ; ページごとのヘッダの出力
 ;  ;
 (defun outputPageHeader (page file printfile)  (defun outputPageHeader (page psfile printfile scale )
   (lets ((date (date-time)))    (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")
Line 220 
Line 211 
     (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")))
 ;  ;
 ; $B%U%!%$%k$N@8@.(B  ; ファイルの生成
 ;  ;
 (defun out-to-ps-all (outlines tag psfile  (defun out-to-ps-all (outlines tag psfile
                                (nameflag)                                 (nameflag)
Line 232 
Line 223 
         (ii nil)(jj nil)(page nil)(last nil)          (ii nil)(jj nil)(page nil)(last nil)
         (skeleton)(hints)(type1)(kstr)          (skeleton)(hints)(type1)(kstr)
         (next nil)(nextnext nil)(x1 nil)(y1 nil)(x2 nil)(y2 nil))          (next nil)(nextnext nil)(x1 nil)(y1 nil)(x2 nil)(y2 nil))
     (outputFileHeader scale)      (outputFileHeader scale line col)
     (setq ii 0 jj 0 page 1)      (setq ii 0 jj 0 page 1)
     (outputPageHeader page psfile printfile)      (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
                 (skeleton2list (setq skeleton (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 260 
Line 257 
         (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 skeleton 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 278 
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")
                     (setq page (1+ page))                      (setq page (1+ page))
                     (outputPageHeader page psfile printfile)                      (outputPageHeader page psfile printfile scale)
                     (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.5  
changed lines
  Added in v.1.8
ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help