View of /lisp/test/kananorm.l

Parent Directory

Revision Log

change to CVS wadalab font project

(setq kanacenter '(200 200))
(setq kanaspace 300)
(setq kanawidth 25)
(defun fixxy (p)
  `(,(fix (car p)) ,(fix (cadr p)) .,(cddr p)))
(defun kananorms (prims (filename))
  (lets ((standard-output 
	  (cond (filename (outopen (stream filename)))
		(t standard-output))))
    (do ((l prims (cdr l))
	 (prim))
      ((atom l))
      (setq prim (kananorm (applykanji (car l))))
      (prind `(defprimitive mincho ,(car l) ',prim)))))
(setq wratio 1.4)
(defun kananorm(prim)
  (lets ((points (car prim))
	 (elements (cadr prim))
	 (maxx)(minx)(maxy)(miny)(maxw 0)
	 (newpoints)(newelements)
	 (width)(height)(ratio)(meanx)(meany)(affine);(wratio)
	 (x)(y)(hirawidth)
	 )
    (do ((l points (cdr l)))
      ((atom l))
      (setq x (caar l) y (cadar l))
      (and (or (null maxx)(lessp maxx x))(setq maxx x))
      (and (or (null maxy)(lessp maxy y))(setq maxy y))
      (and (or (null minx)(lessp x minx))(setq minx x))
      (and (or (null miny)(lessp y miny))(setq miny y)))
    (do ((l elements (cdr l)))
      ((atom l))
      (setq element (car l))
      (setq hirawidth (assq 'hirawidth (cddr element)))
      (and hirawidth
	   (do ((ll (cdr hirawidth)(cdr ll)))
	     ((atom ll))
	     (and (lessp maxw (car ll))(setq maxw (car ll))))))
    (setq width (difference maxx minx))
    (setq height (difference maxy miny))
    (setq ratio (//$ (float kanaspace) (float (max width height))))
;    (setq meanx (times 0.5 (plus maxx minx)))
;    (setq meany (times 0.5 (plus maxy miny)))
;    (setq affine (movexy (car kanacenter)(cadr kanacenter)
;			 (scalexy ratio ratio
;				  (movexy (minus meanx)(minus meany)))))
;    (setq wratio (//$ (float kanawidth) (float maxw)))
    (do ((l points (cdr l)))
      ((atom l))
;      (push (fixxy (affine (car l) affine)) newpoints)
      (push (car l) newpoints)
      )
    (do ((l elements (cdr l)))
      ((atom l))
      (setq element (car l))
      (setq alist (cddr element))
      (setq hirawidth (assq 'hirawidth alist))
      (cond (hirawidth
	     (do ((ll (cdr hirawidth)(cdr ll))
		  (wlist))
	       ((atom ll)
		(push
		 `(,(car element)
		   ,(cadr element)
		   (hirawidth .,(nreverse wlist))
		   .,(remq hirawidth alist)) newelements))
	       (push (fix (times wratio (car ll))) wlist)))
	    (t (push element newelements))))
    `(,(nreverse newpoints) ,(nreverse newelements) .,(cddr prim))))
(defun center-of-gravity (prim)
  (lets ((points (car prim))
	 (elements (cadr prim))
	 (weight 0)(xsum 0)(ysum 0))
    (do ((l elements (cdr l)))
      ((atom l)
       `(,(//$ xsum weight 2.0) ,(//$ ysum weight 2.0)))
      (setq line (cadar l))
      (do ((ll line (cdr ll))(p0)(p1)(len))
	((atom (cdr ll)))
	(setq p0 (nth (car ll) points))
	(setq p1 (nth (cadr ll) points))
	(setq len (metric2 p0 p1))
	(setq weight (plus weight len))
	(setq xsum (plus xsum (times weight (plus (car p0)(car p1)))))
	(setq ysum (plus ysum (times weight (plus (cadr p0)(cadr p1)))))))))
(defun kana-thin (filename thinrate)
  (lets ((s (inopen (stream filename)))
	 (err:end-of-file #'(lambda (x y)(throw 'eof)))(x))
    (catch 'eof
      (loop
       (setq x (read s))
       (match x
	 (('defprimitive 'nil sym ('quote val))
	  (lets ((points (car val))
		 (elements (cadr val))
		 (alist (cddr val)))
	    (mapcar elements 
	      #'(lambda (x)
		  (map (assq 'hirawidth (cddr x))
		    #'(lambda (y) (and (numberp (car y))
				       (rplaca y (fix (times thinrate (car y))))))))))))
       (prind x)))))