View of /renderer/transform.l

Parent Directory

Revision Log

*** empty log message ***

(defun in-region (point region)
  (and (lessp (first region) (car point) (third region))
       (lessp (second region) (cadr point) (fourth region))))


(defun transprim (fonttype param prim)
  (lets ((prim (applykanji prim))
	 (elements (cadr prim))
	 (alist (cddr prim))
	 (trans (assq 'trans alist)))
    (do ((ll (cdr trans) (cddr ll))
	 (newpoints)
	 (points (car prim) (nreverse newpoints))
	 (region)(affine))
      ((atom ll)
       `(,points ,elements .,alist))
      (setq newpoints nil)
      (setq region (car ll))
      (setq affine (scale-affine param (vector 6 (cadr ll))))
      (do ((l points (cdr l)))
	((atom l))
	(cond ((in-region (car l) region)
	       (push (affine (car l) affine) newpoints))
	      (t (push (car l) newpoints)))))))
;
(defun checkhook2 (type prim1 prim2 alist)
  (lets ((eprim1 (applykanji prim1))
	 (eprim2 (applykanji prim2))
	 (hook1 (assq 'hook (cddr eprim1)))
	 (hook1 (and hook1 (assoc (list type 0) (cdr hook1))))
	 (hook2 (assq 'hook (cddr eprim2)))
	 (hook2 (and hook2 (assoc (list type 1) (cdr hook2)))))
    (cond (hook1 (funcall (cdr hook1) prim1 prim2 alist))
	  (hook2 (funcall (cdr hook2) prim1 prim2 alist)))))
;
(defun transregion (region trans param)
  (lets ((transregion (car trans))
	 (affine (scale-affine param (vector 6 (cadr trans))))
	 (x0 (first region))(y0 (second region))
	 (x1 (third region))(y1 (fourth region))
	 (nx0 x0)(ny0 y0)(nx1 x1)(ny1 y1)(p))
    (cond ((in-region `(,x0 ,y0) transregion)
	   (setq p (affine `(,x0 ,y0) affine))
	   (setq nx0 (car p) ny0 (cadr p))))
    (cond ((in-region `(,x0 ,y1) transregion)
	   (setq p (affine `(,x0 ,y1) affine))
	   (setq nx0 (car p) ny1 (cadr p))))
    (cond ((in-region `(,x1 ,y0) transregion)
	   (setq p (affine `(,x1 ,y0) affine))
	   (setq nx1 (car p) ny0 (cadr p))))
    (cond ((in-region `(,x1 ,y1) transregion)
	   (setq p (affine `(,x1 ,y1) affine))
	   (setq nx1 (car p) ny1 (cadr p))))
    `(,nx0 ,ny0 ,nx1 ,ny1)))
;
(defun kamaetrans (prim1 prim2 alist)
  (lets ((eprim1 (add-unit (applykanji prim1)))
	 (eprim2 (add-unit (applykanji prim2)))
	 (affines (affine-kamae eprim1 eprim2 alist))
	 (yunit1 (yunit eprim1))
	 (yunit2 (times (vref (cadr affines) 3)
			(yunit eprim2)))
	 (alist1 (cddr eprim1))
	 (trans (cdr (assq 'trans alist1)))
	 (kamae (cdr (assq 'kamae alist1)))
	 (kamae1 (transregion kamae trans 1.0))
	 (ratio (-$ (//$ (float (region-height kamae1))
			 (float (region-height kamae)))
		    1.0))
	 (param (//$ (difference yunit1 yunit2)
		     (plus yunit1 (times ratio yunit2))))
	 (param (max param 0.0))
	 (nprim1 (transprim nil param eprim1))
	 (nprim1 `(,(car nprim1) ,(cadr nprim1)
		   (kamae .,(transregion kamae trans param))
		   .,(cddr nprim1)))
	 (newaffines (affine-kamae nprim1 eprim2 alist)))
;		    (break)
    (joint nil newaffines `(,(transprim nil param prim1) ,prim2) nil)))
;
(defun nounit-kamae (prim1 prim2 alist)
  (lets ((eprim1 (applykanji prim1))
	 (eprim2 (applykanji prim2))
	 (affines (affine-kamae eprim1 eprim2 alist))
	 (newalist (remassoc 'xunit (remassoc 'yunit (cddr affines)))))
    (joint nil `(,(car affines),(cadr affines).,newalist)
	   `(,prim1 ,prim2) nil)))
	 
;
(defun changeprim (prim affine trans)
  (lets ((points (car prim))
	 (naffine (vector 6 affine))
	 (naffine (prog1 naffine (vset naffine 4 0)(vset naffine 5 0)))
	 (affine1 (times-affine naffine (vector 6 (cadr trans))))
	 (region (car trans)))
    (do ((l points (cdr l))
	 (ret))
      ((atom l)`(,(nreverse ret) .,(cdr prim)))
      (cond ((in-region (car l) region)
	     (push (list (affine (car l) affine)
			 (affine (car l) affine1)) ret))
	    (t (push (list (affine (car l) affine) '(0 0)) ret))))))
;
(defun tate2trans (prim1 prim2 alist)
  (lets ((eprim1 (applykanji prim1))
	 (eprim2 (applykanji prim2))
	 (alist2 (cddr eprim2))
	 (trans (cdr (assq 'trans alist2)))
	 (nprim2 (add-unit(transprim nil 1.0 eprim2)))
	 (affines (affine-tate-n `(,eprim1 ,nprim2) nil  alist))
	 (nprim1 (add-unit(affinepart eprim1 (car affines))))
	 (prim11 `(,(add0vector (car nprim1)) .,(cdr nprim1)))
	 (nprim22 (changeprim eprim2 (cadr affines) trans))
	 (param `((yunit 0 .,(yunit nprim1))(xunit 0 .,(xunit nprim1))))
	 (section (general-section1 prim11 nprim22 param))
	 (limit (cond (section (minus (section-minus section)))
		      (t 0.0)))

    (joint nil affines `(,prim1 ,(transprim nil limit prim2)) nil))))
;
(defun remassoc (item list)
  (do ((l list (cdr l))
       (ret))
    ((atom l)(nreverse ret))
    (or (eq (caar l) item)(push (car l) ret))))
;
(defun kashira (fonttype list)
  (lets ((prim (car list))
	 (newprim (transprim nil 1.0 (applykanji prim fonttype))))
    `(,(car newprim) ,(cadr newprim) .,(remassoc 'hook (cddr newprim)))))
;
(defun add-center (fonttype list)
  (lets ((center (car list))
	 (prim (cadr list))
	 (nprim (applykanji prim)))
    `(,(car nprim),(cadr nprim)(center .,center).,(cddr nprim))))
;
(defun nocenter (fonttype list)
  (lets ((prim (car list))
	(nprim (applykanji prim fonttype)))
    `(,(car nprim),(cadr nprim)(center).,(cddr nprim))))

(defun changexunit (fonttype list)
  (lets ((scale (car list))
	 (prim (cadr list))
	 (nprim (add-unit (applykanji prim)))
	(xunit (times scale (xunit nprim))))
    `(,(car nprim),(cadr nprim)(xunit .,xunit).,(cddr nprim))))