View of /lisp/test/jis3ku.l

Parent Directory

Revision Log

*** empty log message ***

(defun jis3ps (kustr psfile)
  (lets ((standard-output (outopen (stream psfile)))
	(tag 'mincho-patch)(col 12)(line 8)
	(scale (fix (times 160.0 (max (//$ 9.0 (float col))
				      (//$ 6.0 (float line))))))
	(i nil)(j nil)(page nil)(last nil)(outlines)
	(next nil)(nextnext nil)(x1 nil)(y1 nil)(x2 nil)(y2 nil)(skeleton)
	(minchowidth  10.0)
	(tateyokoratio 0.3)
	(hirawidth 0.35)
	(tatekazari 1.8)
	(kazariheight 1.8)
	(tomeheight 2.4)
	(date (date-time)))
    (do ((i 1 (1+ i))
	 (dig2 (make-string 2)))
      ((> i 94)(setq outlines (nreverse outlines)))
      (sset dig2 0 (+ 48 (quotient i 10)))
      (sset dig2 1 (+ 48 (remainder i 10)))
      (push (intern (symbol (string-append "1-" kustr "-" dig2))) outlines))
    (format "%!/n%%BoundingBox: 95 195 /c /c/n" 
	    (plus 105 (fix (times 0.001 scale (- (* line 500) 100))))
	    (plus 205 (fix (times 0.001 scale (- (* col 500) 100)))))
    (lets ((s (inopen (stream "/home/mari/kanji/lib/psfiles/compfont.ps")))
	   (err:end-of-file #'(lambda (x (y))(throw 'eof))))
      (catch 'eof (loop (princ (readline s))(terpri))))
    (format "%!/n50 50 translate/n0.001 /c mul dup scale/n" scale)
    (format "//Helvetica findfont 140 scalefont setfont/n")
    (do ((i 0 (1+ i)))
      ((greaterp i 11))
      (format "-200 /c moveto (/c) show/n" (plus 180 (times i 500)) 
	      (cond ((lessp i 10)
		     (string-append "0" (number-image i)))
		    (t i))))
    (do ((i 1 (1+ i)))
      ((greaterp i 7))
      (format "/c -140 moveto (/c) show/n" 
	      (plus 160 (times i 500)) (times 12 i)))
    (format "0 -140 moveto (/c) show/n" (string-append "1" kustr))
    (format "3000 -280 moveto (/c-/c-/c /c:/c) show/n" 
		 (substring date 0 2)
		 (substring date 2 4)(substring date 4 6)
		 (substring date 6 8)(substring date 8 10))
    (format "//Wadalab-mincho-10 CompNF/n")
    (format "//Wadalab-mincho-10 findfont 400 scalefont setfont/n")
;    (break)
    (setq i 1 j 0 page 1)
    (format "0 500 translate/n")
    (do 
     ((ol outlines (cdr ol))
      (l nil))
     ((atom ol))
     (princ ";" terminal-output)
;     (princ (gccount) terminal-output)
     (print (car ol) terminal-output)
     (setq l
	   (let ((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
		(skeleton2list (setq skeleton (normkanji (rm-limit (applykanji (car ol) tag)))) tag))))
     (cond 
      ((atom l)
       (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n")
       (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n"))
      (t
       (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n")
       (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n")
	(setq hints (type1hints skeleton tag))
	(setq type1 (out2type1 l hints))
	(cond ((and (= 2 (string-length (car ol)))
		    (logand 128 (sref (car ol) 0)))
	       (setq kstr (long-hex-image 
			   (plus (logand 127 (sref (car ol) 1))
				 (times 256 (logand 127 (sref (car ol) 0)))))))
	      ((and (= 7 (string-length (car ol)))
		    (string-equal (substring (car ol) 0 2) "1-"))
	       (setq kstr
		     (long-hex-image
		      (plus (logand 127 (plus 32 (number-value (substring (car ol) 5 7))))
			    (times 256 (logand 127 (plus 32 (number-value (substring (car ol) 2 4)))))))))
	       (t
	       (setq kstr "2121")))
	(princ type1)
	(format " </c> CompD/n" kstr)
	(format "0 70 moveto </c> show/n" kstr)))
      (setq i (1+ i))
      (cond ((eq i col)
	     (format "500 /c translate/n" (* -500 (1- col)))
	     (setq i 0)
	     (setq j (1+ j)))
	    (t (format "0 500 translate/n"))))
    (format "showpage/n"))))
(defun jis3-ku (kustr)
  (do ((i 1 (1+ i))
       (dig2 (make-string 2))
       (ret))
    ((> i 94)(nreverse ret))
    (sset dig2 0 (+ 48 (quotient i 10)))
    (sset dig2 1 (+ 48 (remainder i 10)))
    (push (intern (symbol (string-append "1-" kustr "-" dig2))) ret)))
(defun rec_boundp (l)
  (cond ((symbolp l)(and (boundp l) (rec_boundp (eval l))))
	((consp l)
	 (or (not (symbolp (car l)))
	     (do ((ll (cdr l)(cdr ll)))
	       ((atom ll) t)
	       (or (rec_boundp (car ll))(exit nil)))))
	(t)))
(defun check-ku (kustr)
  (do ((l (jis3-ku kustr) (cdr l)))
    ((atom l))
    (or (rec_boundp (car l))(format ";/c/n" (car l)))))

(defun check-bushu (kustr)
  (do ((l (jis3-ku kustr) (cdr l))(a))
    ((atom l))
    (and (symbolp (setq a (eval (car l))))(format ";/c,/c/n" (car l) a))))

(defun makeku (kanjis type filespec dig)
  (lets ((filename (string-append filespec (long-hex-image dig) ".ps")))
    (format ";/c/n" filename)
    (out-to-ps-all (nreverse kanjis) type filename nil 12 8 nil)))
(defun jis-ku (ku type filename)
  (do ((j #x21 (1+ j))(ret)(str (make-string 2)(make-string 2)))
    ((greaterp j #x7e)
     (out-to-ps-all (nreverse ret) type filename nil 12 8 nil))
    (sset str 0 (logor #x80 ku))(sset str 1 (logor #x80 j))
    (push (intern (symbol str)) ret)))
(defun jis-ku-3 (ku type filename)
  (out-to-ps-all (jis3-ku ku) type filename nil 12 8 nil))
(defun makeallkanji (type filespec)
  (lets ((ret))
    (do ((i #x30 (1+ i)))
      ((greaterp i #x4e))
      (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2)))
	((greaterp j #x7e)(makeku ret type filespec i)(setq ret nil))
	(sset str 0 (logor #x80 i))(sset str 1 (logor #x80 j))
	(push (intern (symbol str)) ret)))
    (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2)))
      ((greaterp j #x53)(makeku ret type filespec i)(setq ret nil))
      (sset str 0 (logor #x80 #x4f))(sset str 1 (logor #x80 j))
      (push (intern (symbol str)) ret))
    (do ((i #x50 (1+ i)))
      ((greaterp i #x73))
      (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2)))
	((greaterp j #x7e)(makeku ret type filespec i)(setq ret nil))
	(sset str 0 (logor #x80 i))(sset str 1 (logor #x80 j))
	(push (intern (symbol str)) ret)))
    (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2)))
      ((greaterp j #x24))
      (sset str 0 (logor #x80 #x74))(sset str 1 (logor #x80 j))
      (push (intern (symbol str)) ret))
    (push 'ŁĘŁµ ret)
    (push 'ŁĘŁ¶ ret)
    (makeku ret type filespec i)(setq ret nil)))

(defun makeallkanjitest (type filespec)
  (lets ((ret))
    (do ((i #x3c (1+ i)))
      ((greaterp i #x4e))
      (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2)))
	((greaterp j #x7e)(makeku ret type filespec i)(setq ret nil))
	(sset str 0 (logor #x80 i))(sset str 1 (logor #x80 j))
	(push (intern (symbol str)) ret)))
    (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2)))
      ((greaterp j #x53)(makeku ret type filespec i)(setq ret nil))
      (sset str 0 (logor #x80 #x4f))(sset str 1 (logor #x80 j))
      (push (intern (symbol str)) ret))
    (do ((i #x50 (1+ i)))
      ((greaterp i #x73))
      (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2)))
	((greaterp j #x7e)(makeku ret type filespec i)(setq ret nil))
	(sset str 0 (logor #x80 i))(sset str 1 (logor #x80 j))
	(push (intern (symbol str)) ret)))
    (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2)))
      ((greaterp j #x24))
      (sset str 0 (logor #x80 #x74))(sset str 1 (logor #x80 j))
      (push (intern (symbol str)) ret))
    (push 'ŁĘŁµ ret)
    (push 'ŁĘŁ¶ ret)
    (makeku ret type filespec i)(setq ret nil)))
(defun makegothku (ku)
  (format "%!/n50 50 translate/n0.001 /c mul dup scale/n" 120)
  (format "//GothicBBB-Medium-H findfont 400 scalefont setfont/n")
  (do ((j #x21 (1+ j))
       (y 0))
    ((> j #x7e)(format "showpage/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 "0 60 moveto </c> show/n" (long-hex-image (+ j (* ku 256))))
    (setq y (1+ y))
    (cond ((eq y 12)
	   (format "500 /c translate/n" (* -500 11))(setq y 0))
	  (t
	   (format "0 500 translate/n")))))
(defun makeminku (ku)
  (format "%!/n50 50 translate/n0.001 /c mul dup scale/n" 120)
  (format "//Ryumin-Light-H findfont 400 scalefont setfont/n")
  (do ((j #x21 (1+ j))
       (y 0))
    ((> j #x7e)(format "showpage/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 "0 60 moveto </c> show/n" (long-hex-image (+ j (* ku 256))))
    (setq y (1+ y))
    (cond ((eq y 12)
	   (format "500 /c translate/n" (* -500 11))(setq y 0))
	  (t
	   (format "0 500 translate/n")))))