| ; |
; |
| ; |
; |
| ;(code-load '("/home/ktanaka/work/wadalabfont/lisp/window.o") "/usr/X11R6/lib/libX11.so") |
;(code-load '("/home/ktanaka/work/wadalabfont/lisp/window.o") "/usr/X11R6/lib/libX11.so") |
| |
; (code-load "/usr/X11R6/lib/libX11.so" "/home/ktanaka/work/wadalabfont/lisp/window.o") |
| ; |
; |
| (declare (err:argument-type err:number-of-arguments err:unbound-variable |
(declare (err:argument-type err:number-of-arguments err:unbound-variable |
| err:zero-division err:undefined-function) special) |
err:zero-division err:undefined-function) special) |
| (checkevent) |
(checkevent) |
| (close_window)) |
(close_window)) |
| |
|
| ; |
|
| ; pointを結ぶtension 1のスプラインを求める |
|
| ; |
|
| (declare (alpha beta gamma sqrt2 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)))))) |
|
| |
|
| (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)))) |
|
| |
|
| (defun drawpoints (points) |
(defun drawpoints (points) |
| (init_window 400 400) |
(init_window 400 400) |
| ((atom l)(drawlines ret)(redraw)(checkevent)(close_window)) |
((atom l)(drawlines ret)(redraw)(checkevent)(close_window)) |
| (push (cons (fix (caar l))(fix (cadar l))) ret))) |
(push (cons (fix (caar l))(fix (cadar l))) ret))) |
| ; |
; |
| |
(defun jointtest (prim1 prim2 affine type) |
| |
(filltest |
| |
(rmlimit (appendpart prim1 |
| |
(affinepart prim2 affine))) type)) |
| |
(defun rmlimit (x) |
| |
(lets ((elements (cadr x))(ret)) |
| |
(do ((l elements (cdr l))) |
| |
((atom l)`(,(car x) ,(nreverse ret) .,(cddr x))) |
| |
(or (memq (caar l) '(xlimit ylimit))(push (car l) ret))))) |
Diff of /lisp/disp.l
Parent Directory
| 
Revision Log