| ;(cond ((definedp 'init_window)) |
|
| ; (t (code-load "window.o" "-lX11"))) |
|
| ; ライブラリをexfileする |
|
| ;(cond ((definedp 'kanjilib)) |
|
| ; (t (exfile 'lib.l))) |
|
| ; |
|
| ;(cond ((definedp 'unpackprim)) |
|
| ; (t (exfile 'pack.l))) |
|
| ; bez |
|
| ; Bezier曲線を直線群で近似する |
|
| ; |
|
| (defun bez (x0 y0 x1 y1 x2 y2 x3 y3 (dlist)) |
|
| (lets ((maxx (max x0 x1 x2 x3)) |
|
| (maxy (max y0 y1 y2 y3)) |
|
| (minx (min x0 x1 x2 x3)) |
|
| (miny (min y0 y1 y2 y3))) |
|
| (cond |
|
| ((or (lessp (difference maxx minx) 2) |
|
| (lessp (difference maxy miny) 2)) |
|
| `((,(fix x3) . ,(fix y3)).,dlist)) |
|
| (t |
|
| (lets ((tempx (times 0.125 (plus x0 (times 3 x1)(times 3 x2) x3))) |
|
| (tempy (times 0.125 (plus y0 (times 3 y1)(times 3 y2) y3)))) |
|
| (bez tempx tempy |
|
| (times (plus x3 x2 x2 x1) 0.25) |
|
| (times (plus y3 y2 y2 y1) 0.25) |
|
| (times (plus x3 x2) 0.5) |
|
| (times (plus y3 y2) 0.5) |
|
| x3 y3 |
|
| (bez x0 y0 |
|
| (times (plus x0 x1) 0.5) |
|
| (times (plus y0 y1) 0.5) |
|
| (times (plus x0 x1 x1 x2) 0.25) |
|
| (times (plus y0 y1 y1 y2) 0.25) |
|
| tempx tempy dlist))))))) |
|
| ; |
|
| ; アウトラインから折れ線への変換を行なう |
|
| ; |
|
| |
|
| (defun setpart1 (l) |
|
| (and l |
|
| (lets ((last (car l)) |
|
| (curx (cadr last)) |
|
| (cury (caddr last)) |
|
| (x0)(y0)(x1)(y1)(x2)(y2) |
|
| (ret `((,(fix curx).,(fix cury))))) |
|
| (do ((ll (cdr l) (cdr ll))) |
|
| ((atom ll)ret) |
|
| (match ll |
|
| ((('angle x0 y0).next) |
|
| (setq ret `((,(fix x0).,(fix y0)).,ret)) |
|
| (setq curx x0 cury y0)) |
|
| ((('bezier x0 y0)('bezier x1 y1)) |
|
| (exit (bez curx cury x0 y0 x1 y1 (cadr last)(caddr last) ret))) |
|
| ((('bezier x0 y0)('bezier x1 y1)('angle x2 y2).next) |
|
| (setq ret (bez curx cury x0 y0 x1 y1 x2 y2 ret)) |
|
| (setq curx x2 cury y2) |
|
| (setq ll (cddr ll))) |
|
| (any (break) ; 想定しない入力 |
|
| )))))) |
|
| ; |
; |
| ; スケルトンからアウトラインへの変換を行なう |
; スケルトンからアウトラインへの変換を行なう |
| ; |
; |
| |
|
| |
; |
| |
; pointsのn番目を取り，floatに変換する |
| |
; |
| (defun point-n (n points) |
(defun point-n (n points) |
| (let ((point (nth n points))) |
(let ((point (nth n points))) |
| `(,(float (car point)),(float (cadr point)) .,(cddr point)))) |
`(,(float (car point)),(float (cadr point)) .,(cddr point)))) |
| |
|
| |
; |
| |
; points全体をfloatに変換する |
| |
; |
| (defun floatlist (list) |
(defun floatlist (list) |
| (mapcar list |
(mapcar list |
| (function (lambda (x) `(,(float (car x)),(float (cadr x)).,(cddr x)))))) |
(function (lambda (x) `(,(float (car x)),(float (cadr x)).,(cddr x)))))) |
| |
; |
| |
; 見てのとおり |
| |
; |
| (defun appendrev (a b) (append a (reverse b))) |
(defun appendrev (a b) (append a (reverse b))) |
| (defun skelton2list (l tag) |
; |
| |
; |
| |
; |
| |
(defun skeleton2list (l tag) |
| |
; 仮想的なエレメント xlimit, ylimitを取り除く |
| (setq l (rm-limit l)) |
(setq l (rm-limit l)) |
| |
; 書体固有のスケルトン変形関数が定義されている場合は呼び出す |
| (let ((func (get-def 'typehook tag))) |
(let ((func (get-def 'typehook tag))) |
| (and func (setq l (funcall func l)))) |
(and func (setq l (funcall func l)))) |
| (let ((linkpoints nil) |
(let ((linkpoints nil) |
| (tmpline nil)(type3 nil) |
(tmpline nil)(type3 nil) |
| (type1 nil)(type2 nil)(cross nil)(kazari nil)(part3 nil) |
(type1 nil)(type2 nil)(cross nil)(kazari nil)(part3 nil) |
| (lines (cadr l))) |
(lines (cadr l))) |
| |
; 配列linkpointsの初期化 |
| (do ((ll points (cdr ll)) |
(do ((ll points (cdr ll)) |
| (linkcount 0 (1+ linkcount))) |
(linkcount 0 (1+ linkcount))) |
| ((atom ll)) |
((atom ll)) |
| ((atom lll)) |
((atom lll)) |
| ; (push (point-n (car lll) points) partpoint) |
; (push (point-n (car lll) points) partpoint) |
| (push (nth (car lll) points) partpoint)) |
(push (nth (car lll) points) partpoint)) |
| |
(setq partpoint (nreverse partpoint)) |
| |
|
| ;; tag に対するプロパティが未定義のときのため(石井) |
;; tag に対するプロパティが未定義のときのため(石井) |
| ;; if を使わないように直す(田中) |
;; if を使わないように直す(田中) |
| (lets ((funcname (get-def type tag)) |
(lets ((funcname (get-def type tag)) |
| (result (cond (funcname |
(result (cond (funcname |
| (funcall funcname |
(funcall funcname |
| (nreverse partpoint)(cddr part))) |
partpoint(cddr part))) |
| (t |
(t |
| (print (list 'undefined tag)) |
(print (list 'undefined tag)) |
| (funcall (get type 'mincho) |
(funcall (get type 'mincho) |
| (nreverse partpoint)(cddr part)))))) |
partpoint(cddr part)))))) |
| `(lines ,result))) |
`(lines ,result))) |
| |
|
| (push tmpline linelist) |
(push tmpline linelist) |
| (t (funcall (car l) fonttype (cdr l))))) |
(t (funcall (car l) fonttype (cdr l))))) |
| (t (unpackprim l)))))) |
(t (unpackprim l)))))) |
| ; |
; |
| (defun expandall (list (file)) |
(defun expandall (list (file)(fonttype 'mincho)) |
| (let ((standard-output (cond (file (outopen (stream file))) |
(let ((standard-output (cond (file (outopen (stream file))) |
| (t standard-output)))) |
(t standard-output)))) |
| (do ((l list (cdr l)) |
(do ((l list (cdr l)) |
| (err:unbound-variable #'(lambda (x (y))(throw 'err))) |
(err:unbound-variable #'(lambda (x (y))(throw 'err))) |
| (err:zero-division #'(lambda (x (y))(throw 'err)))) |
(err:zero-division #'(lambda (x (y))(throw 'err)))) |
| (catch 'err |
(catch 'err |
| (setq ret (expandkanji (car l))))) |
(setq ret (expandkanji (car l) fonttype)))) |
| (cond ((consp ret) |
(cond ((consp ret) |
| (prind `(defjoint ,(car l) ',ret))))))) |
(prind `(defjoint ,(car l) ',ret))))))) |
| ; |
; |
| (do ((l (oblist) (cdr l))) |
(do ((l (oblist) (cdr l))) |
| ((atom l)) |
((atom l)) |
| (remprop (car l) 'prim))) |
(remprop (car l) 'prim))) |
| |
; |
| |
; pointを結ぶtension 1のスプラインを求める |
| |
; |
| |
(declare (alpha beta gamma sqrt2 sqrt5 d16 sqrt51 sqrt35)special) |
| |
(setq alpha 1.0 beta 1.0 gamma 0.0) |
| |
(defun reduce_points(points) |
| |
(do ((l points (cdr l)) |
| |
(ret nil) |
| |
(old '(10000.0 10000.0))) |
| |
((atom l)(nreverse ret)) |
| |
(cond ((>$ 1.0 (metric2 old (car l)))) |
| |
(t (push (car l) ret) |
| |
(setq old (car l)))))) |
| |
(defun spline (points) |
| |
(let ((fais nil) |
| |
(points (reduce_points points)) |
| |
(thetas nil) |
| |
(lengthes nil) |
| |
(npoints 2) |
| |
(psis nil) |
| |
(array nil) |
| |
(x nil) |
| |
(ret nil) |
| |
(b nil)) |
| |
(do ((l points (cdr l)) |
| |
(p0 nil) |
| |
(p1 nil) |
| |
(p2 nil) |
| |
(d0 nil) |
| |
(d1 nil) |
| |
(theta nil) |
| |
(costheta nil) |
| |
(sintheta nil)) |
| |
((atom (cddr l)) |
| |
(push (metric2 (car l)(cadr l)) lengthes) |
| |
(setq lengthes (nreverse lengthes)) |
| |
(push 0.0 psis) |
| |
(setq psis (nreverse psis))) |
| |
(setq p0 (car l) p1 (cadr l) p2 (caddr l)) |
| |
(setq d1 (diff2 p2 p1) d0 (diff2 p1 p0)) |
| |
(setq theta (theta d1 d0)) |
| |
(setq npoints (1+ npoints)) |
| |
(push (metric2 (car l)(cadr l)) lengthes) |
| |
; (print (list costheta sintheta theta lengthes)) |
| |
(push theta psis)) |
| |
(setq array (vector (* npoints npoints) 0.0)) |
| |
(setq x (vector npoints 0.0) b (vector npoints 0.0)) |
| |
(vset array 0 (-$ (//$ (*$ alpha alpha) beta) |
| |
(*$ 3.0 (*$ alpha alpha)) |
| |
(//$ (*$ gamma beta beta) alpha))) |
| |
(vset array 1 (-$ (//$ (*$ gamma beta beta) alpha) |
| |
(*$ 3.0 (*$ beta beta gamma)) |
| |
(//$ (*$ alpha alpha) beta))) |
| |
(vset b 0 (*$ (-$ (car psis))(vref array 1))) |
| |
(do ((i 1 (1+ i)) |
| |
(tmppsi psis (cdr tmppsi)) |
| |
(lk nil) |
| |
(lk1 nil) |
| |
(psi nil) |
| |
(psi1 nil) |
| |
(tmplen lengthes (cdr tmplen)) |
| |
(offset (+ npoints 1) (+ offset npoints 1))) |
| |
((>= i (1- npoints))) |
| |
(setq lk (car tmplen) lk1 (cadr tmplen)) |
| |
(setq psi (car tmppsi) psi1 (cadr tmppsi)) |
| |
(vset array (1- offset) (//$ (*$ beta beta) lk alpha)) |
| |
(vset array offset (+$ (*$ beta beta (//$ 1.0 lk) |
| |
(-$ 3.0 (//$ 1.0 alpha))) |
| |
(*$ alpha alpha (//$ 1.0 lk1) |
| |
(-$ 3.0 (//$ 1.0 beta))))) |
| |
(vset array (1+ offset) (//$ (*$ alpha alpha) lk1 beta)) |
| |
(vset b i (-$ (*$ psi beta beta (//$ 1.0 lk) |
| |
(-$ (//$ 1.0 alpha) 3.0)) |
| |
(//$ (*$ psi1 alpha alpha) lk1 beta)))) |
| |
(vset array (- (* npoints npoints) 2) |
| |
(-$ (//$ (*$ gamma alpha alpha) beta) |
| |
(*$ 3.0 gamma alpha alpha) |
| |
(//$ (*$ beta beta) alpha))) |
| |
(vset array (- (* npoints npoints) 1) |
| |
(-$ (//$ (*$ beta beta) alpha) |
| |
(*$ gamma alpha alpha) |
| |
(*$ 3.0 beta beta))) |
| |
; (print "psis") |
| |
; (print psis) |
| |
; (print "lengthes") |
| |
; (print lengthes) |
| |
; (print "array") |
| |
(do ((i 0 (1+ i))) |
| |
((>= i npoints)) |
| |
(do ((j 0 (1+ j)) |
| |
(ret nil)) |
| |
((>= j npoints)(nreverse ret)) |
| |
(push (vref array (+ (* npoints i) j)) ret))) |
| |
; (print "b") |
| |
(do ((i 0 (1+ i)) |
| |
(ret nil)) |
| |
((>= i npoints)(nreverse ret)) |
| |
(push (vref b i) ret)) |
| |
; (print "gs") |
| |
(gs npoints array x b) |
| |
(do ((i 0 (1+ i)) |
| |
(ret nil)) |
| |
((>= i npoints)(setq thetas (nreverse ret))) |
| |
(push (vref x i) ret)) |
| |
; (print "thetas")(print thetas) |
| |
(setq ret `((angle .,(car points)))) |
| |
(do ((l points (cdr l)) |
| |
(tmptheta thetas (cdr tmptheta)) |
| |
(tmppsi psis (cdr tmppsi)) |
| |
(diff nil)(p0 nil)(p1 nil)(fai nil)(f nil)(r nil) |
| |
(rotdiff nil)(sintheta nil)(costheta nil)(sinfai nil)(cosfai nil)) |
| |
((atom (cdr l))(nreverse ret)) |
| |
(setq p0 (car l) p1 (cadr l)) |
| |
(setq diff (diff2 p1 p0)) |
| |
(setq rotdiff (rot90 diff)) |
| |
(setq sintheta (sin (car tmptheta)) costheta (cos (car tmptheta))) |
| |
(setq fai (-$ 0.0 (car tmppsi)(cadr tmptheta))) |
| |
; (print (list (car tmppsi)(cadr tmptheta)fai)) |
| |
(setq sinfai (sin fai) cosfai (-$ (cos fai))) |
| |
(setq f (_f (car tmptheta) fai)) |
| |
(setq r (//$ f alpha)) |
| |
(push `(bezier .,(plus2 p0 (times2 (*$ r costheta) diff) |
| |
(times2 (*$ r sintheta) rotdiff))) ret) |
| |
(setq f (_f fai (car tmptheta))) |
| |
(setq r (//$ f beta)) |
| |
(push `(bezier .,(plus2 p1 (times2 (*$ r cosfai) diff) |
| |
(times2 (*$ r sinfai) rotdiff))) ret) |
| |
(push `(angle .,p1) ret)))) |
| |
|
| |
(setq sqrt2 (sqrt 2.0) sqrt5 (sqrt 5.0) d16 (//$ 1.0 16.0)) |
| |
(setq sqrt51 (-$ sqrt5 1.0) sqrt35 (-$ 3.0 sqrt5)) |
| |
(defun _f (theta fai) |
| |
(let ((sinfai (sin fai)) |
| |
(cosfai (cos fai)) |
| |
(sintheta (sin theta)) |
| |
(costheta (cos theta))) |
| |
(//$ (+$ 2.0 (*$ sqrt2 |
| |
(-$ sintheta (*$ d16 sinfai)) |
| |
(-$ sinfai (*$ d16 sintheta)) |
| |
(-$ costheta cosfai))) |
| |
(*$ 3.0 (+$ 1.0 |
| |
(*$ 0.5 sqrt51 costheta) |
| |
(*$ 0.5 sqrt35 cosfai)))))) |
| |
|
| |
; |
| |
; Gauss-Seidel 法により三重対角行列の解を求めているが， |
| |
; 優対角行列でない場合は問題があり |
| |
; LU分解の方が良い? |
| |
; |
| |
(defun gs (n array x b) |
| |
(do ((i 0 (1+ i))) |
| |
((> i 10)) |
| |
(vset x 0 (//$ (-$ (vref b 0) |
| |
(*$ (vref array 1)(vref x 1)) |
| |
(*$ (vref array (1- n))(vref x (1- n))) |
| |
) |
| |
(vref array 0))) |
| |
(do ((j 1 (1+ j)) |
| |
(offset (+ n 1) (+ offset n 1))) |
| |
((>= j (1- n))) |
| |
(vset x j |
| |
(//$ (-$ (vref b j) |
| |
(+$ (*$ (vref array (1- offset))(vref x (1- j))) |
| |
(*$ (vref array (1+ offset))(vref x (1+ j))))) |
| |
(vref array offset)))) |
| |
(vset x (1- n) (//$ (-$ (vref b (1- n)) |
| |
(*$ (vref array (* (1- n) n))(vref x 0)) |
| |
(*$ (vref array (- (* n n) 2))(vref x (- n 2)))) |
| |
(vref array (1- (* n n))))) |
| |
(do ((j 0 (1+ j)) |
| |
(ret nil)) |
| |
((>= j n)(nreverse ret)) |
| |
(push (vref x j)ret)))) |
Diff of /renderer/apply.l
Parent Directory
| 
Revision Log