View of /renderer/hiranew.l

Parent Directory

Revision Log

*** empty log message ***

;
; please compile this file by iwasaki version compiler
;
(declare (hirawidth *default-hirawidth* circle-ratio gothicwidth smallhira-affine smallhira-width) special)

;
(defelement mincho hira-long
  (cond 
   ((equal 2 (length  points))
    (lets ((p0 (car points))
	   (p1 (cadr points))
	   (hwlist (assq 'hirawidth alist))
	   (w0 (cond (hwlist (cadr hwlist))(t *default-hirawidth*)))
	   (w1 (cond (hwlist (caddr hwlist))(t *default-hirawidth*)))
	   (l0 (rot270 (diff2 p1 p0)))
	   (a00 (plus2 p0 (normlen2 w0 l0)))
	   (a01 (diff2 p0 (normlen2 w0 l0)))
	   (a10 (plus2 p1 (normlen2 w1 l0)))
	   (a11 (diff2 p1 (normlen2 w1 l0))))
      `(((angle .,a00)(angle .,a10))
	((angle .,a01)(angle .,a11)))))
   (t
  (lets ((npoints (length points))
;	 (ms (times 0.5 meshsize))
	 (ms 0)
	 (array (vector (* npoints npoints) 0.0))
	 (func #'(lambda (x) (exp (times 0.66666 (log x)))))
	 (ti 
	  (vector (1- npoints)
		  (do ((l points (cdr l))
		       (ret))
		    ((atom (cdr l))(nreverse ret))
		    (push (funcall func (metric2 (car l)(cadr l))) ret))))
	 (titi (vector (1- npoints)))
	 (hwlist (assq 'hirawidth alist))
	 (bwi (vector (1- (* npoints 2))))
	 (dwi (vector (1- (* npoints 2))))
	 (wi (cond (hwlist
		    (vector npoints
			    (do ((l (cdr hwlist)(cdr l))
				 (ret))
			      ((atom l)(nreverse ret))
			      (push (max ms (times (car l) hirawidth)) ret))))
		   (t
		    (vector npoints *default-hirawidth*))))
	 (center (tenhokan points func))
	 )
    (do ((i 0 (1+ i)))((>= i (1- npoints)))
	(vset titi i (times (vref ti i)(vref ti i))))
    (vset array 0 (quotient 2.0 (vref ti 0)))
    (vset array 1 (quotient 1.0 (vref ti 0)))
    (vset bwi 0 (times (quotient 3.0 (vref titi 0))
		       (difference (vref wi 1)(vref wi 0))))
    (do ((i 0 (1+ i))
	 (j npoints (+ j npoints)))
      ((>= i (- npoints 2)))
      (vset array (+ j i) (quotient 1.0 (vref ti i)))
      (vset array (+ j i 1)(plus (quotient 2.0 (vref ti i))
				 (quotient 2.0 (vref ti (1+ i)))))
      (vset array (+ j i 2) (quotient 1.0 (vref ti (1+ i))))
      (vset bwi (1+ i)
	    (plus (times (quotient -3.0 (vref titi i))(vref wi i))
		  (times (difference (quotient 3.0 (vref titi i))
				     (quotient 3.0 (vref titi (1+ i))))
			 (vref wi (1+ i)))
		  (times (quotient 3.0 (vref titi (1+ i)))
			 (vref wi (+ i 2))))))
    (vset array (- (* npoints npoints) 2)
	  (quotient 1.0 (vref ti (- npoints 2))))
    (vset array (1- (* npoints npoints))
	  (quotient 2.0 (vref ti (- npoints 2))))
    (vset bwi (1- npoints)
	  (times (quotient 3.0 (vref titi (- npoints 2)))
		 (difference (vref wi (1- npoints))(vref wi (- npoints 2)))))
    (do ((i 0 (1+ i)))((>= i npoints))
	(vset dwi i 0.0)
	)
    (gs npoints array dwi bwi)
    (do ((i 0 (1+ i)))((>= i npoints))
	(vset dwi i (times 0.2 (vref dwi i))))
    (do ((l (reverse center))
	 (ret '(nil nil))
	 (i (1- npoints) (1- i)))
      ((atom l) ret)
      (match l
	(((angle . p3)(bezier . p2)(beizer . p1)(angle . p0) . rest)
	 (setq ret (curve1 p0 p1 p2 p3 
			   (vref wi (1- i))
			   (plus (vref wi (1- i))
				 (times 0.3333 (vref ti (1- i))
					(vref dwi (1- i))))
			   (plus (vref wi i)
				 (times -0.3333 (vref ti (1- i))
					(vref dwi i)))
			   (vref wi i)
			   ret))
	 (setq l (cdddr l)))
	(any (setq l (cdr l)))))))))

(defelement gothic hira-long
  (cond 
   ((equal 2 (length  points))
    (lets ((p0 (car points))
	   (p1 (cadr points))
	   (hwlist (assq 'hirawidth alist))
	   (w0 (cond (hwlist (cadr hwlist))(t *default-hirawidth*)))
	   (w1 (cond (hwlist (caddr hwlist))(t *default-hirawidth*)))
	   (l0 (rot270 (diff2 p1 p0)))
	   (a00 (plus2 p0 (normlen2 w0 l0)))
	   (a01 (diff2 p0 (normlen2 w0 l0)))
	   (a10 (plus2 p1 (normlen2 w1 l0)))
	   (a11 (diff2 p1 (normlen2 w1 l0))))
      `(((angle .,a00)(angle .,a10))
	((angle .,a01)(angle .,a11)))))
   (t
  (lets ((npoints (length points))
	 (array (vector (* npoints npoints) 0.0))
	 (func #'(lambda (x) (exp (times 0.66666 (log x)))))
	 (center (tenhokan points func))
	 (w gothicwidth)
	 )
    (do ((l (reverse center))
	 (ret '(nil nil)))
      ((atom l) ret)
      (match l
	(((angle . p3)(bezier . p2)(beizer . p1)(angle . p0) . rest)
	 (setq ret (curve1 p0 p1 p2 p3 w w w w ret))
	 (setq l (cdddr l)))
	(any (setq l (cdr l)))))))))

(setq circle-ratio (quotient (times 4.0 (difference (sqrt 2) 1)) 3.0))
(setq smallhira-affine (movexy 200 230 (scalexy 0.8 0.8 (movexy -200 -200))))
(setq smallhira-width 0.85)

(defun smallkana (type list)
  (lets ((prim (applykanji (car list) type))
	 (points (car prim))
	 (elements (cadr prim))
	 (newpoints)
	 (newelements))
    (do ((l points (cdr l)))
      ((atom l))
      (push (affine (car l) smallhira-affine) newpoints))
    (do ((l elements (cdr l))(element)(alist)(hirawidth))
      ((atom l))
      (setq element (car l))
      (setq alist (cddr element))
      (setq hirawidth (assq 'hirawidth alist))
      (cond (hirawidth
	     (do ((ll (cdr hirawidth)(cdr ll))
		  (newhirawidth))
	       ((atom ll)
		(push `(,(car element),(cadr element)
			(hirawidth .,(nreverse newhirawidth))
			.,(remq hirawidth alist))
		      newelements))
	       (push (fix (times smallhira-width (car ll))) newhirawidth)))
	    (t
	     (push element newelements))))
    `(,(nreverse newpoints),(nreverse newelements)
      (xlimit 15 385)(ylimit 15 385).,(cddr prim))))
;
(defun kana-joint (fonttype list)
  (lets ((affines (cadr (car list)))
	 (prims (cadr (cadr list))))
    (do ((outlines (affinepart (applykanji (car prims)fonttype)(car affines)))
	 (a (cdr affines)(cdr a))
	 (p (cdr prims)(cdr p)))
      ((atom p)`(,(car outlines),(cadr outlines)
		 (xlimit 15 385)(ylimit 15 385).,a))
      (setq outlines
	    (appendpart outlines
			(affinepart (applykanji (car p) fonttype)(car a)))))))
(defkazari mincho ((hira-short hira-long) 2 (hira-short hira-long) 0)
  (progn
;    (print (list (vref cross 0)(vref cross 1)(vref cross 2)(vref cross 3)))
    `((angle .,(vref cross 2))
      (angle .,(vref cross 1)))))
(defkazari gothic (hira-long 2 hira-long 0)
  (lets ((p0 (vref cross 0))
	 (p1 (vref cross 1))
	 (p2 (vref cross 2))
	 (p3 (vref cross 3))
	 (l0 (diff2 p2 p0))
	 (l1 (diff2 p1 p0))
	 (rightp (plusp (mul2 l1 (rot90 l0))))
	 (costheta (costheta l0 l1)))
    (cond ((and rightp (lessp 0.2 costheta))
	   `((angle .,p1)
	     (angle .,p2)))
	  (t `((angle .,p0))))))
(defkazari gothic (hira-long 3 hira-long 1)
  (lets ((p0 (vref cross 0))
	 (p1 (vref cross 1))
	 (p2 (vref cross 2))
	 (p3 (vref cross 3))
	 (l0 (diff2 p2 p0))
	 (l1 (diff2 p1 p0))
	 (rightp (plusp (mul2 l1 (rot90 l0))))
	 (costheta (costheta l0 l1)))
    (cond ((and (not rightp) (lessp 0.2 costheta))
	   `((angle .,p2)
	     (angle .,p1)))
	  (t `((angle .,p3))))))
     
					;
					; circle
					;
(defun circle0 (x y rx ry)
  (lets ((rx1 (times rx circle-ratio))
	 (ry1 (times ry circle-ratio))
	 (p0 `(,x ,(difference y ry )))
	 )
  `((angle .,p0)
    (bezier ,(plus x rx1) ,(difference y ry ))
    (bezier ,(plus x rx) ,(difference y ry1))
    (angle  ,(plus x rx) ,y)
    (bezier ,(plus x rx) ,(plus y ry1))
    (bezier ,(plus x rx1) ,(plus y ry ))
    (angle  ,x ,(plus y ry))
    (bezier ,(difference x rx1) ,(plus y ry ))
    (bezier ,(difference x rx) ,(plus y ry1))
    (angle  ,(difference x rx) ,y)
    (bezier ,(difference x rx) ,(difference y ry1))
    (bezier ,(difference x rx1) ,(difference y ry ))
    (angle  .,p0))))
;
(defun hira-circle (points (alist))
  (lets ((p0 (first points))
	 (p1 (second points))
	 (w (times *default-hirawidth* hirawidth))
	 (ix (difference (abs (difference (car p1)(car p0))) w))
	 (iy (difference (abs (difference (cadr p1)(cadr p0))) w))
	 (ox (plus (abs (difference (car p1)(car p0))) w))
	 (oy (plus (abs (difference (cadr p1)(cadr p0))) w))
	 (ic (circle0 (car p0)(cadr p0) ix iy))
	 (oc (circle0 (car p0)(cadr p0) ox oy)))
    `(,ic ,oc)))
;

(defelement mincho hira-circle (hira-circle points alist))
(defelement naal hira-circle (hira-circle points alist))

(defkazari mincho (hira-long 0 hira-long 1)
  (kanastart (vref cross 0)(vref cross 1)(vref cross 2)(vref cross 3)))
(defkazari mincho (hira-long 2 hira-long 3)
  (reverse
   (kanastart (vref cross 1)(vref cross 0)(vref cross 3)(vref cross 2))))
(defun kanastart (p0 p1 p2 p3)
  (lets ((pp0 (inter2 p2 p0 1.8))
	 (pp1 (inter2 p3 p1 1.8))
	 (pp2 (inter2 pp0 pp1 0.5)))
    `((angle .,p0)
      (bezier .,(inter2 p0 pp0 circle-ratio))
      (bezier .,(inter2 pp2 pp0 circle-ratio))
      (angle .,pp2)
      (bezier .,(inter2 pp2 pp1 circle-ratio))
      (bezier .,(inter2 p1 pp1 circle-ratio))
      (angle .,p1))))