View of /renderer/gothic.l

Parent Directory

Revision Log

*** empty log message ***

;(cond ((definedp 'kanjilib))
;      (t (exfile 'lib.l)))
(declare (local_gothicwidth) special)
(defun gothic2 (p1 p2 w)
  (lets ((p12 (diff2 p2 p1))
	 (l1 (normlen2 w (rot270 p12))))
    `(((angle .,(plus2 p1 l1))
       (angle .,(plus2 p2 l1)))
      ((angle .,(diff2 p1 l1))
       (angle .,(diff2 p2 l1))))))
;
(defun gothic3 (p1 p2 p3 w (ratio 0.6666666666))
  (lets ((p12 (diff2 p2 p1))
	 (l1 (normlen2 w (rot270 p12)))
	 (p23 (diff2 p3 p2))
	 (l3 (normlen2 w (rot270 p23)))
	 (dp1 (times2 (times 3 ratio) p12))
	 (dp2 (times2 (times 3 ratio) p23))
	 (ddp1 (plus2
		(times2 6.0 (diff2 p3 p1))
		(times2 -4.0 dp1)
		(times2 -2.0 dp2)))
	 (ddp2 (plus2
		(times2 6.0 (diff2 p1 p3))
		(times2 4.0 dp2)
		(times2 2.0 dp1)))
	 (dp1_ddp1 (mul2 dp1 ddp1))
	 (dp2_ddp2 (mul2 dp2 ddp2))
	 (lendp1 (length2 dp1))
	 (lendp2 (length2 dp2))
	 (lendp1_3 (expt lendp1 3))
	 (lendp2_3 (expt lendp2 3))
	 (a1 (plus2 p1 l1))
	 (a2 (plus2 p3 l3))
	 (b1 (diff2 p1 l1))
	 (b2 (diff2 p3 l3))
	 (da1 (plus2 
	       dp1
	       (times2 (quotient w lendp1) (rot270 ddp1))
	       (times2 (quotient (times w dp1_ddp1) lendp1_3) (rot90 dp1))))
	 (da2 (plus2 
	       dp2
	       (times2 (quotient w lendp2) (rot270 ddp2))
	       (times2 (quotient (times w dp2_ddp2) lendp2_3) (rot90 dp2))))
	 (db1 (plus2 
	       dp1
	       (times2 (quotient w lendp1) (rot90 ddp1))
	       (times2 (quotient (times w dp1_ddp1) lendp1_3) (rot270 dp1))))
	 (db2 (plus2 
	       dp2
	       (times2 (quotient w lendp2) (rot90 ddp2))
	       (times2 (quotient (times w dp2_ddp2) lendp2_3) (rot270 dp2))))
	 )
;    (break)
    `(((angle .,a1)
       (bezier .,(plus2 a1 (times2 0.33333333 da1)))
       (bezier .,(plus2 a2 (times2 -0.33333333 da2)))
       (angle .,a2))
      ((angle .,b1)
       (bezier .,(plus2 b1 (times2 0.33333333 db1)))
       (bezier .,(plus2 b2 (times2 -0.33333333 db2)))
       (angle .,b2)))))

(defun gothiccurve (p1 p2 p3 w (ratio 0.6666666666))
  (lets ((p12 (diff2 p2 p1))
	 (l1 (normlen2 w (rot270 p12)))
	 (p23 (diff2 p3 p2))
	 (l3 (normlen2 w (rot270 p23)))
	 (w1 (quotient (times -1.0 w (length2 l1)(length2 p23))
		       (mul2 l1 p23)))
	 (a1 (plus2 p1 l1))
	 (a2 (plus2 p2 (normlen2 w1 (diff2 p2 p1))(normlen2 w1 (diff2 p2 p3))))
	 (a3 (plus2 p3 l3))
	 (b1 (diff2 p1 l1))
	 (b2 (plus2 p2 (normlen2 w1 (diff2 p1 p2))(normlen2 w1 (diff2 p3 p2))))
	 (b3 (diff2 p3 l3)))
;    (break)
;    (setq test 'bezier)
    `(((angle .,a1)
       (bezier .,(inter2 a1 a2 ratio))
       (bezier .,(inter2 a3 a2 ratio))
       (angle .,a3))
      ((angle .,b1)
       (bezier .,(inter2 b1 b2 ratio))
       (bezier .,(inter2 b3 b2 ratio))
       (angle .,b3)))))


;
(defkazari gothic ((tate hidari tatehidari tatehane kokoro tasuki magaritate) 0 
	    (tate hidari tatehidari tatehane kokoro tasuki magaritate) 1)
  (lets ((p0 (vref cross 0))
	 (p1 (vref cross 1))
	 (p2 (vref cross 2))
	 (p3 (vref cross 3))
	 (d0 (norm2 (diff2 p3 p1)))
	 (len (metric2 p0 p1))
	 (sintheta (times 0.5 (car d0))))
  `((angle .,p0)
    (bezier .,
     (plus2 p1 (normlen2 (plus (times len 0.2)(times len sintheta)) (diff2 p3 p1))
	    (normlen2 (times len 0.5) (diff2 p1 p0))))
    (bezier .,
     (plus2 p1 (normlen2 (plus (times len 0.6)(times 1.5 len sintheta)) (diff2 p3 p1))
	    (normlen2 (times len 0.5) (diff2 p1 p0))))
    (angle .,
     (plus2 p1 (normlen2 (plus (times len 0.8)(times len sintheta)) (diff2 p3 p1)))))))
;
(defkazari gothic (migiue 0 migiue 1)
  (lets ((p1 (vref cross 0))
	 (p0 (vref cross 1))
	 (p3 (vref cross 2))
	 (p2 (vref cross 3))
	 (d0 (norm2 (diff2 p3 p1)))
	 (len (metric2 p0 p1))
;	 (sintheta (times 0.5 (car d0)))
	 (sintheta 0)
	 )
  `(
    (angle .,
     (plus2 p1 (normlen2 (plus (times len 0.8)(times len sintheta)) (diff2 p3 p1))))
    (bezier .,
     (plus2 p1 (normlen2 (plus (times len 0.6)(times 1.5 len sintheta)) (diff2 p3 p1))
	    (normlen2 (times len 0.5) (diff2 p1 p0))))
    (bezier .,
     (plus2 p1 (normlen2 (plus (times len 0.2)(times len sintheta)) (diff2 p3 p1))
	    (normlen2 (times len 0.5) (diff2 p1 p0))))
    (angle .,p0))))
;
(defkazari gothic ((sanzui kokoro migiue tasuki) 2 (sanzui kokoro migiue tasuki) 3)
  (lets ((p1 (vref cross 0))
	 (p0 (vref cross 1))
	 (p3 (vref cross 2))
	 (p2 (vref cross 3))
	 (d0 (norm2 (diff2 p3 p1)))
	 (sintheta (min 0.25 (times 0.5 (cadr d0))))
	 (l0 (normlen2 (times sintheta (metric2 p0 p1)) d0))
	 )
    `((angle .,(plus2 p1 l0))
      (angle .,(diff2 p0 l0)))))
(defkazari gothic (ten 2 ten 3)
  (lets ((p1 (vref cross 0))
	 (p0 (vref cross 1))
	 (p3 (vref cross 2))
	 (p2 (vref cross 3))
	 (l0 (times2 -0.1 (diff2 p3 p1))))
    `((angle .,(plus2 p1 l0))
      (angle .,(diff2 p0 l0)))))
;
(defkazari gothic 
;  ((hidari tatehidari migi tatehane tsukurihane shin-nyuu kozato) 2
;   (hidari tatehidari migi tatehane tsukurihane shin-nyuu kozato) 3)
  ((hidari tatehidari migi shin-nyuu) 2
   (hidari tatehidari migi shin-nyuu) 3)
  (lets ((p1 (vref cross 0))
	 (p0 (vref cross 1))
	 (p3 (vref cross 2))
	 (p2 (vref cross 3))
	 (d0 (norm2 (diff2 p3 p1)))
	 (costheta (times 0.2 (car d0)))
	 (l0 (normlen2 (times costheta (metric2 p0 p1)) d0))
	 )
    `((angle .,(diff2 p1 l0))
      (angle .,(plus2 p0 l0)))))
;	 
(defkazari gothic ((magaritate tsukurihane hidari) 1 yoko 3)
  (lets ((p0 (vref cross 0))
	 (p1 (vref cross 1))
	 (p2 (vref cross 2))
	 (p3 (vref cross 3)))
      `((angle .,(inter2 p2 p3 0.3))
	(angle .,(inter2 p1 p3 0.3)))))
(defkazari gothic (hidari 2 ten 0)
  (lets ((p0 (vref cross 0))
	 (p1 (vref cross 1))
	 (p2 (vref cross 2))
	 (p3 (vref cross 3))
	 (newp0 (plus2 p3 (normlen2 (times 3.0 local_gothicwidth)(diff2 p0 p3))))
	 )
    `((angle .,newp0))))
;;
;; エレメントの定義
;;
;
; 点の定義
;
(defelement gothic ten
  (lets ((x (car points))
	 (y (cadr points))
	 (x (inter2 y x 0.9))
	 (w local_gothicwidth)
	 (diff (diff2 y x))
	 (m (plus2 (times2 0.5 (plus2 x y))
		   (times2 0.1 (list (cadr diff)(minus (car diff)))))))
	(gothic3 x m y w)))

;	(niku3 x m y 0.3 0.3 w w w (times 1.1 w))))
;
; 縦棒の定義
;
(defelement gothic tate
  (let ((x (car points))
	(y (cadr points))
	(w local_gothicwidth))
    (gothic2 x y w))))

;
; 横棒の定義
;
(defelement gothic yoko
  (let ((x (car points))
	(y (cadr points))
	(w local_gothicwidth))
    (gothic2 (inter2 x y 0.000001) (inter2 y x 0.00001) w)))
;
; 右上はらいの定義
;
(defelement gothic migiue
  (let ((x (car points))
	(y (cadr points))
	(z (caddr points))
	(w local_gothicwidth)
	)
;  (niku3 x y z 0.3 0.3 w w w w)
    (gothic3 x y z w)
 ))

;
; 左はらいの定義
;
(defelement gothic hidari
  (lets ((p0 (car points))
	(p1 (cadr points))
	(p2 (caddr points))
	(w local_gothicwidth)
	)
    (gothic3 p0 p1 p2 w)))
;
; 縦左はらいの定義
;
(defelement gothic tatehidari
  (lets ((p0 (car points))
	 (p1 (cadr points))
	 (p2 (caddr points))
	 (p3 (cadddr points))
	 (w local_gothicwidth)
	 (l0 (gothic2 p0 p1 w))
	 (l1 (gothic3 p1 p2 p3 w)))
    `(,(nconc (car l0) (cdar l1))
      ,(nconc (cadr l0) (cdadr l1)))))
;
; 右はらいの定義
;
(defelement gothic migi
  (let ((x (car points))
	(y (cadr points))
	(z (caddr points))
	(w local_gothicwidth))
;    (niku3 x y z 0.3 0.3 w w w w)
    (gothic3 x y z w)
    ))
;
; こざと偏の一部
;
(defelement gothic kozato
  (lets ((p0 (car points))
	(p1 (cadr points))
	(p2 (caddr points))
	(p3 (fourth points))
	(p12 (inter2 p1 p2 0.5))
	(w local_gothicwidth))
    (curve2 p0 (inter2 p0 p1 0.6)(inter2 p12 p1 0.6) p12
	    w w w w
	    (hane p12 p2 p3
		    w w w))))
;
; 縦跳ね
;
(defelement gothic tatehane
  (lets ((p0 (car points))
	 (p1 (cadr points))
	 (p2 (caddr points))
	 (w local_gothicwidth)
	 (p1 (plus2 p1 (normlen2 w (diff2 p0 p1))))
	 (p2 (plus2 p2 (normlen2 w (diff2 p0 p1))))
	 (len0 (metric2 p0 p1))
	 (len1 (metric2 p1 p2))
	 (p01 (inter2 p1 p0 (quotient len1 len0)))
	 (p2 (plus2 p1 (normlen2 (max (times 2.0 w)(metric2 p2 p1))
				 (diff2 p2 p1)))))
    (line2 p0 p01 w (hane p01 p1 p2 w w w))))
;	 (out1 (gothic2 p0 p01 w))
;	 (out2 (gothiccurve p01 p1 p2 w)))
;    `(,(nconc (car out1)(cdar out2))
;      ,(nconc (cadr out1)(cdadr out2)))))
;
; 旁の跳ね
;	    
(defelement gothic tsukurihane
  (lets ((p0 (car points))
	 (p1 (cadr points))
	 (p2 (caddr points))
	 (p3 (cadddr points))
	 (w local_gothicwidth)
	 (p2 (plus2 p2 (normlen2 w (diff2 p1 p2))))
	 (p3 (plus2 p3 (normlen2 w (diff2 p1 p2))))
	 (p3 (cond ((lessp (metric2 p2 p3) (times w 2))
		    (plus2 p2 (normlen2 (times w 2)(diff2 p3 p2))))
		   (t p3)))
	 (p4 (inter2 p1 p2 0.5))
;	 (out1 (gothic3 p0 p1 p4 w))
;	 (out2 (gothic3 p4 p2 p3 w))
	 )
;    (break)
    (curve2 p0 (inter2 p0 p1 0.6)(inter2 p4 p1 0.6) p4
	    w w w w
	    (hane p4 p2 p3
		    w w w))))
;	    ))
;	 )
;    `(,(nconc (car out1)(cdar out2))
;      ,(nconc (cadr out1)(cdadr out2)))))
;
; さんずい
;
(defelement gothic sanzui 
  (lets ((p0 (car points))
	 (p1 (cadr points))
	 (dx (difference (car p0)(car p1)))
	 (p0 (plus2 p0 `(,dx 0)))
	 (p1 (inter2 p0 p1 0.7))
	 (p0 (inter2 p1 p0 0.9))
	 (v0 (times2 0.05 (rot270 (diff2 p1 p0))))
	 (p2 (plus2 (inter2 p0 p1 0.5) v0))
	 (w local_gothicwidth))
    (gothic3 p0 p2 p1 w)))

