View of /lisp/samples/harai

Parent Directory

Revision Log

change to CVS wadalab font project

;; -*- Mode: lisp -*-
;; 新しい左ハライの検討の実験 lisp コード
;; 1991 年 長橋

;; テスト用の漢字リスト
;;
(setq jis-list
      '(娃 哀 有 葵 旭 圧 扱 宛 姐 安 杏 井 伊 衣 亥))

;; X-window に描くためのルーチン群(要 ulx)
(defun draw-bezier (window gc x0 y0 x1 y1 x2 y2 x3 y3)
  (let ((bez (bez x0 y0 x1 y1 x2 y2 x3 y3)))
    (draw-lines window gc (points-to-flat bez))))

(defun points-to-flat (points)
  (mapcan points
	  (function (lambda (x) (list (car x) (cdr x))))))

(defun draw-harai (window gc x0 y0 x1 y1 x2 y2)
  (lets ((spec (funcall (get 'migi 'mincho)
			`((,x0 ,y0) (,x1 ,y1) (,x2 ,y2)) nil))
	 (line1 (first spec))
	 (line2 (second spec))
	 (trans (function (lambda (x)
			    (list (fix (second x))(fix (third x)))))))
    (draw-line window gc x0 y0 x1 y1)
    (draw-line window gc x1 y1 x2 y2)
    (apply 'draw-bezier (cons window (cons gc (mapcan line1 trans))))
    (apply 'draw-bezier (cons window (cons gc (mapcan line2 trans))))
    ))

;; PostScript コードを生成するための関数
;; 
;; postscript-bez: bez (list of 3 control points) -> bezier line.
;;
(defun postscript-bez (bez p)
  ;;(format "/s /s moveto " (first bez) (second bez))
  (format "/s /s /s " (first bez) (second bez) p)
  (mapcar (cddr bez) '(lambda (x) (princ x) (princ " ")))
  (format "curveto/n"))

;; postscript-bez-control: bez -> control point
;;
(defun postscript-bez-control (bez (dot))
  (and dot
       (do ((x (cddr bez) (cddr x))
	    (R 4))
	   ((atom (cddr x)))
	   (format "/c /c moveto /c 0 rmoveto /c /c /c 0 360 arc fill/n"
		   (first x) (second x) R
		   (first x) (second x) R)))
  (format "gsave .3 setlinewidth/n")
  (do ((x bez (cddr x))
       (m 'moveto 'lineto))
      ((atom x))
      (format "/c /c /c " (first x) (second x) m))
  (format "[3 5] 0 setdash stroke grestore/n")
  )

;; パラメータを変化させつつハライを描く
;;
(defun postscript-harai (x0 y0 x1 y1 x2 y2)
  (lets ((spec (funcall (get 'migi 'mincho)
			`((,x0 ,y0) (,x1 ,y1) (,x2 ,y2)) nil))
	 (line1 (first spec))
	 (line2 (reverse (second spec)))
	 (trans (function (lambda (x)
			    (list (fix (second x))(fix (third x))))))
	 (bez1 (mapcan line1 trans))
	 (bez2 (mapcan line2 trans)))

    (format "gsave/n")
    (postscript-bez bez1 'moveto)
    (postscript-bez bez2 'lineto)
    (format "closepath 0.6 setgray fill grestore/n")

    (postscript-bez-control bez1)
    (postscript-bez-control bez2)

    (format "/s /s moveto /s /s lineto /s /s lineto 0.3 setlinewidth stroke/n"
	    x0 y0 x1 y1 x2 y2)))

;; postscript 出力用マクロ
;;
(defmacro with-postscript-output (filename . body)
  `(let ((standard-output (outopen (stream ,filename))))
     (format "%!/n")
     (format "0.5 0.5 scale 20 50 translate/n")
     (progn . ,body)
     (format "showpage/n")
     (close standard-output)
     nil))

;; dx, dy = delta vector to p3.(forth point)
(defun postscript-bez-harai-list (dx dy)
  (with-postscript-output "d"
    (format "40 1500 translate 1 -1 scale/n")
    (lets ((px0 dx) (py0 0)
	   (px1 dx) (py1 100)
	   (px2 0) (py2 (+ py1 dy))
	   (xy (//$ (float dy) (float dx)))
	   (dxx (//$ (float dx) 10.0)))
      (do ((y 0 (+ y 10)))
	  ((>= y 100))
	  (format "save/n")
	  (do ((x dxx (+$ x dxx)))
	      ((>$ x (float dx)))
	      
	      (let ((bez (list px0 py0 px0 y
			       (fix x) (- py2 (fix (*$ x xy)))
			       px2 py2)))
		(postscript-bez bez 'moveto)
		(format "3 setlinewidth stroke/n")
		(postscript-bez-control bez t))
	      (format "/c 0 translate/n" (+ dx 20)))
	  (format "restore 0 /c translate/n" (+ 100 dy 10)))
      )))


(defun postscript-harai-list ()
  (with-postscript-output "d"
    (format "1200 0 translate -1 1 scale/n")
    (lets ((x1 100) (y1 100))
      (do ((gy 0 (+ gy 250))
	   (y2 (+ y1 40) (+ y2 20)))
	  ((>= gy 1500))
	  (do ((gx 0 (+ gx 100))
	       (x2 x1 (+ x2 20)))
	      ((>= gx 1000))
	      (format "save /s /s translate/n" gx gy)
	      (postscript-harai x1 0 x1 y1 x2 y2)
	      (format "restore/n")
	      )))))

(defun postscript-hidari (x0 y0 x1 y1 x2 y2)
  (lets ((spec (funcall (get 'hidari 'mincho)
			`((,x0 ,y0) (,x1 ,y1) (,x2 ,y2)) nil))
	 (line1 (first spec))
	 (line2 (reverse (second spec)))
	 (trans (function (lambda (x)
			    (list (fix (second x))(fix (third x))))))
	 (bez1 (mapcan line1 trans))
	 (bez2 (mapcan line2 trans)))

    (format "gsave/n")
    (postscript-bez bez1 'moveto)
    (postscript-bez bez2 'lineto)
    (format "closepath 0.6 setgray fill grestore/n")

    (postscript-bez-control bez1 t)
    (postscript-bez-control bez2 t)

    (format "/s /s moveto /s /s lineto /s /s lineto 0.3 setlinewidth stroke/n"
	    x0 y0 x1 y1 x2 y2)))

(defun postscript-hidari-list ()
  (with-postscript-output "d"
    (format "1200 0 translate -1 1 scale/n")
    (lets ((x1 200) (y1 100))
      (do ((gy 0 (+ gy 250))
	   (y2 (+ y1 40) (+ y2 20)))
	  ((>= gy 1500))
	  (do ((gx 0 (+ gx 100))
	       (x2 x1 (- x2 20)))
	      ((>= gx 1000))
	      (format "save /s /s translate/n" gx gy)
	      (postscript-hidari x1 0 x1 y1 x2 y2)
	      (format "restore/n")
	      )))))

(defun radian (deg)
  (*$ (//$ (float deg) 180.0) 3.141593))

(defun postscript-hidari-list2 ()
  (with-postscript-output "d"
     (format "50 1500 translate 1 -1 scale/n")
     (lets ((x0 150) (y0 0)
	    (x1 (- x0 50)) (y1 300))
       (do ((gy 0 (+ gy 500))
            (r 100 (+ r 20)))
           ((>= gy 1500))
           (do ((gx 0 (+ gx 100))
                (s 0 (+ s 10)))
               ((>= gx 1000))
               (format "save /s /s translate/n" gx gy)
               (let ((x2 (- x1 (fix (*$ (float r) (sin (radian s))))))
                     (y2 (+ y1 (fix (*$ (float r) (cos (radian s)))))))
                 (postscript-hidari x0 y0 x1 y1 x2 y2)
                 (format "restore/n")
                 ))))))

;; prim-p: checks prim is a primitive or not.
;;
(defun prim-p (prim)
  (and (symbolp prim) (setq (eval prim)))
  (or (and (consp prim) (stringp (car prim)))
      (stringp prim)
      (and (consp prim) (consp (car prim)))))

(defun postscript-outline (prim (tag 'mincho))
  (let ((outline (skelton2list (applykanji prim) tag)))
    (and (consp outline)
	 (do ((ll outline (cdr ll)))
	     ((atom ll))
	     (setq last (caar ll))
	     (format "/c /c moveto/n" (fix (cadr last)) (fix (caddr last)))
	     (do ((lll (cdar ll) (cdr lll)))
		 ((atom lll))
		 (match (car lll)
		   (('angle x y)
		    (format "/c /c lineto/n" (fix x) (fix y)))
		   (('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 x1 (cadr next) y1 (caddr next))
		    (setq x2 (cadr nextnext) y2 (caddr nextnext))
		    (format "/c /c /c /c /c /c curveto/n"
			    (fix x0) (fix y0)
			    (fix x1) (fix y1)
			    (fix x2) (fix y2)))))
	     (format "closepath fill/n")))))

;; skelton を出力
(defun postscript-skelton (prim)
  (and (symbolp prim) (setq prim (eval prim)))
  (and (consp prim) (stringp (car prim)) (setq prim (car prim)))
  (and (stringp prim) (setq prim (unpackprim prim)))
  
  (let ((points (first prim))
	(links (second prim))
	(gx 50) (gy 50)
	(R 10))
    ;;(format "/c /c translate/n" gx gy)

    (format "gsave 0.8 setgray/n")
    (postscript-outline prim)
    (format "grestore/n")
    
    (princ "gsave ")
    (format "0 0 moveto 0 400 rlineto 400 0 rlineto 0 -400 rlineto/n")
    (format "closepath 0 setlinewidth stroke grestore/n")
    
    (format "gsave .5 setlinewidth/n")
    (mapcar points '(lambda (x) (format "/c /c " (first x) (second x))))
    (format "/c { 2 copy moveto /c 0 rmoveto /c 0 360 arc stroke } repeat/n"
	    (length points) R R)
    (format "grestore/n")
    
    (format "gsave 2 setlinewidth/n")
    (do ((l links (cdr l)))
	((atom l ))
	(do ((p (second (car l)) (cdr p))
	     (m 'moveto 'lineto))
	    ((atom p))
	    (let ((f (nth (car p) points)))
	      (format "/c /c /c " (first f) (second f) m)))
	(format "stroke/n"))
    (format "grestore/n")))

;; 一枚の紙に複数の図を描くためのマクロ
;;
(defmacro multi-postscript-output ((filename xsize ysize) . body)
  `(let ((standard-output (outopen (stream ,filename)))
	 (xsize ,xsize) (ysize ,ysize)
	 (gx 20) (gy 810))
     (format "%!/n")
     (loop
      (format "save /c /c translate 1 -1 scale/n" gx gy)
      (let ((whatnext (progn . ,body)))
	(format "restore/n/n")
	(cond (whatnext (format "showpage/n") (exit)))
	(setq gx (+ gx xsize))
	(and (>= gx (- 600 xsize)) (setq gx 20 gy (- gy ysize)))
	(or (>= gy ysize) (progn (setq gy 800) (format "showpage/n/n")))))
     (close standard-output)))

;; postscript-skelton-all: primitive list -> skelton.
(defun postscript-skelton-all (prims)
  (and (atom prims) (setq prims (ncons prims)))
  (multi-postscript-output ("skel.ps" 205 205)
     (cond ((atom prims) t)
	   (t (format "0.5 0.5 scale/n")
	      (postscript-skelton (pop prims))
	      nil))))

(macro gsave (body)
  `(progn
     (format "gsave/n")
     (progn . ,body)
     (format "grestore/n")))

(defun postscript-harai-all (prims)
  (and (atom prims) (setq prims (ncons prims)))
  (multi-postscript-output ("harai.ps" 205 205)
     (or (atom prims)
	 (let ((harai (get (pop prims) 'harai)))
	   (format "0.5 0.5 scale gsave/n")
	   (format "0 0 moveto 0 400 rlineto 400 0 rlineto 0 -400 rlineto/n")
	   (format "closepath 0 setlinewidth stroke grestore/n")
	   (do ((h harai (cdr h)))
	       ((atom h))
	       (let ((bez (mapcan (car h) '(lambda (x) (copy (cdr x))))))
		 (gsave
		  (postscript-bez bez 'moveto)
		  (format "2 setlinewidth stroke/n"))
		 (postscript-bez-control bez t)))
	   nil))))
		 
(defmacro X (p) `(first ,p))
(defmacro Y (p) `(second ,p))

(defun postscript-bezier-point (prim)
    (do ((p prim (cdr p)))
	((atom p))
	(do ((h (get (car p) 'harai) (cdr h)))
	    ((atom h))
	    
	    (lets ((points (mapcar (car h) 'cdr))
		   (p0 (first points))
		   (p1 (third points))
		   (p2 (fourth points))
		   (cp (second points))
		   (d1 (diff2 p0 p1))
		   (d2 (diff2 p2 p1))
		   (ss (minus (//$ (float (X d2))(float (Y d2)))))
		   (ys (//$ (float (- (Y p1) (Y cp)))
			    (float (- (Y p1) (Y p0)))))
		   (armlen1 (sqrt (+$ (*$ (float (X d1)) (float (X d1)))
				      (*$ (float (Y d1)) (float (Y d1))))))
		   (armlen2 (sqrt (+$ (*$ (float (X d2)) (float (X d2)))
				      (*$ (float (Y d2)) (float (Y d2))))))
		   (yd (float (- (Y p1) (Y cp))))
		   (lenratio (//$ armlen2 armlen1))
		   )
	      ;;(format "/c /c/n" ss ys) ;; harai.data3
	      ;;(format "/c /c/n" armlen2 yd) ;; harai.data4
	      ;;(format "/c /c/n" lenratio ys) ;; harai.data5
	      (format "/c /c/n" lenratio (sqrt ys)) ;; harai.data6
	      ))))

;;
;; redefine hidari-harai.
(defelement mincho hidari
  (let ((p0 (first points))
	(p1 (second points))
	(p2 (third points))
	(w (times minchowidth 0.9)))	; chotto herasita houga dekiga yoi.
    (lets ((v10 (diff2 p0 p1))
	   (v12 (diff2 p2 p1))
	   (d10 (norm2 (list (Y v10) (minus (X v10)))))
	   (d12 (norm2 (list (minus (Y v12)) (X v12))))
	   (vc (plus2 d10 d12))

	   (a (length2 v10))(b (length2 v12))
	   ;;(c1disp (//$ b 2.0))
	   (lenratio (//$ b a))
	   (c1disp (*$ lenratio lenratio a))

	   (wl (*$ (//$ b (+$ a b)) w))
	   (cc (minus (Y (norm2 v10))))		;cosine
	   (w2 (+$ (*$ w cc) (*$ wl (-$ 1.0 cc))))

	   (dc (times2 (//$ w2 (mul2 vc d10)) vc))
	   (cl (plus2 p1 dc))
	   (cr (diff2 p1 dc)))
      `(((angle . ,(plus2 p0 (times2 w d10)))
	 (bezier . ,(plus2 cl (normlen2 c1disp v10)))
	 (bezier . ,cl)
	 (angle . ,p2))
	((angle . ,(plus2 p0 (normlen2 (minus w) d10)))
	 (bezier . ,(plus2 cr (normlen2 c1disp v10)))
	 (bezier . ,cr)
	 (angle . ,p2))))))