View of /renderer/type1.l

Parent Directory

Revision Log

*** empty log message ***

(declare (crypt_r crypt_c1 crypt_c2) special)
(setq crypt_r 4330)
(setq crypt_c1 52845)
(setq crypt_c2 22719)
(defun init_crypt ()
  (setq crypt_r 4330))
;
(defun putc_crypt (c)
  (let ((cipher (logand 255 (logxor c (logshift crypt_r -8)))))
    (setq crypt_r (remainder (plus crypt_c2 (times crypt_c1 (plus cipher crypt_r))) 65536))
    (string (hex2 cipher))))
;
(defun put_int (val)
  (cond ((<= -107 val 107)
	 (putc_crypt (+ val 139)))
	((<= 108 val 1131)
	 (string-append
	  (putc_crypt (+ 247 (// (- val 108) 256)))
	  (putc_crypt (\ (- val 108) 256))))
	((<= -1131 val -108)
	 (string-append
	  (putc_crypt (+ 251 (// (- (+ val 108)) 256)))
	  (putc_crypt (\ (- (+ val 108)) 256))))
	(t
	 (print `(error ,val) terminal-output)
	 (break))))
;
(defun long-hex-image (n)
  (cond ((lessp n 16)(string (hex-image-char n)))
	(t (string-append (long-hex-image (quotient n 16))
			  (string (hex-image-char (remainder n 16)))))))
;
(defun hex2 (n)
  (string-append (string (hex-image-char (quotient n 16)))
		 (string (hex-image-char (remainder n 16)))))
;
; Adobe Type1 Font Format ¤Î½ÐÎÏ
;
(defun klist2type1 (klist tag (fontfile))
  (let ((standard-output (cond (fontfile (outopen (stream fontfile)))
			       (t standard-output))))
    (do ((l klist (cdr l))
	 (outline)
	 (kanji))
      ((atom l)(and fontfile (close standard-output)))
      (setq kanji (car l))
      (format "/c/c ;/c/n" 
	      (long-hex-image (logand 127 (sref kanji 0)))
	      (long-hex-image (logand 127 (sref kanji 1)))
	      kanji)
      (princ (out2type1 (makeoutline
			 (skeleton2list (applykanji (car l)) tag)))))))
(declare (type1max type1ratio) special)
(setq type1max 1000)
(setq type1ratio 2.5) 
(defun skeleton2type1 (kanji type)
  (lets ((meshsize 0.4)
	 (skeleton (normkanji (applykanji kanji type)))
	 (outline (skeleton2list skeleton type))
	 (hints (type1hints skeleton type)))
    (out2type1 outline hints)))
(defun out2type1 (outline (hints))
  (cond 
   ((atom outline))
   (t
    (init_crypt)
    (let ((retstr (string-append "<" (putc_crypt 0)(putc_crypt 0)
				 (putc_crypt 0)(putc_crypt 0)
				 (put_int 0)(put_int 1000)(putc_crypt 13))))
    (do ((l hints (cdr l))(base)(width))
      ((atom l))
      (cond ((eq 'v (caar l))
;	     (print (car l))
	     (setq base (fix (times type1ratio (cadar l))))
	     (setq width (- (fix (times type1ratio (cddar l))) base))
;	     (print `(vstem ,base ,width))
	     (setq retstr (string-append retstr 
					 (put_int base)
					 (put_int width)
					 (putc_crypt 3))))
	    ((eq 'h (caar l))
;	     (print (car l))
	     (setq base (- type1max (fix (times type1ratio (cddar l)))))
	     (setq width (- (- type1max (fix (times type1ratio (cadar l))))
			    base))
;	     (print `(hstem ,base ,width))
	     (setq retstr (string-append retstr 
					 (put_int base)
					 (put_int width)
					 (putc_crypt 1))))))
    (do ((ll outline (cdr ll))
	 (next)(nextnext)
	 (curx 0)(cury 0)(newx)(newy)(dx1)(dy1)(dx2)(dy2)(dx3)(dy3)(last));
      ((atom ll))
      (and (car ll)
      (setq last (caar ll))
      (setq newx (fix (times type1ratio (cadr last)))
	    newy (- type1max (fix (times type1ratio (caddr last)))))
;      (print `(moveto ,newx ,newy))
      (cond ((eq newx curx)
	     (setq retstr (string-append retstr 
					 (put_int (- newy cury))
					 (putc_crypt 4))))
	    ((eq newy cury)
	     (setq retstr (string-append retstr (put_int (- newx curx))
					 (putc_crypt 22))))
	    (t 
	     (setq retstr (string-append retstr (put_int (- newx curx))
					 (put_int (- newy cury))
					 (putc_crypt 21)))))
      (setq curx newx cury newy)
      (do ((lll (cdar ll) (cdr lll)))
	((atom lll))
	(match 
	    (car lll)
	  (('angle x y)
	   (setq newx (fix (times type1ratio x)) 
		 newy (- type1max (fix (times type1ratio y))))
;	   (print `(lineto ,newx ,newy))
	   (cond ((eq newx curx)
		  (setq retstr (string-append retstr (put_int (- newy cury))
					      (putc_crypt 7))))
		 ((eq newy cury)
		  (setq retstr (string-append retstr (put_int (- newx curx))
					      (putc_crypt 6))))
		 (t (setq retstr (string-append retstr (put_int (- newx curx))
						(put_int (- newy cury))
						(putc_crypt 5)))))
	   (setq curx newx cury newy))
	  (('bezier x0 y0)
	   (setq next (cadr lll))
	   (setq nextnext 
		 (cond ((cddr lll)(setq lll (cddr lll))(car lll))
		       (t (setq lll (cdr lll))last)))
	   (setq newx (fix (times type1ratio x0)) newy (- type1max (fix (times type1ratio y0))))
	   (setq dx1 (- newx curx) dy1 (- newy cury))
	   (setq curx newx cury newy)
	   (setq newx (fix (times type1ratio (cadr next)))
		 newy (- type1max (fix (times type1ratio (caddr next)))))
	   (setq dx2 (- newx curx) dy2 (- newy cury))
	   (setq curx newx cury newy)
	   (setq newx (fix (times type1ratio (cadr nextnext)))
		 newy (- type1max (fix (times type1ratio (caddr nextnext)))))
	   (setq dx3 (- newx curx) dy3 (- newy cury))
;	   (print `(curveto ,newx ,newy))
	   (setq curx newx cury newy)
	   (cond ((and (zerop dx1)(zerop dy3))
		  (setq retstr (string-append retstr
					      (put_int dy1)(put_int dx2)
					      (put_int dy2)(put_int dx3)
					      (putc_crypt 30))))
		 ((and (zerop dy1)(zerop dx3))
		  (setq retstr (string-append retstr
					      (put_int dx1)(put_int dx2)
					      (put_int dy2)(put_int dy3)
					      (putc_crypt 31))))
		 (t
		  (setq retstr (string-append retstr
					      (put_int dx1)(put_int dy1)
					      (put_int dx2)(put_int dy2)
					      (put_int dx3)(put_int dy3)
					      (putc_crypt 8))))))))))
    (string-append retstr 
		   (putc_crypt 9)(putc_crypt 14)">")))))
	  
;
(defun type1hints (skeleton type)
  (lets ((points (car skeleton))
	 (elements (cadr skeleton))
	 (hints))
    (do ((l elements (cdr l))(element)(eltype)(elpoints nil nil)(type1list)(elhint)(hint))
      ((atom l))
      (setq element (car l))
      (setq eltype (car element))
      (setq elhint (and (setq type1list (get eltype 'type1))
			(do ((ll type (get ll 'parent))(ret))
			  ((null ll))
			  (and (setq ret (assq ll type1list))(exit ret)))))
      (cond (elhint
	     (do ((ll (cadr element)(cdr ll)))
	       ((atom ll)(setq elpoints (nreverse elpoints)))
	       (push (nth (car ll) points) elpoints))
	     (setq hint (funcall (cdr elhint) elpoints))
;	     (prind `(,element ,elhint ,elpoints ,hint))
	     (and hint (setq hints (nconc hint hints))))))
    (setq hints (sort hints #'(lambda (x y)
				(cond ((eq (car x)(car y))
				       (cond ((equal (cadr x)(cadr y))
					      (lessp (cddr x)(cddr y)))
					     (t
					      (lessp (cadr x)(cadr y)))))
				      (t
				       (eq (car x) 'h))))))
    (do ((l hints (cdr l))
	 (ret))
      ((atom l) ret)
      (cond ((and (cdr l)
		  (eq (caar l)(caadr l))
		  (equal (cadr (car l))(cadr (cadr l))))
	     (push (car l) ret)
	     (setq l (cdr l)))
	    ((and (cdr l)
		  (eq (caar l)(caadr l))
		  (equal (cddr (car l))(cddr (cadr l)))))
	    ((and (cdr l)
		  (eq (caar l)(caadr l))
		  (greaterp (cddr (car l))(cadr (cadr l))))
	     (setq l (cdr l)))
	    (t (push (car l) ret))))))