Annotation of /renderer/transform.lAnnotation of /renderer/transform.l
Parent Directory
| 
Revision Log
Revision: 1.1 - (view) (download)
| 1 : | ktanaka | 1.1 | (defun in-region (point region) |
| 2 : | (and (lessp (first region) (car point) (third region)) | ||
| 3 : | (lessp (second region) (cadr point) (fourth region)))) | ||
| 4 : | |||
| 5 : | |||
| 6 : | (defun transprim (fonttype param prim) | ||
| 7 : | (lets ((prim (applykanji prim)) | ||
| 8 : | (elements (cadr prim)) | ||
| 9 : | (alist (cddr prim)) | ||
| 10 : | (trans (assq 'trans alist))) | ||
| 11 : | (do ((ll (cdr trans) (cddr ll)) | ||
| 12 : | (newpoints) | ||
| 13 : | (points (car prim) (nreverse newpoints)) | ||
| 14 : | (region)(affine)) | ||
| 15 : | ((atom ll) | ||
| 16 : | `(,points ,elements .,alist)) | ||
| 17 : | (setq newpoints nil) | ||
| 18 : | (setq region (car ll)) | ||
| 19 : | (setq affine (scale-affine param (vector 6 (cadr ll)))) | ||
| 20 : | (do ((l points (cdr l))) | ||
| 21 : | ((atom l)) | ||
| 22 : | (cond ((in-region (car l) region) | ||
| 23 : | (push (affine (car l) affine) newpoints)) | ||
| 24 : | (t (push (car l) newpoints))))))) | ||
| 25 : | ; | ||
| 26 : | (defun checkhook2 (type prim1 prim2 alist) | ||
| 27 : | (lets ((eprim1 (applykanji prim1)) | ||
| 28 : | (eprim2 (applykanji prim2)) | ||
| 29 : | (hook1 (assq 'hook (cddr eprim1))) | ||
| 30 : | (hook1 (and hook1 (assoc (list type 0) (cdr hook1)))) | ||
| 31 : | (hook2 (assq 'hook (cddr eprim2))) | ||
| 32 : | (hook2 (and hook2 (assoc (list type 1) (cdr hook2))))) | ||
| 33 : | (cond (hook1 (funcall (cdr hook1) prim1 prim2 alist)) | ||
| 34 : | (hook2 (funcall (cdr hook2) prim1 prim2 alist))))) | ||
| 35 : | ; | ||
| 36 : | (defun transregion (region trans param) | ||
| 37 : | (lets ((transregion (car trans)) | ||
| 38 : | (affine (scale-affine param (vector 6 (cadr trans)))) | ||
| 39 : | (x0 (first region))(y0 (second region)) | ||
| 40 : | (x1 (third region))(y1 (fourth region)) | ||
| 41 : | (nx0 x0)(ny0 y0)(nx1 x1)(ny1 y1)(p)) | ||
| 42 : | (cond ((in-region `(,x0 ,y0) transregion) | ||
| 43 : | (setq p (affine `(,x0 ,y0) affine)) | ||
| 44 : | (setq nx0 (car p) ny0 (cadr p)))) | ||
| 45 : | (cond ((in-region `(,x0 ,y1) transregion) | ||
| 46 : | (setq p (affine `(,x0 ,y1) affine)) | ||
| 47 : | (setq nx0 (car p) ny1 (cadr p)))) | ||
| 48 : | (cond ((in-region `(,x1 ,y0) transregion) | ||
| 49 : | (setq p (affine `(,x1 ,y0) affine)) | ||
| 50 : | (setq nx1 (car p) ny0 (cadr p)))) | ||
| 51 : | (cond ((in-region `(,x1 ,y1) transregion) | ||
| 52 : | (setq p (affine `(,x1 ,y1) affine)) | ||
| 53 : | (setq nx1 (car p) ny1 (cadr p)))) | ||
| 54 : | `(,nx0 ,ny0 ,nx1 ,ny1))) | ||
| 55 : | ; | ||
| 56 : | (defun kamaetrans (prim1 prim2 alist) | ||
| 57 : | (lets ((eprim1 (add-unit (applykanji prim1))) | ||
| 58 : | (eprim2 (add-unit (applykanji prim2))) | ||
| 59 : | (affines (affine-kamae eprim1 eprim2 alist)) | ||
| 60 : | (yunit1 (yunit eprim1)) | ||
| 61 : | (yunit2 (times (vref (cadr affines) 3) | ||
| 62 : | (yunit eprim2))) | ||
| 63 : | (alist1 (cddr eprim1)) | ||
| 64 : | (trans (cdr (assq 'trans alist1))) | ||
| 65 : | (kamae (cdr (assq 'kamae alist1))) | ||
| 66 : | (kamae1 (transregion kamae trans 1.0)) | ||
| 67 : | (ratio (-$ (//$ (float (region-height kamae1)) | ||
| 68 : | (float (region-height kamae))) | ||
| 69 : | 1.0)) | ||
| 70 : | (param (//$ (difference yunit1 yunit2) | ||
| 71 : | (plus yunit1 (times ratio yunit2)))) | ||
| 72 : | (param (max param 0.0)) | ||
| 73 : | (nprim1 (transprim nil param eprim1)) | ||
| 74 : | (nprim1 `(,(car nprim1) ,(cadr nprim1) | ||
| 75 : | (kamae .,(transregion kamae trans param)) | ||
| 76 : | .,(cddr nprim1))) | ||
| 77 : | (newaffines (affine-kamae nprim1 eprim2 alist))) | ||
| 78 : | ; (break) | ||
| 79 : | (joint nil newaffines `(,(transprim nil param prim1) ,prim2) nil))) | ||
| 80 : | ; | ||
| 81 : | (defun nounit-kamae (prim1 prim2 alist) | ||
| 82 : | (lets ((eprim1 (applykanji prim1)) | ||
| 83 : | (eprim2 (applykanji prim2)) | ||
| 84 : | (affines (affine-kamae eprim1 eprim2 alist)) | ||
| 85 : | (newalist (remassoc 'xunit (remassoc 'yunit (cddr affines))))) | ||
| 86 : | (joint nil `(,(car affines),(cadr affines).,newalist) | ||
| 87 : | `(,prim1 ,prim2) nil))) | ||
| 88 : | |||
| 89 : | ; | ||
| 90 : | (defun changeprim (prim affine trans) | ||
| 91 : | (lets ((points (car prim)) | ||
| 92 : | (naffine (vector 6 affine)) | ||
| 93 : | (naffine (prog1 naffine (vset naffine 4 0)(vset naffine 5 0))) | ||
| 94 : | (affine1 (times-affine naffine (vector 6 (cadr trans)))) | ||
| 95 : | (region (car trans))) | ||
| 96 : | (do ((l points (cdr l)) | ||
| 97 : | (ret)) | ||
| 98 : | ((atom l)`(,(nreverse ret) .,(cdr prim))) | ||
| 99 : | (cond ((in-region (car l) region) | ||
| 100 : | (push (list (affine (car l) affine) | ||
| 101 : | (affine (car l) affine1)) ret)) | ||
| 102 : | (t (push (list (affine (car l) affine) '(0 0)) ret)))))) | ||
| 103 : | ; | ||
| 104 : | (defun tate2trans (prim1 prim2 alist) | ||
| 105 : | (lets ((eprim1 (applykanji prim1)) | ||
| 106 : | (eprim2 (applykanji prim2)) | ||
| 107 : | (alist2 (cddr eprim2)) | ||
| 108 : | (trans (cdr (assq 'trans alist2))) | ||
| 109 : | (nprim2 (add-unit(transprim nil 1.0 eprim2))) | ||
| 110 : | (affines (affine-tate-n `(,eprim1 ,nprim2) nil alist)) | ||
| 111 : | (nprim1 (add-unit(affinepart eprim1 (car affines)))) | ||
| 112 : | (prim11 `(,(add0vector (car nprim1)) .,(cdr nprim1))) | ||
| 113 : | (nprim22 (changeprim eprim2 (cadr affines) trans)) | ||
| 114 : | (param `((yunit 0 .,(yunit nprim1))(xunit 0 .,(xunit nprim1)))) | ||
| 115 : | (section (general-section1 prim11 nprim22 param)) | ||
| 116 : | (limit (cond (section (minus (section-minus section))) | ||
| 117 : | (t 0.0))) | ||
| 118 : | |||
| 119 : | (joint nil affines `(,prim1 ,(transprim nil limit prim2)) nil)))) | ||
| 120 : | ; | ||
| 121 : | (defun remassoc (item list) | ||
| 122 : | (do ((l list (cdr l)) | ||
| 123 : | (ret)) | ||
| 124 : | ((atom l)(nreverse ret)) | ||
| 125 : | (or (eq (caar l) item)(push (car l) ret)))) | ||
| 126 : | ; | ||
| 127 : | (defun kashira (fonttype list) | ||
| 128 : | (lets ((prim (car list)) | ||
| 129 : | (newprim (transprim nil 1.0 (applykanji prim fonttype)))) | ||
| 130 : | `(,(car newprim) ,(cadr newprim) .,(remassoc 'hook (cddr newprim))))) | ||
| 131 : | ; | ||
| 132 : | (defun add-center (fonttype list) | ||
| 133 : | (lets ((center (car list)) | ||
| 134 : | (prim (cadr list)) | ||
| 135 : | (nprim (applykanji prim))) | ||
| 136 : | `(,(car nprim),(cadr nprim)(center .,center).,(cddr nprim)))) | ||
| 137 : | ; | ||
| 138 : | (defun nocenter (fonttype list) | ||
| 139 : | (lets ((prim (car list)) | ||
| 140 : | (nprim (applykanji prim fonttype))) | ||
| 141 : | `(,(car nprim),(cadr nprim)(center).,(cddr nprim)))) | ||
| 142 : | |||
| 143 : | (defun changexunit (fonttype list) | ||
| 144 : | (lets ((scale (car list)) | ||
| 145 : | (prim (cadr list)) | ||
| 146 : | (nprim (add-unit (applykanji prim))) | ||
| 147 : | (xunit (times scale (xunit nprim)))) | ||
| 148 : | `(,(car nprim),(cadr nprim)(xunit .,xunit).,(cddr nprim)))) | ||
| 149 : |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |