| ; X-Windowを扱うためのCの関数をロードする |
; X-Windowを扱うためのCの関数をロードする |
| ; |
; |
| ; |
; |
| |
;(code-load '("/home/ktanaka/work/wadalabfont/lisp/window.o") "/usr/X11R6/lib/libX11.so") |
| ; |
; |
| (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) |
| |
|
| ;(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)))))))) |
|
| ; |
|
| ; スケルトンからアウトラインへの変換を行なう |
|
| ; |
|
| |
|
| (defun point-n (n points) |
|
| (let ((point (nth n points))) |
|
| `(,(float (car point)),(float (cadr point)) .,(cddr point)))) |
|
| |
|
| (defun floatlist (list) |
|
| (mapcar list |
|
| (function (lambda (x) `(,(float (car x)),(float (cadr x)).,(cddr x)))))) |
|
| (defun appendrev (a b) (append a (reverse b))) |
|
| (defun skelton2list (l tag) |
|
| (setq l (rm-limit l)) |
|
| (let ((func (get-def 'typehook tag))) |
|
| (and func (setq l (funcall func l)))) |
|
| (let ((linkpoints nil) |
|
| (linelist nil) |
|
| (outline nil) |
|
| (points (floatlist(car l))) |
|
| (part nil)(type nil)(cpoint nil)(lpoint nil)(partpoint nil) |
|
| (tmppoint nil)(flag nil)(link nil)(part1 nil)(part2 nil) |
|
| (tmpline nil)(type3 nil) |
|
| (type1 nil)(type2 nil)(cross nil)(kazari nil)(part3 nil) |
|
| (lines (cadr l))) |
|
| (do ((ll points (cdr ll)) |
|
| (linkcount 0 (1+ linkcount))) |
|
| ((atom ll)) |
|
| (push (list linkcount (ncons 'link)) linkpoints)) |
|
| (do ((ll lines (cdr ll))) |
|
| ((atom ll)) |
|
| (setq part (car ll)) |
|
| (setq type (car part)) |
|
| ; (setq npoint (get type 'npoint)) |
|
| (setq cpoint (cadr part)) |
|
| (setq lpoint (assq 'link (cddr part))) |
|
| (setq lpoint (cond (lpoint (cdr lpoint)))) |
|
| (setq partpoint nil) |
|
| (do ((lll cpoint (cdr lll))) |
|
| ((atom lll)) |
|
| ; (push (point-n (car lll) points) partpoint) |
|
| (push (nth (car lll) points) partpoint)) |
|
| |
|
| ;; tag に対するプロパティが未定義のときのため(石井) |
|
| ;; if を使わないように直す(田中) |
|
| (setq tmpline |
|
| (lets ((funcname (get-def type tag)) |
|
| (result (cond (funcname |
|
| (funcall funcname |
|
| (nreverse partpoint)(cddr part))) |
|
| (t |
|
| (print (list 'undefined tag)) |
|
| (funcall (get type 'mincho) |
|
| (nreverse partpoint)(cddr part)))))) |
|
| `(lines ,result))) |
|
| |
|
| (push tmpline linelist) |
|
| (do ((lll cpoint (cdr lll)) |
|
| (i 0 (1+ i))) |
|
| ((atom lll)) |
|
| (cond ((zerop i) |
|
| (setq flag 0)) |
|
| ((atom (cdr lll));(eq i (1- npoint)) |
|
| (setq flag 1)) |
|
| (t (setq flag 2))) |
|
| (setq link (assq 'link (cdr (assq (car lll) linkpoints)))) |
|
| (rplacd link (cons (list type flag tmpline) (cdr link)))) |
|
| (do ((lll lpoint (cdr lll))) |
|
| ((atom lll)) |
|
| (setq link (assq 'link (cdr (assq (car lll) linkpoints)))) |
|
| (rplacd link (cons (list type 2 tmpline) (cdr link))))) |
|
| (do ((ll linkpoints (cdr ll))) |
|
| ((atom ll)) |
|
| (setq link (assq 'link (cdar ll))) |
|
| (cond |
|
| ((eq 4 (length link)) |
|
| (setq part1 (second link) part2 (third link) part3 (fourth link)) |
|
| (setq type1 (cadr part1) type2 (cadr part2) type3 (cadr part3)) |
|
| (and (memq type1 '(0 1))(memq type2 '(0 1))(memq type3 '(0 1)) |
|
| (lets ((ass1 (assq 'lines (cddr part1))) |
|
| (lines1 (second ass1)) |
|
| (line10 (selectq type1 |
|
| (0 (first lines1)) |
|
| (1 (reverse (second lines1))))) |
|
| (line11 (selectq type1 |
|
| (0 (second lines1)) |
|
| (1 (reverse (first lines1))))) |
|
| (dir1 (diff2 (cdr (second line10)) |
|
| (cdr (first line10)))) |
|
| (ass2 (assq 'lines (cddr part2))) |
|
| (lines2 (second ass2)) |
|
| (line20 (selectq type2 |
|
| (0 (first lines2)) |
|
| (1 (reverse (second lines2))))) |
|
| (line21 (selectq type2 |
|
| (0 (second lines2)) |
|
| (1 (reverse (first lines2))))) |
|
| (dir2 (diff2 (cdr (second line20)) |
|
| (cdr (first line20)))) |
|
| (ass3 (assq 'lines (cddr part3))) |
|
| (lines3 (second ass3)) |
|
| (line30 (selectq type3 |
|
| (0 (first lines3)) |
|
| (1 (reverse (second lines3))))) |
|
| (line31 (selectq type3 |
|
| (0 (second lines3)) |
|
| (1 (reverse (first lines3))))) |
|
| (dir3 (diff2 (cdr (second line30)) |
|
| (cdr (first line30)))) |
|
| (theta12 (theta dir2 dir1)) |
|
| (theta12 (cond ((minusp theta12) |
|
| (plus theta12 (times 2 3.14159265))) |
|
| (t theta12))) |
|
| (theta13 (theta dir3 dir1)) |
|
| (theta13 (cond ((minusp theta13) |
|
| (plus theta13 (times 2 3.14159265))) |
|
| (t theta13))) |
|
| (next1 (cond ((lessp theta12 theta13) |
|
| 2) |
|
| (t 3))) |
|
| (linesall (selectq next1 |
|
| (2 |
|
| `(((,line11 ,line20) |
|
| ((,type1 ,ass1)(,type2 ,ass2))) |
|
| ((,line21 ,line30) |
|
| ((,type2 ,ass2)(,type3 ,ass3))) |
|
| ((,line31 ,line10) |
|
| ((,type3 ,ass3)(,type1 ,ass1))))) |
|
| (3 |
|
| `( |
|
| ((,line11 ,line30) |
|
| ((,type1 ,ass1)(,type3 ,ass3))) |
|
| ((,line31 ,line20) |
|
| ((,type3 ,ass3)(,type2 ,ass2))) |
|
| ((,line21 ,line10) |
|
| ((,type2 ,ass2) |
|
| (,type1 ,ass1)))))))) |
|
| (do ((l linesall (cdr l)) |
|
| (line0)(type0)(lines0) |
|
| (line1)(type1)(lines1)(p)(plist)(flag1)(flag2)) |
|
| ((atom l) |
|
| (setq plist (nreverse plist)) |
|
| (do ((ll plist (cdr ll))(i 0 (1+ i)) |
|
| (start (car plist))(maxlen)(len0)(max)) |
|
| ((atom (cdr ll)) |
|
| (setq len0 (metric2 (car ll) start)) |
|
| (and (greaterp len0 maxlen)(setq max i)) |
|
| (setq max (remainder (1+ max) 3)) |
|
| ; (prind max) |
|
| ; (prind plist) |
|
| ; (prind linesall) |
|
| (setq type1 (car (first (second (nth max linesall))))) |
|
| (setq lines1 (cadr (first (second (nth max linesall))))) |
|
| (setq line1 `((angle .,(nth max plist)) |
|
| (angle .,(nth (remainder (1+ max) 3) |
|
| plist)) |
|
| (angle .,(nth (remainder (+ 2 max) 3) |
|
| plist)))) |
|
| (nconc lines1 `((,(difference -1 type1) |
|
| .,(cond ((zerop type1) |
|
| (nreverse line1)) |
|
| (t line1)) |
|
| ))) |
|
| ; (prind `(,type1 ,lines1)) |
|
| ) |
|
| (setq len0 (metric2 (car ll) (cadr ll))) |
|
| (and (or (null maxlen)(greaterp len0 maxlen)) |
|
| (setq maxlen len0)(setq max i)))) |
|
| (setq line0 (first (caar l)) line1 (second (caar l))) |
|
| (setq type1 (caar (cadar l)) lines1 (cadar (cadar l))) |
|
| (setq type2 (caadr (cadar l)) lines2 (cadadr (cadar l))) |
|
| (setq flag1 (cond ((equal type1 0) 1) |
|
| (t 2))) |
|
| (setq flag2 (cond ((equal type2 0) 0) |
|
| (t 3))) |
|
| (setq p (linecross line0 line1)) |
|
| (push p plist) |
|
| ; (prind p) |
|
| (nconc lines1 `((,flag1 .,p))) |
|
| (nconc lines2 `((,flag2 .,p))))))) |
|
| ((eq 3 (length link)) |
|
| (setq part1 (cadr link) part2 (caddr link)) |
|
| (setq type1 (cadr part1) type2 (cadr part2)) |
|
| (setq cross (crosspoint part1 part2)) |
|
| (setq kazari |
|
| (selectq type1 |
|
| (1 |
|
| (selectq type2 |
|
| (1 |
|
| (appendrev |
|
| (findkazari part1 part2 0 1 cross tag) |
|
| (findkazari part1 part2 1 0 cross tag))) |
|
| (0 |
|
| (appendrev |
|
| (findkazari part1 part2 0 0 cross tag) |
|
| (findkazari part1 part2 1 1 cross tag))) |
|
| (2 |
|
| (find-last part1 part2)))) |
|
| (0 |
|
| (selectq type2 |
|
| (1 |
|
| (appendrev |
|
| (findkazari part1 part2 1 1 cross tag) |
|
| (findkazari part1 part2 0 0 cross tag))) |
|
| (0 |
|
| (appendrev |
|
| (findkazari part1 part2 1 0 cross tag) |
|
| (findkazari part1 part2 0 1 cross tag))) |
|
| (2 |
|
| (find-first part1 part2)))) |
|
| (2 (selectq type2 |
|
| (0 (find-first part2 part1)) |
|
| (1 (find-last part2 part1)))))) |
|
| (cond ((> (length kazari) 2) (push kazari outline))) |
|
| ) |
|
| ((and (eq 2 (length link))(<= 0 (cadadr link) 1)) |
|
| (setq part1 (cadr link)) |
|
| (setq type1 (cadr part1)) |
|
| ; (setq cross (cross2point part1 (point-n (caar ll) points))) |
|
| (setq cross (cross2point part1 (nth (caar ll) points))) |
|
| (setq kazari |
|
| (findkazari part1 part1 0 1 cross tag)) |
|
| (nconc (assq 'lines (cddr part1)) (ncons(cons (- -1 type1) kazari)))))) |
|
| (do ((ll linelist (cdr ll)) |
|
| (part0 nil) |
|
| (part1 nil)) |
|
| ((atom ll)) |
|
| (setq part0 (car (cadar ll))) |
|
| (setq part1 (cadr (cadar ll))) |
|
| (setq part2 nil part3 nil) |
|
| ; (prind (cddar ll)) |
|
| (do ((lll (cddar ll) (cdr lll))) |
|
| ((atom lll)) |
|
| (selectq (caar lll) |
|
| (-2 (setq part3 (cond ((cdar lll)(cddar lll))))) |
|
| (-1 (setq part2 (cond ((cdar lll)(reverse (cddar lll)))))) |
|
| (0 (setq part0 (change-head part0 (cdar lll)))) |
|
| (1 (setq part1 (change-head part1 (cdar lll)))) |
|
| (2 (setq part0 (change-tail part0 (cdar lll)))) |
|
| (3 (setq part1 (change-tail part1 (cdar lll)))) |
|
| ; (t (prind (caar lll))) |
|
| )) |
|
| (push (append part0 part3 (reverse part1) part2) outline)) |
|
| ; (break) |
|
| outline)) |
|
| |
|
| ; find-first part1 part2 |
|
| ; part1の始点をpart2の内部に来るように変更する |
|
| ; nil を返す |
|
| |
|
| (defun find-first (part1 part2) |
|
| (lets ((lines0 (cadr (assq 'lines (cddr part1)))) |
|
| (curve0 (car lines0)) |
|
| (curve1 (cadr lines0)) |
|
| (line0 (list (cdar curve0)(cdadr curve0))) |
|
| (line1 (list (cdar curve1)(cdadr curve1))) |
|
| (lines1 (cadr (assq 'lines (cddr part2)))) |
|
| (curve0 (car lines1)) |
|
| (curve1 (cadr lines1)) |
|
| (p00 (cross2curve line0 curve0)) |
|
| (p01 (cross2curve line0 curve1)) |
|
| (p0 (inter2 p00 p01 0.75)) |
|
| (p10 (cross2curve line1 curve0)) |
|
| (p11 (cross2curve line1 curve1)) |
|
| (p1 (inter2 p10 p11 0.85))) |
|
| (nconc (assq 'lines (cddr part1)) `((0 .,p0)(1 .,p1))) |
|
| nil)) |
|
| ;(defun find-first (part1 part2) nil) |
|
| ; lineを延長してcurveへ交わる点があるかどうか |
|
| ; ある時はその点を返す |
|
| ; |
|
| (defun cross2curve (line curve) |
|
| (do ((l curve (cdr l)) |
|
| (ll nil) |
|
| (p0 (car line)) |
|
| (tmpcross) |
|
| (p1 (cadr line))) |
|
| ((atom (cdr l))(car line)) |
|
| (setq tmpcross |
|
| (cond ((eq (caadr l) 'angle) |
|
| (cross2line p0 p1 (cdar l) (cdadr l))) |
|
| (t |
|
| (setq ll l l (cddr l)) |
|
| (car (cross2bez p0 p1 (cdar ll) (cdadr ll) (cdaddr ll) (cdr (cadddr ll))))))) |
|
| (cond (tmpcross (exit tmpcross))))) |
|
| ; |
|
| ; |
|
| ; |
|
| (defun cross2line (p0 p1 l0 l1) |
|
| (lets ((d0 (diff2 p1 p0)) |
|
| (d1 (diff2 l0 p0)) |
|
| (d2 (diff2 l1 p0)) |
|
| (sin0 (costheta (rot90 d0) d1)) |
|
| (sin1 (costheta (rot90 d0) d2))) |
|
| (cond ((0<$ (*$ sin0 sin1))nil) |
|
| (t (linecross (list (cons nil p0)(cons nil p1)) |
|
| (list (cons nil l0)(cons nil l1))))))) |
|
| ; |
|
| ; |
|
| (defun cross2bez (p0 p1 b0 b1 b2 b3 (mint 0.0)(twidth 1.0)) |
|
| (lets ((x0 (car b0))(y0 (cadr b0)) |
|
| (x1 (car b1))(y1 (cadr b1)) |
|
| (x2 (car b2))(y2 (cadr b2)) |
|
| (x3 (car b3))(y3 (cadr b3)) |
|
| (maxx (max x0 x1 x2 x3)) |
|
| (maxy (max y0 y1 y2 y3)) |
|
| (minx (min x0 x1 x2 x3)) |
|
| (miny (min y0 y1 y2 y3)) |
|
| (tempx nil)(tempy nil) |
|
| (n0 nil)(ret nil)(tt nil)) |
|
| ; (prind (list p0 p1 b0 b1 b2 b3)) |
|
| (cond ((or (<$ (-$ maxx minx) 2.0)(<$ (-$ maxy miny) 2.0)) |
|
| ; (break) |
|
| (setq ret (cross2line p0 p1 b0 b3)) |
|
| (cond (ret |
|
| (setq tt |
|
| (plus mint |
|
| (times twidth |
|
| (quotient (metric2 b0 ret) |
|
| (metric2 b0 b3))))) |
|
| `(,ret . ,tt)) |
|
| (t `(nil . 0.0))) |
|
| ) |
|
| (t |
|
| (setq tempx (//$ (+$ x0 (*$ 3.0 x1)(*$ 3.0 x2) x3) 8.0)) |
|
| (setq tempy (//$ (+$ y0 (*$ 3.0 y1)(*$ 3.0 y2) y3) 8.0)) |
|
| (setq n0 (list tempx tempy)) |
|
| (lets ((d0 (diff2 p1 p0)) |
|
| (d1 (diff2 b0 p0)) |
|
| (d2 (diff2 n0 p0)) |
|
| (sin0 (costheta (rot90 d0) d1)) |
|
| (sin1 (costheta (rot90 d0) d2))) |
|
| (cond ((0<$ (*$ sin0 sin1)) |
|
| (setq d0 (diff2 p1 p0)) |
|
| (setq d1 (diff2 n0 p0)) |
|
| (setq d2 (diff2 b3 p0)) |
|
| (setq sin0 (costheta (rot90 d0) d1)) |
|
| (setq sin1 (costheta (rot90 d0) d2)) |
|
| (cond ((0<$ (*$ sin0 sin1))`(nil . 0.0)) |
|
| (t |
|
| (cross2bez p0 p1 n0 |
|
| (list (//$ (+$ x3 x2 x2 x1) 4.0)(//$ (+$ y3 y2 y2 y1) 4.0)) |
|
| (list (//$ (+$ x3 x2) 2.0)(//$ (+$ y3 y2) 2.0)) |
|
| b3 |
|
| (plus mint (times twidth 0.5)) |
|
| (times twidth 0.5) |
|
| )))) |
|
| (t |
|
| (cross2bez p0 p1 b0 |
|
| (list (//$ (+$ x0 x1) 2.0)(//$ (+$ y0 y1) 2.0)) |
|
| (list (//$ (+$ x0 x1 x1 x2) 4.0)(//$ (+$ y0 y1 y1 y2) 4.0)) |
|
| n0 |
|
| mint |
|
| (times twidth 0.5) |
|
| )))))))) |
|
| |
|
| |
|
| ; find-last part1 part2 |
|
| ; part1の終点をpart2の内部に来るように変更する |
|
| ; nil を返す |
|
| |
|
| (defun find-last (part1 part2) |
|
| (lets ((lines0 (cadr (assq 'lines (cddr part1)))) |
|
| (curve0 (reverse (car lines0))) |
|
| (curve1 (reverse (cadr lines0))) |
|
| (line0 (list (cdar curve0)(cdadr curve0))) |
|
| (line1 (list (cdar curve1)(cdadr curve1))) |
|
| (lines1 (cadr (assq 'lines (cddr part2)))) |
|
| (curve0 (car lines1)) |
|
| (curve1 (cadr lines1)) |
|
| (p00 (cross2curve line0 curve0)) |
|
| (p01 (cross2curve line0 curve1)) |
|
| (p0 (inter2 p00 p01 0.4)) |
|
| (p10 (cross2curve line1 curve0)) |
|
| (p11 (cross2curve line1 curve1)) |
|
| (p1 (inter2 p10 p11 0.3))) |
|
| (nconc (assq 'lines (cddr part1)) `((2 .,p0)(3 .,p1))) |
|
| nil)) |
|
| |
|
| ; |
|
| ; 始点を変更する |
|
| ; |
|
| |
|
| (defun change-head (l c) |
|
| (lets ((first (car l)) |
|
| (second (cadr l))) |
|
| ; (prind (list l c)) |
|
| (cond ((eq 'bezier (car second)) |
|
| (append (change-bezier l c)(cddddr l))) |
|
| (t (cons (cons 'angle c)(cdr l)))))) |
|
| |
|
| ; |
|
| ; 終点を変更する |
|
| ; bug |
|
| ; bug |
|
| ; bug |
|
| (defun change-tail (ll c) |
|
| (reverse (change-head (reverse ll) c))) |
|
| |
|
| ; |
|
| ; Bezier曲線の制御点を始点の変化にあわせて変更する |
|
| ; |
|
| |
|
| (defun change-bezier (l c) |
|
| ; (prind `(change-bezier ,l ,c)) |
|
| (lets ((p0 (cdr (first l))) |
|
| (p1 (cdr (second l))) |
|
| (p2 (cdr (third l))) |
|
| (p3 (cdr (fourth l))) |
|
| (dp0 (times2 3.0 (diff2 p1 p0))) |
|
| (dp3 (times2 3.0 (diff2 p3 p2))) |
|
| (ret) |
|
| (t1 (cond ((plusp (costheta (diff2 c p0)(diff2 p1 p0))) |
|
| (quotient (metric2 c p0)(metric2 p1 p0)3.0)) |
|
| (t |
|
| (minus (quotient (metric2 c p0)(metric2 p1 p0) 3.0))))) |
|
| (twidth3 (times (difference 1.0 t1) (quotient 1.0 3.0)))) |
|
| (cond ((zerop twidth3) |
|
| `((angle .,c)(angle .,p3))) |
|
| (t |
|
| (lets ((newdp0 (times2 twidth3 (bezierdp p0 p1 p2 p3 t1))) |
|
| (newdp3 (times2 twidth3 dp3))) |
|
| (setq ret |
|
| `((angle .,c) |
|
| (bezier .,(plus2 c newdp0)) |
|
| (bezier .,(diff2 p3 newdp3)) |
|
| (angle .,p3))) |
|
| ; (prind `(,t1 ,twidth3 ,ret)) |
|
| ret))))) |
|
| |
|
| ; |
|
| ; メンバーかどうか |
|
| ; |
|
| |
|
| (defun eq_member (l pat) |
|
| (cond ((eq pat '*)t) |
|
| ((atom pat)(eq l pat)) |
|
| (t (memq l pat)))) |
|
| |
|
| ; |
|
| ; 飾りのアウトラインを求める |
|
| ; |
|
| |
|
| (defun findkazari (part1 part2 line1 line2 cross tag) |
|
| (lets |
|
| ((ret nil) |
|
| (parttype1 (car part1)) |
|
| (parttype2 (car part2)) |
|
| (type1 (cadr part1)) |
|
| (type2 (cadr part2)) |
|
| (line1 (+ (* 2 type1)line1)) |
|
| (line2 (+ (* 2 type2)line2))) |
|
| (do ((tmptag tag (get tmptag 'parent))) |
|
| ((null tmptag)) |
|
| (do ((l (get-def 'allkazari tmptag) (cdr l)) |
|
| (ll nil)) |
|
| ((atom l)ret) |
|
| (setq ll (car l)) |
|
| (cond ((and (eq_member parttype1 (car ll)) |
|
| (eq_member line1 (cadr ll)) |
|
| (eq_member parttype2 (caddr ll)) |
|
| (eq_member line2 (cadddr ll))) |
|
| (setq ret (funcall (car (cddddr ll)) cross)) |
|
| (nconc (assq 'lines (cddr part1)) |
|
| (ncons(cons line1 (cdr (car ret))))) |
|
| (nconc (assq 'lines (cddr part2)) |
|
| (ncons (cons line2 (cdar (last ret))))) |
|
| (exit ret)) |
|
| ((and (eq_member parttype2 (car ll)) |
|
| (eq_member line2 (cadr ll)) |
|
| (eq_member parttype1 (caddr ll)) |
|
| (eq_member line1 (cadddr ll))) |
|
| (setq ret (funcall (car (cddddr ll)) (rev4 cross))) |
|
| (nconc (assq 'lines (cddr part1)) |
|
| (ncons(cons line1 (cdar (last ret))))) |
|
| (nconc (assq 'lines (cddr part2)) |
|
| (ncons(cons line2 (cdr (car ret))))) |
|
| (exit (reverse ret))))) |
|
| (and ret (exit))) |
|
| (cond |
|
| (ret) |
|
| ((eq part1 part2)nil) |
|
| (t |
|
| (setq ret (ncons (append '(angle) (vref cross (+ (logand line2 1) (* 2 (logand 1 line1))))))) |
|
| (nconc (assq 'lines (cddr part1)) (ncons(cons line1 (cdar ret)))) |
|
| (nconc (assq 'lines (cddr part2)) (ncons(cons line2 (cdar ret)))) |
|
| ret)))) |
|
| |
|
| ; |
|
| ; 転置行列 |
|
| ; |
|
| |
|
| (defun rev4 (cross) |
|
| (let ((ret (vector 4 cross))) |
|
| (vset ret 2 (vref cross 1)) |
|
| (vset ret 1 (vref cross 2)) |
|
| ret)) |
|
| |
|
| ; |
|
| ; 2つのpartの間の点 |
|
| ; |
|
| |
|
| (defun crosspoint (part1 part2) |
|
| (let ((ret (vector 4)) |
|
| (line0 (caadr (assq 'lines (cddr part1)))) |
|
| (line1 (cadadr (assq 'lines (cddr part1)))) |
|
| (line2 (caadr (assq 'lines (cddr part2)))) |
|
| (line3 (cadadr (assq 'lines (cddr part2))))) |
|
| (selectq (cadr part1) |
|
| (0 |
|
| (setq line0 (list (car line0)(cadr line0))) |
|
| (setq line1 (list (car line1)(cadr line1)))) |
|
| (1 |
|
| (setq line0 (reverse line0) line1 (reverse line1)) |
|
| (setq line0 (list (car line0)(cadr line0))) |
|
| (setq line1 (list (car line1)(cadr line1))))) |
|
| (selectq (cadr part2) |
|
| (0 |
|
| (setq line2 (list (car line2)(cadr line2))) |
|
| (setq line3 (list (car line3)(cadr line3)))) |
|
| (1 |
|
| (setq line2 (reverse line2) line3 (reverse line3)) |
|
| (setq line2 (list (car line2)(cadr line2))) |
|
| (setq line3 (list (car line3)(cadr line3))))) |
|
| (vset ret 0 (linecross line0 line2)) |
|
| (vset ret 1 (linecross line0 line3)) |
|
| (vset ret 2 (linecross line1 line2)) |
|
| (vset ret 3 (linecross line1 line3)) |
|
| ret)) |
|
| |
|
| ; |
|
| ; partからpointへの垂線とその他の2点 |
|
| ; |
|
| |
|
| (defun cross2point (part1 point) |
|
| (let ((ret (vector 4)) |
|
| (line0 (caadr (assq 'lines (cddr part1)))) |
|
| (line1 (cadadr (assq 'lines (cddr part1))))) |
|
| (selectq (cadr part1) |
|
| (0 |
|
| (setq line0 (list (car line0)(cadr line0))) |
|
| (setq line1 (list (car line1)(cadr line1)))) |
|
| (1 |
|
| (setq line0 (reverse line0) line1 (reverse line1)) |
|
| (setq line0 (list (car line0)(cadr line0))) |
|
| (setq line1 (list (car line1)(cadr line1))))) |
|
| (lets ((p0 (nearest line0 point)) |
|
| (p1 (nearest line1 point)) |
|
| (l00 (list (float (cadar line0))(float (caddar line0)))) |
|
| (l01 (list (float (cadadr line0))(float (cadr (cdadr line0))))) |
|
| (l10 (list (float (cadar line1))(float (caddar line1)))) |
|
| (l11 (list (float (cadadr line1))(float (cadr (cdadr line1)))))) |
|
| (cond |
|
| ((or (null p0)(null p1)) |
|
| (setq p0 (list (float (car point))(float (cadr point)))) |
|
| (vset ret 0 p0) |
|
| (vset ret 1 p0) |
|
| (vset ret 2 p0) |
|
| (vset ret 3 p0)) |
|
| (t |
|
| (vset ret 0 p0) |
|
| (vset ret 1 p1) |
|
| (vset ret 2 |
|
| (plus2 |
|
| p0 |
|
| (normlen2 (metric2 p0 p1) |
|
| (diff2 l01 l00)))) |
|
| (vset ret 3 |
|
| (plus2 |
|
| p1 |
|
| (normlen2 (metric2 p0 p1) |
|
| (diff2 l11 l10)))))) |
|
| ret))) |
|
| |
|
| ; |
|
| ; もっとも近い点 |
|
| ; |
|
| |
|
| (defun nearest (l0 point) |
|
| (lets ((ax (float (cadr (car l0)))) |
|
| (ay (float (caddr (car l0)))) |
|
| (bx (-$ (float(cadr (cadr l0))) ax)) |
|
| (by (-$ (float(caddr (cadr l0))) ay)) |
|
| (cx (car point)) |
|
| (cy (cadr point))) |
|
| (linecross l0 `((angle ,cx ,cy)(angle ,(+$ cx by),(-$ cy bx)))))) |
|
| |
|
| ; |
|
| ; lineの交点 |
|
| ; |
|
| |
|
| (defun linecross (line0 line1) |
|
| (lets ((l0 nil)(l1 nil)(ll0 nil)(ll1 nil)) |
|
| (cond ((eq 2 (length line0)) |
|
| (setq l0 line0 ll1 line1)) |
|
| (t (setq l0 line1 ll1 line0))) |
|
| (do ((l1 ll1 (cdr l1))) |
|
| ((atom (cdr l1))) |
|
| (lets ((ax (float (cadr (car l0)))) |
|
| (ay (float (caddr (car l0)))) |
|
| (bx (-$ (float(cadr (cadr l0))) ax)) |
|
| (by (-$ (float(caddr (cadr l0))) ay)) |
|
| (cx (float (cadr (car l1)))) |
|
| (cy (float (caddr (car l1)))) |
|
| (dx (-$ (float(cadr (cadr l1))) cx)) |
|
| (dy (-$ (float (caddr (cadr l1))) cy)) |
|
| (mat2 (vector 4 (list bx by (-$ dx)(-$ dy)))) |
|
| (rmat nil) |
|
| (rmat2 nil) |
|
| (s nil)) |
|
| (cond |
|
| ((0=$ (-$ (*$ bx dy)(*$ by dx))) |
|
| (cond ((0=$ (-$ (*$ (-$ cx ax)by)(*$ (-$ cy ay)bx))) |
|
| (exit (list ax ay))))) |
|
| (t |
|
| (setq rmat2 (rmat mat2)) |
|
| (setq s (+$ |
|
| (*$ (vref rmat2 1)(-$ cx ax)) |
|
| (*$ (vref rmat2 3)(-$ cy ay)))) |
|
| (cond ((eq 2 (length l1)) |
|
| (exit(list (+$ cx (*$ s dx))(+$ cy (*$ s dy))))) |
|
| ((and (0<$ s)(<$ s 1.0)) |
|
| (exit(list (+$ cx (*$ s dx))(+$ cy (*$ s dy)))))))))))) |
|
| |
|
| ; |
|
| (defun hex1(x) |
|
| (string (sref "0123456789abcdef" x))) |
|
| ; |
|
| (defun hex2(h) |
|
| (string-append (hex1 (logand 15 (logshift h -4))) |
|
| (hex1 (logand 15 h)))) |
|
| ; |
|
| (defun euc2jis(str) |
|
| (lets ((len (string-length str)) |
|
| (newstr "")) |
|
| (do ((i 0 (1+ i))) |
|
| ((>= i len)newstr) |
|
| (setq newstr (string-append newstr (hex2 (logand 127 (sref str i)))))))) |
|
| ; |
; |
| ; PSファイルの出力 |
; PSファイルの出力 |
| ; |
; |
| (err:undefined-function #'(lambda (x (y))(throw 'err))) |
(err:undefined-function #'(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 |
| (skelton2list (normkanji (rm-limit (applykanji (car ol) tag)) tag))))) |
(skeleton2list (normkanji (rm-limit (applykanji (car ol) tag)) tag))))) |
| (cond |
(cond |
| ((atom l) |
((atom l) |
| (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n") |
(format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n") |
| ) |
) |
| |
|
| ; |
; |
| ; 組み合わせたものを使う |
; アウトライン形式のデータを表示する |
| ; |
; |
| (defun expandkanji (l (fonttype 'mincho)) |
(defun showOutline (outline) |
| (cond ((symbolp l) |
(init_window 400 400) |
| (let ((ll(eval l))) |
(mapcar outline '(lambda (x)(drawlines (setpart1 x)))) |
| (cond ((and (consp ll)(symbolp (car ll))) |
(redraw) |
| (expandkanji ll fonttype)) |
(checkevent) |
| (t l)))) |
(close_window)) |
| ((atom l) l) |
; |
| (t (cond |
; スケルトンデータを renderingして表示する |
| ((eq (car l) 'joint)l) |
|
| ((symbolp (car l)) |
|
| (cond ((get (car l) 'expand) |
|
| (funcall (get (car l) 'expand) fonttype (cdr l))) |
|
| (t (funcall (car l) fonttype (cdr l))))) |
|
| (t (unpackprim l)))))) |
|
| ; |
|
| (defun get-def (symbol fonttype) |
|
| (do ((l fonttype (get l 'parent))(def)) |
|
| ((null l) |
|
| (and (boundp symbol)(eval symbol))) |
|
| (and (setq def (get symbol l))(exit def)))) |
|
| ; |
|
| (defun applykanji (l (tag)) |
|
| ; (prind l) |
|
| (cond ((null l)nil) |
|
| ((symbolp l) |
|
| (applykanji (get-def l tag) tag)) |
|
| ((stringp l) (applykanji (unpackprim l) tag)) |
|
| ((atom l)l) |
|
| (t (cond |
|
| ((eq (car l) 'joint) |
|
| ; (prind l)(flush standard-output) |
|
| (joint tag |
|
| (cadr (second l)) |
|
| (mapcar (cadr (third l)) |
|
| #'(lambda (x) (applykanji x tag))) |
|
| (fourth l))) |
|
| ((symbolp (car l)) |
|
| (funcall (car l) tag (cdr l))) |
|
| (t (unpackprim l)))))) |
|
| ; |
|
| (defun expandall (list (file)) |
|
| (let ((standard-output (cond (file (outopen (stream file))) |
|
| (t standard-output)))) |
|
| (do ((l list (cdr l)) |
|
| (ret)) |
|
| ((atom l)) |
|
| (princ (string-append "; " (car l)) terminal-output)(terpri terminal-output) |
|
| (setq ret nil) |
|
| (let ((err:argument-type #'(lambda (x (y))(throw 'err))) |
|
| (err:number-of-arguments #'(lambda (x (y))(throw 'err))) |
|
| (err:unbound-variable #'(lambda (x (y))(throw 'err))) |
|
| (err:zero-division #'(lambda (x (y))(throw 'err)))) |
|
| (catch 'err |
|
| (setq ret (expandkanji (car l))))) |
|
| (cond ((consp ret) |
|
| (prind `(defjoint ,(car l) ',ret))))))) |
|
| ; |
|
| (defun applycache (l) |
|
| (cond ((null l)nil) |
|
| ((symbolp l) |
|
| (cond ((get l 'joint) |
|
| (applycache (get l 'joint))) |
|
| (t |
|
| (let ((ll(eval l))) |
|
| (cond ((and (consp ll)(symbolp (car ll))) |
|
| (expandkanji ll)) |
|
| (t l)))))) |
|
| ((stringp l) (applycache (unpackprim l))) |
|
| ((atom l)l) |
|
| (t (cond ((symbolp (car l)) |
|
| (apply (car l) (mapcar (cdr l) 'applycache))) |
|
| (t (unpackprim l)))))) |
|
| ; |
|
| (defun clearcache () |
|
| (do ((l (oblist) (cdr l))) |
|
| ((atom l)) |
|
| (remprop (car l) 'prim))) |
|
| ; |
; |
| ; アウトライン形式で表示する |
(defun showSkeleton (skeleton tag) |
| |
(showOutline (skeleton2list skeleton tag))) |
| ; |
; |
| |
; スケルトンデータを折れ線に変換する． |
| |
; |
| |
(defun skeletonToLinesList (skeleton) |
| |
(lets ((points (car skeleton)) |
| |
(lineslist) |
| |
(elements (cadr skeleton)) |
| |
(linkPoints)) |
| |
(mapc elements |
| |
#'(lambda (element) |
| |
(lets ((links (assq 'link (cddr element)))) |
| |
(and links |
| |
(mapc (cdr links) |
| |
#'(lambda (p) (or (memq p linkPoints) |
| |
(push p linkPoints)))))))) |
| |
(mapc elements |
| |
#'(lambda (element) |
| |
(lets ((lines)) |
| |
(mapc (cadr element) |
| |
#'(lambda (p) |
| |
(lets ((point (nth p points)) |
| |
(x (fix (car point))) |
| |
(y (fix (cadr point)))) |
| |
(push `(,x .,y) lines)))) |
| |
(push lines lineslist)))) |
| |
(mapc linkPoints |
| |
#'(lambda (p) (push (makeSquareLines (nth p points)) lineslist))) |
| |
lineslist)) |
| |
; |
| |
; ある点を中心に四角を書く |
| |
; (100.0 100.0) -> |
| |
; ((98 . 98)(98 . 102)(102 . 102)(102 . 98)(98 . 98) |
| |
(defun makeSquareLines (point (d 2)) |
| |
(lets ((x (fix (car point))) |
| |
(y (fix (cadr point)))) |
| |
`((,(- x d).,(- y d)) |
| |
(,(- x d).,(+ y d)) |
| |
(,(+ x d).,(+ y d)) |
| |
(,(+ x d).,(- y d)) |
| |
(,(- x d).,(- y d))))) |
| |
|
| (defun showtest (l tag) |
; |
| (lets ((outline nil)) |
; |
| |
; |
| |
(defun showSkeletonByLines (skeleton) |
| (init_window 400 400) |
(init_window 400 400) |
| (setq outline (skelton2list (applykanji l tag) tag)) |
(mapcar (skeletonToLinesList skeleton) #'drawlines) |
| (mapcar outline '(lambda (x)(drawlines (setpart1 x)))) |
|
| (redraw) |
(redraw) |
| (checkevent) |
(checkevent) |
| (close_window))) |
(close_window)) |
| |
|
| |
|
| |
|
| |
; |
| |
; |
| |
; |
| |
(defun showtest (l tag) |
| |
(showSkeleton (applykanji l tag) tag)) |
| ; |
; |
| (defun showtest1 (l tag) |
(defun showtest1 (l tag) |
| (lets ((outline nil)) |
(lets ((outline nil)) |
| (init_window 400 400) |
(init_window 400 400) |
| (setq outline (makeoutline (skelton2list (applykanji l tag) tag))) |
(setq outline (makeoutline (skeleton2list (applykanji l tag) tag))) |
| (mapcar outline '(lambda (x)(drawlines (setpart1 x)))) |
(mapcar outline '(lambda (x)(drawlines (setpart1 x)))) |
| (redraw) |
(redraw) |
| (checkevent) |
(checkevent) |
| (close_window))) |
(close_window))) |
| ; |
; |
| (defun showtest2 (outline) |
|
| (init_window 400 400) |
|
| (mapcar outline '(lambda (x)(drawlines (setpart1 x)))) |
|
| (redraw) |
|
| (checkevent) |
|
| (close_window)) |
|
| ; |
|
| ; 塗りつぶして表示する |
; 塗りつぶして表示する |
| ; |
; |
| |
|
| (defun filltest (l tag) |
(defun filltest (l tag) |
| (init_window 400 400) |
(init_window 400 400) |
| (mapcar (skelton2list (rm-limit (applykanji l tag)) tag) |
(mapcar (skeleton2list (rm-limit (applykanji l tag)) tag) |
| (function (lambda (x)(fillpolygon (setpart1 x))))) |
(function (lambda (x)(fillpolygon (setpart1 x))))) |
| (redraw) |
(redraw) |
| (checkevent) |
(checkevent) |
Diff of /lisp/disp.l
Parent Directory
| 
Revision Log