View of /lisp/souchou.l

Parent Directory

Revision Log

Initial revision

(subfont souchou mincho)
;
(defun curve2 (p1 p2 dp1 dp2 w1 w2 dw1 dw2 ti)
  (lets ((titi (times ti ti))
	 (ddp1 (plus2 (times2 (quotient 6.0 titi)
			      (diff2 p2 p1))
		      (times2 (quotient -4.0 ti) dp1)
		      (times2 (quotient -2.0 ti) dp2)))
	 (ddp2  (plus2 (times2 (quotient 6.0 titi)
			      (diff2 p1 p2))
		      (times2 (quotient 4.0 ti) dp2)
		      (times2 (quotient 2.0 ti) dp1)))
	 (dp1_ddp1 (mul2 dp1 ddp1))
	 (dp2_ddp2 (mul2 dp2 ddp2))
	 (lendp1 (length2 dp1))
	 (lendp2 (length2 dp2))
	 (lendp1_3 (quotient 1.0 (times lendp1 lendp1 lendp1)))
	 (lendp2_3 (quotient 1.0 (times lendp2 lendp2 lendp2)))
	 (a1 (plus2 p1 (normlen2 w1 (rot270 dp1))))
	 (a2 (plus2 p2 (normlen2 w2 (rot270 dp2))))
	 (b1 (diff2 p1 (normlen2 w1 (rot270 dp1))))
	 (b2 (diff2 p2 (normlen2 w2 (rot270 dp2))))
	 )
;    (break)
    `(((angle .,a1)
       (,test
	.,(plus2 a1
		 (times2 (quotient ti 3.0)
			 (plus2 dp1
				(times2 (quotient dw1 lendp1) (rot270 dp1))
				(times2 (quotient w1 lendp1) (rot270 ddp1))
				(times2 (times -1.0 w1 dp1_ddp1 lendp1_3)
					(rot270 dp1))))))
       (,test
	.,(plus2 a2
		 (times2 (quotient ti -3.0)
			 (plus2 dp2
				(times2 (quotient dw2 lendp2)(rot270 dp2))
				(times2 (quotient w2 lendp2) (rot270 ddp2))
				(times2 (times -1.0 w2 dp2_ddp2 lendp2_3)
					(rot270 dp2))))))
       (angle .,a2))
      ((angle .,b1)
       (,test 
	.,(plus2 b1
		 (times2 (quotient ti 3.0)
			 (plus2 dp1
				(times2 (quotient dw1 lendp1) (rot90 dp1))
				(times2 (quotient w1 lendp1) (rot90 ddp1))
				(times2 (times -1.0 w1 dp1_ddp1 lendp1_3)
					(rot90 dp1))
					))))
       (,test 
	.,(plus2 b2
		 (times2 (quotient ti -3.0)
			 (plus2 dp2
				(times2 (quotient dw2 lendp2) (rot90 dp2))
				(times2 (quotient w2 lendp2) (rot90 ddp2))
				(times2 (times -1.0 w2 dp2_ddp2 lendp2_3)
					(rot90 dp2))))))
       (angle .,b2)))))
;
(defkazari souchou (ten 2 ten 3)
  (lets ((p0 (vref cross 0))
	 (p1 (vref cross 1))
	 (p2 (vref cross 2))
	 (p3 (vref cross 3))
	 (p4 (times2 0.5 (plus2 p0 p1)))
	 (p5 (plus2 p1 (times2 1.0 (diff2 p3 p1))))
	 (p6 (plus2 p0 (times2 0.6 (diff2 p2 p0)))))
  `((angle .,p6)
    (angle .,p4)
    (angle .,p5))))
;
(setq souchouwidth 12.0)
(defelement souchou ten
  (lets ((p0 (car points))
	 (p1 (cadr points))
	 (w souchouwidth)
	 (l1 (normlen2 w (rot90 (diff2 p1 p0))))
	 (p2 (plus2 p1 l1))
	 (len (metric2 p0 p2))
	 (p02 (plus2 (inter2 p0 p2 0.5)(normlen2 (times len 0.05) l1)))
	 (d0 (times2 2 (diff2 p02 p0)))
	 (d2 (times2 2 (diff2 p2 p02)))
	 (dw (quotient w len)))
    (curve2 p0 p2 d0 d2 0 w w w 1)))
(defelement souchou hidari
  (lets ((p0 (car points))
	 (p1 (cadr points))
	 (p2 (caddr points))
	 (w souchouwidth)
	 (d0 (times2 2 (diff2 p1 p0)))
	 (d2 (times2 2.5 (diff2 p2 p1)))
	 (len1 (metric2 p0 p1))
	 (len2 (metric2 p1 p2))
	 (len (plus len1 len2))
	 (dw1 (quotient (times -0.5 w len) len))
	 (dw2 (times w -2)))
    (curve2 p0 p2 d0 d2 w 0 dw1 dw2 1)))