;
; こころ
;
(defelement gothic kokoro
  (lets ((p0 (car points))
	 (p1 (cadr points))
	 (p2 (caddr points))
	 (p3 (cadddr points))
	 (w local_gothicwidth)
	 (p2 (plus2 p2 (normlen2 (times w 1.2)(diff2 p1 p2))))
	 (p1 (plus2 p1 (normlen2 w (diff2 p0 p1))))
	 (p2 (plus2 p2 (normlen2 w (diff2 p3 p2))))
	 (w2 (times w 2))
	 (p10 (plus2 p1 (normlen2 w2 (diff2 p0 p1))))
	 (p12 (cond ((lessp (metric2 p1 p2) (times w2 2.0))
		     (inter2 p1 p2 0.5))
		    (t (plus2 p1 (normlen2 w2 (diff2 p2 p1))))))
	 (p21 (cond ((lessp (metric2 p1 p2) (times w2 2.0))
		     nil)
		    (t (plus2 p2 (normlen2 w2 (diff2 p1 p2))))))
	 (p23 (plus2 p2 (normlen2 (min w2 (times 0.8 (metric2 p3 p2)))(diff2 p3 p2))))
	 (out1 (gothic2 p0 p10 w))
	 (out2 (gothiccurve p10 p1 p12 w))
	 (out3 (cond (p21 (gothic2 p12 p21 w))
		     (t '((nil) (nil)))))
	 (out4 (cond (p21 (gothiccurve p21 p2 p23 w))
		     (t (gothiccurve p12 p2 p23 w))))
	 (out5 (gothic2 p23 p3 w)))
    `(,(nconc (car out1)(cdar out2)(cdar out3)(cdar out4)(cdar out5))
      ,(nconc (cadr out1)(cdadr out2)(cdadr out3)(cdadr out4)(cdadr out5)))))
;
; たすき
;
(defelement gothic tasuki
  (lets ((p0 (car points))
	 (p1 (cadr points))
	 (p2 (caddr points))
	 (p3 (cadddr points))
	 (w local_gothicwidth)
	 (p21 (plus2 p2 (normlen2 
			 (min (times 0.5 (metric2 p1 p2))(times 4 w))
			 (diff2 p1 p2))))
	 (p23 (plus2 p2 (normlen2 
			 (min (times 0.5 (metric2 p2 p3))(times 4 w))
			 (diff2 p3 p2)))))
	 (curve2 p0 (inter2 p0 p1 0.7)(inter2 p21 p1 0.7) p21
		 w w w w
		 (curve2 p21 (inter2 p21 p2 0.7)(inter2 p23 p2 0.7) p23
			 w w w w
			 (gothic2 p23 p3 w)))))
;    `(,(nconc (car out1)(cdar out2)(cdar out3))
;      ,(nconc (cadr out1)(cdadr out2)(cdadr out3)))))
;
; まがりたて
;
(defelement gothic magaritate
  (let ((p0 (car points))
	(p1 (cadr points))
	(p2 (caddr points))
	(w local_gothicwidth))
    (cond ((lessp (metric2 p1 p2)(times 4.0 w))
	   (gothic2 p0 p2 w))
	  (t
	   (gothic3 p0 p1 p2 w)))))
;
; かぎ
;
(defelement gothic kagi
  (lets ((p0 (car points))
	 (p1 (cadr points))
	 (p2 (caddr points))
	 (w local_gothicwidth)
	 (p1 (plus2 p1 (normlen2 w (diff2 p0 p1))))
	 (p2 (plus2 p2 (normlen2 w (diff2 p0 p1))))
	 (w2 (times w 3))
       	 (p10 (cond ((lessp w2 (metric2 p0 p1)) 
		     (plus2 p1 (normlen2 w2 (diff2 p0 p1))))
		    (t p0)))
       	 (p12 (cond ((lessp w2 (metric2 p2 p1))
		     (plus2 p1 (normlen2 w2 (diff2 p2 p1))))
		    (t (inter2 p1 p2 0.9))))
	 (out1 (cond ((not (eq p0 p10)) (gothic2 p0 p10 w))(t '(nil nil))))
	 (out2 (gothiccurve p10 p1 p12 w circle-ratio))
	 (out3 (gothic2 p12 p2 w)))
    `(,(nconc (car out1)(cdar out2)(cdar out3))
      ,(nconc (cadr out1)(cdadr out2)(cdadr out3)))))
;
; しんにゅう
;
(defelement gothic shin-nyuu
  (lets ((p0 (car points))
	 (p1 (cadr points))
	 (p2 (caddr points))
	 (w local_gothicwidth))
    (curve2 p0 (inter2 p0 p1 0.7)(inter2 p2 p1 0.7) p2 w w w w)))
;	(gothic3 p0 p1 p2 w)))
;
(deftypehook gothic
  (function gothic-prim))
(declare (yokopoints) special)
(defun rm-geta (prim getalen)
  (lets ((points (car prim))
	 (elements (cadr prim))
	 (newelements)
	 (linkpoints)
	 (yokopoints))
    (do ((l elements (cdr l))(p)(link))
      ((atom l))
      (and (setq link (assq 'link (cddar l)))
	   (setq linkpoints (append (cdr link) linkpoints)))
      (and (eq (caar l) 'yoko)
	   (setq p (cadar l))
	   (setq yokopoints `(,(car p) ,(cadr p) .,yokopoints)))
      (or (memq (caar l) '(tate magaritate))
	  (setq linkpoints (append (cadar l) linkpoints))))
    (do ((l elements (cdr l))(epoints)(p1)(lastp)(rp1)(link)(yokolink))
      ((atom l)
       `(,points ,(nreverse newelements) .,(cddr prim)))
      (cond ((memq (caar l) '(tate magaritate))
	     (setq epoints (copy (cadar l)))
	     (setq lastp (last epoints))
	     (setq rp1 (nth (setq p1 (car lastp)) points))
	     (setq link (assq 'link (cddar l)))
	     (and link
		  (setq yokolink 
			(do ((ll (cdr link)(cdr ll))(ret))
			  ((atom ll)(nreverse ret))
			  (and (memq (car ll) yokopoints)
			       (push (car ll) ret)))))
	     (cond ((or (null link)(null yokolink)(memq p1 linkpoints))
		    (push (car l) newelements))
		   (t
		    (do ((ll yokolink (cdr ll))(minlink)(minlen)(p)(len))
		      ((atom ll)
		       (cond ((lessp minlen getalen)
			      (rplaca lastp minlink)
;                              (break)
			      (push `(,(caar l) ,epoints 
				      (link .,(remq minlink (cdr link)))
				      .,(cddar l)) newelements))
			     (t
			      (push (car l) newelements))))
		      (setq p (nth (car ll) points))
		      (setq len (metric2 rp1 p))
		      (and (or (null minlink)(lessp len minlen))
			   (setq minlink (car ll) minlen len))))))
	    (t (push (car l) newelements))))))

(defun gothic-prim (prim)
  (lets ((prim (rm-geta prim 30.0))
	 (points (car prim))
	 (elements (cadr prim))
	 (alist (cddr prim))
	 (origunits (units prim))
	 (units (units 
		 `(,points ,elements 
			   .,(every alist 
				    #'(lambda (x) 
					(not (memq (car x) 
						   '(xunit yunit))))))))
	 (width (min gothicwidth
		     (times 0.16 (min (car origunits)(cdr origunits)(car units)(cdr units))))))
;    (break)
    (setq local_gothicwidth width)
    `(,points ,elements .,alist)))