Annotation of /lisp/disp.lAnnotation of /lisp/disp.l
Parent Directory
| 
Revision Log
Revision: 1.5 - (view) (download)
| 1 : | ktanaka | 1.1 | ; X-Windowを扱うためのCの関数をロードする |
| 2 : | ; | ||
| 3 : | ; | ||
| 4 : | ktanaka | 1.2 | ;(code-load '("/home/ktanaka/work/wadalabfont/lisp/window.o") "/usr/X11R6/lib/libX11.so") |
| 5 : | ktanaka | 1.4 | ; (code-load "/usr/X11R6/lib/libX11.so" "/home/ktanaka/work/wadalabfont/lisp/window.o") |
| 6 : | ktanaka | 1.1 | ; |
| 7 : | (declare (err:argument-type err:number-of-arguments err:unbound-variable | ||
| 8 : | err:zero-division err:undefined-function) special) | ||
| 9 : | |||
| 10 : | ; | ||
| 11 : | ; PSファイルの出力 | ||
| 12 : | ; | ||
| 13 : | |||
| 14 : | (comment | ||
| 15 : | (defun out-to-ps-all (outlines tag psfile | ||
| 16 : | (nameflag) | ||
| 17 : | (col 9)(line (fix (times 0.67 col))) | ||
| 18 : | (printfile t)) | ||
| 19 : | (let ((standard-output (outopen (stream psfile))) | ||
| 20 : | (scale (fix (times 160.0 (min (//$ 9.0 (float col)) | ||
| 21 : | (//$ 6.0 (float line)))))) | ||
| 22 : | (ii nil)(jj nil)(page nil)(last nil) | ||
| 23 : | (next nil)(nextnext nil)(x1 nil)(y1 nil)(x2 nil)(y2 nil) | ||
| 24 : | (date (date-time))) | ||
| 25 : | (format "%!/n%%BoundingBox: 45 45 /c /c/n" | ||
| 26 : | (plus 55 (fix (times 0.001 scale (- (* line 500) 100)))) | ||
| 27 : | (plus 55 (fix (times 0.001 scale (- (* col 500) 100))))) | ||
| 28 : | (format "50 50 translate/n0.001 /c mul dup scale/n" scale) | ||
| 29 : | (format "//Helvetica findfont 70 scalefont setfont/n") | ||
| 30 : | (setq ii 0 jj 0 page 1) | ||
| 31 : | (and printfile | ||
| 32 : | (format "0 -70 moveto (/c-/c-/c /c:/c File: /c Page: /c) show/n" | ||
| 33 : | (substring date 0 2) | ||
| 34 : | (substring date 2 4)(substring date 4 6) | ||
| 35 : | (substring date 6 8)(substring date 8 10) | ||
| 36 : | psfile page)) | ||
| 37 : | (do | ||
| 38 : | ((ol outlines (cdr ol)) | ||
| 39 : | (l nil)) | ||
| 40 : | ((atom ol)) | ||
| 41 : | (princ ";" terminal-output) | ||
| 42 : | ; (princ (gccount) terminal-output) | ||
| 43 : | (print (car ol) terminal-output) | ||
| 44 : | (setq l | ||
| 45 : | (let ((err:argument-type #'(lambda (x (y))(throw 'err))) | ||
| 46 : | (err:number-of-arguments #'(lambda (x (y))(throw 'err))) | ||
| 47 : | (err:unbound-variable #'(lambda (x (y))(throw 'err))) | ||
| 48 : | (err:undefined-function #'(lambda (x (y))(throw 'err))) | ||
| 49 : | (err:zero-division #'(lambda (x (y))(throw 'err)))) | ||
| 50 : | (catch 'err | ||
| 51 : | ktanaka | 1.3 | (skeleton2list (normkanji (rm-limit (applykanji (car ol) tag)) tag))))) |
| 52 : | ktanaka | 1.1 | (cond |
| 53 : | ((atom l) | ||
| 54 : | (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n") | ||
| 55 : | (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n") | ||
| 56 : | (cond (nameflag | ||
| 57 : | (format "//Ryumin-Light-Ext-H findfont /c scalefont setfont/n" | ||
| 58 : | (cond ((lessp (string-length (car ol)) 10) 100) | ||
| 59 : | (t | ||
| 60 : | (fix (quotient 800 (string-length (car ol))))))) | ||
| 61 : | (format "0 410 moveto </c> show/n" (euc2jis(car ol))))) | ||
| 62 : | ) | ||
| 63 : | (t | ||
| 64 : | (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n") | ||
| 65 : | (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n") | ||
| 66 : | (cond (nameflag | ||
| 67 : | (format "//Ryumin-Light-Ext-H findfont /c scalefont setfont/n" | ||
| 68 : | (cond ((lessp (string-length (car ol)) 10) 100) | ||
| 69 : | (t | ||
| 70 : | (fix (quotient 800 (string-length (car ol))))))) | ||
| 71 : | (format "0 410 moveto </c> show/n" (euc2jis (car ol))))) | ||
| 72 : | (do ((ll l (cdr ll))) | ||
| 73 : | ((atom ll)) | ||
| 74 : | (setq last (caar ll)) | ||
| 75 : | (format "newpath /c /c moveto/n" (fix (cadr last)) | ||
| 76 : | (- 400 (fix (caddr last)))) | ||
| 77 : | (do ((lll (cdar ll) (cdr lll))) | ||
| 78 : | ((atom lll)) | ||
| 79 : | (match | ||
| 80 : | (car lll) | ||
| 81 : | (('angle x y) | ||
| 82 : | (format "/c /c lineto/n" (fix x) (- 400 (fix y)))) | ||
| 83 : | (('bezier x0 y0) | ||
| 84 : | (setq next (cadr lll)) | ||
| 85 : | (setq nextnext | ||
| 86 : | (cond ((cddr lll)(setq lll (cddr lll))(car lll)) | ||
| 87 : | (t (setq lll (cdr lll))last))) | ||
| 88 : | (setq x1 (cadr next) y1 (caddr next)) | ||
| 89 : | (setq x2 (cadr nextnext) y2 (caddr nextnext)) | ||
| 90 : | (format | ||
| 91 : | "/c /c /c /c /c /c curveto/n" | ||
| 92 : | (fix x0) (- 400 (fix y0)) (fix x1) (- 400 (fix y1)) (fix x2) (- 400 (fix y2)))))) | ||
| 93 : | (format "closepath fill/n")))) | ||
| 94 : | (setq ii (1+ ii)) | ||
| 95 : | (cond ((eq ii col) | ||
| 96 : | (format "500 /c translate/n" (* -500 (1- col))) | ||
| 97 : | (setq ii 0) | ||
| 98 : | (setq jj (1+ jj)) | ||
| 99 : | (cond ((and (eq jj line)(consp (cdr ol))) | ||
| 100 : | (format "showpage/n") | ||
| 101 : | (format "50 50 translate/n") | ||
| 102 : | (format "0.001 /c mul dup scale/n" scale) | ||
| 103 : | (format "//Helvetica findfont 70 scalefont setfont/n") | ||
| 104 : | (setq page (1+ page)) | ||
| 105 : | (and printfile | ||
| 106 : | (format "0 -70 moveto (/c-/c-/c /c:/c File: /c Page: /c) show/n" | ||
| 107 : | (substring date 0 2) | ||
| 108 : | (substring date 2 4)(substring date 4 6) | ||
| 109 : | (substring date 6 8)(substring date 8 10) | ||
| 110 : | psfile page)) | ||
| 111 : | (format "//Ryumin-Light-Ext-H findfont 100 scalefont setfont/n") | ||
| 112 : | (setq jj 0)))) | ||
| 113 : | (t (format "0 500 translate/n")))) | ||
| 114 : | (format "showpage/n"))) | ||
| 115 : | ) | ||
| 116 : | |||
| 117 : | ; | ||
| 118 : | ktanaka | 1.2 | ; アウトライン形式のデータを表示する |
| 119 : | ; | ||
| 120 : | (defun showOutline (outline) | ||
| 121 : | (init_window 400 400) | ||
| 122 : | (mapcar outline '(lambda (x)(drawlines (setpart1 x)))) | ||
| 123 : | (redraw) | ||
| 124 : | (checkevent) | ||
| 125 : | (close_window)) | ||
| 126 : | ; | ||
| 127 : | ; スケルトンデータを renderingして表示する | ||
| 128 : | ; | ||
| 129 : | (defun showSkeleton (skeleton tag) | ||
| 130 : | ktanaka | 1.3 | (showOutline (skeleton2list skeleton tag))) |
| 131 : | ktanaka | 1.2 | ; |
| 132 : | ; スケルトンデータを折れ線に変換する． | ||
| 133 : | ; | ||
| 134 : | (defun skeletonToLinesList (skeleton) | ||
| 135 : | (lets ((points (car skeleton)) | ||
| 136 : | (lineslist) | ||
| 137 : | (elements (cadr skeleton)) | ||
| 138 : | (linkPoints)) | ||
| 139 : | (mapc elements | ||
| 140 : | #'(lambda (element) | ||
| 141 : | (lets ((links (assq 'link (cddr element)))) | ||
| 142 : | (and links | ||
| 143 : | (mapc (cdr links) | ||
| 144 : | #'(lambda (p) (or (memq p linkPoints) | ||
| 145 : | (push p linkPoints)))))))) | ||
| 146 : | (mapc elements | ||
| 147 : | #'(lambda (element) | ||
| 148 : | (lets ((lines)) | ||
| 149 : | (mapc (cadr element) | ||
| 150 : | #'(lambda (p) | ||
| 151 : | (lets ((point (nth p points)) | ||
| 152 : | (x (fix (car point))) | ||
| 153 : | (y (fix (cadr point)))) | ||
| 154 : | (push `(,x .,y) lines)))) | ||
| 155 : | (push lines lineslist)))) | ||
| 156 : | (mapc linkPoints | ||
| 157 : | #'(lambda (p) (push (makeSquareLines (nth p points)) lineslist))) | ||
| 158 : | lineslist)) | ||
| 159 : | ; | ||
| 160 : | ; ある点を中心に四角を書く | ||
| 161 : | ; (100.0 100.0) -> | ||
| 162 : | ; ((98 . 98)(98 . 102)(102 . 102)(102 . 98)(98 . 98) | ||
| 163 : | (defun makeSquareLines (point (d 2)) | ||
| 164 : | (lets ((x (fix (car point))) | ||
| 165 : | (y (fix (cadr point)))) | ||
| 166 : | `((,(- x d).,(- y d)) | ||
| 167 : | (,(- x d).,(+ y d)) | ||
| 168 : | (,(+ x d).,(+ y d)) | ||
| 169 : | (,(+ x d).,(- y d)) | ||
| 170 : | (,(- x d).,(- y d))))) | ||
| 171 : | |||
| 172 : | ktanaka | 1.1 | ; |
| 173 : | ; | ||
| 174 : | ; | ||
| 175 : | ktanaka | 1.2 | (defun showSkeletonByLines (skeleton) |
| 176 : | (init_window 400 400) | ||
| 177 : | (mapcar (skeletonToLinesList skeleton) #'drawlines) | ||
| 178 : | (redraw) | ||
| 179 : | (checkevent) | ||
| 180 : | (close_window)) | ||
| 181 : | |||
| 182 : | ktanaka | 1.1 | |
| 183 : | ktanaka | 1.2 | |
| 184 : | ; | ||
| 185 : | ; | ||
| 186 : | ; | ||
| 187 : | ktanaka | 1.1 | (defun showtest (l tag) |
| 188 : | ktanaka | 1.2 | (showSkeleton (applykanji l tag) tag)) |
| 189 : | ktanaka | 1.1 | ; |
| 190 : | (defun showtest1 (l tag) | ||
| 191 : | (lets ((outline nil)) | ||
| 192 : | (init_window 400 400) | ||
| 193 : | ktanaka | 1.3 | (setq outline (makeoutline (skeleton2list (applykanji l tag) tag))) |
| 194 : | ktanaka | 1.1 | (mapcar outline '(lambda (x)(drawlines (setpart1 x)))) |
| 195 : | (redraw) | ||
| 196 : | (checkevent) | ||
| 197 : | (close_window))) | ||
| 198 : | ; | ||
| 199 : | ; 塗りつぶして表示する | ||
| 200 : | ; | ||
| 201 : | |||
| 202 : | (defun filltest (l tag) | ||
| 203 : | (init_window 400 400) | ||
| 204 : | ktanaka | 1.3 | (mapcar (skeleton2list (rm-limit (applykanji l tag)) tag) |
| 205 : | ktanaka | 1.1 | (function (lambda (x)(fillpolygon (setpart1 x))))) |
| 206 : | (redraw) | ||
| 207 : | (checkevent) | ||
| 208 : | (close_window)) | ||
| 209 : | |||
| 210 : | |||
| 211 : | (defun drawpoints (points) | ||
| 212 : | (init_window 400 400) | ||
| 213 : | (do ((l points (cdr l)) | ||
| 214 : | (ret nil)) | ||
| 215 : | ((atom l)(drawlines ret)(redraw)(checkevent)(close_window)) | ||
| 216 : | (push (cons (fix (caar l))(fix (cadar l))) ret))) | ||
| 217 : | (defun drawbezier (points bezier) | ||
| 218 : | (init_window 400 400) | ||
| 219 : | (drawlines (setpart1 bezier)) | ||
| 220 : | (do ((l points (cdr l)) | ||
| 221 : | (ret nil)) | ||
| 222 : | ((atom l)(drawlines ret)(redraw)(checkevent)(close_window)) | ||
| 223 : | (push (cons (fix (caar l))(fix (cadar l))) ret))) | ||
| 224 : | (defun drawbezier1 (points bezier) | ||
| 225 : | (init_window 400 400) | ||
| 226 : | (do ((l bezier (cdr l)) | ||
| 227 : | (ret nil)) | ||
| 228 : | ((atom l)(drawlines ret)) | ||
| 229 : | (push (cons (fix (cadr (car l)))(fix (caddr (car l)))) ret)) | ||
| 230 : | (do ((l points (cdr l)) | ||
| 231 : | (ret nil)) | ||
| 232 : | ((atom l)(drawlines ret)(redraw)(checkevent)(close_window)) | ||
| 233 : | (push (cons (fix (caar l))(fix (cadar l))) ret))) | ||
| 234 : | ; | ||
| 235 : | ktanaka | 1.4 | (defun jointtest (prim1 prim2 affine type) |
| 236 : | (filltest | ||
| 237 : | (rmlimit (appendpart prim1 | ||
| 238 : | (affinepart prim2 affine))) type)) | ||
| 239 : | (defun rmlimit (x) | ||
| 240 : | (lets ((elements (cadr x))(ret)) | ||
| 241 : | (do ((l elements (cdr l))) | ||
| 242 : | ((atom l)`(,(car x) ,(nreverse ret) .,(cddr x))) | ||
| 243 : | (or (memq (caar l) '(xlimit ylimit))(push (car l) ret))))) | ||
| 244 : | ktanaka | 1.5 | ; |
| 245 : | ; Bezier曲線を直線群で近似する | ||
| 246 : | ; | ||
| 247 : | (defun bez (x0 y0 x1 y1 x2 y2 x3 y3 (dlist)) | ||
| 248 : | (lets ((maxx (max x0 x1 x2 x3)) | ||
| 249 : | (maxy (max y0 y1 y2 y3)) | ||
| 250 : | (minx (min x0 x1 x2 x3)) | ||
| 251 : | (miny (min y0 y1 y2 y3))) | ||
| 252 : | (cond | ||
| 253 : | ((or (lessp (difference maxx minx) 2) | ||
| 254 : | (lessp (difference maxy miny) 2)) | ||
| 255 : | `((,(fix x3) . ,(fix y3)).,dlist)) | ||
| 256 : | (t | ||
| 257 : | (lets ((tempx (times 0.125 (plus x0 (times 3 x1)(times 3 x2) x3))) | ||
| 258 : | (tempy (times 0.125 (plus y0 (times 3 y1)(times 3 y2) y3)))) | ||
| 259 : | (bez tempx tempy | ||
| 260 : | (times (plus x3 x2 x2 x1) 0.25) | ||
| 261 : | (times (plus y3 y2 y2 y1) 0.25) | ||
| 262 : | (times (plus x3 x2) 0.5) | ||
| 263 : | (times (plus y3 y2) 0.5) | ||
| 264 : | x3 y3 | ||
| 265 : | (bez x0 y0 | ||
| 266 : | (times (plus x0 x1) 0.5) | ||
| 267 : | (times (plus y0 y1) 0.5) | ||
| 268 : | (times (plus x0 x1 x1 x2) 0.25) | ||
| 269 : | (times (plus y0 y1 y1 y2) 0.25) | ||
| 270 : | tempx tempy dlist))))))) | ||
| 271 : | ; | ||
| 272 : | ; アウトラインから折れ線への変換を行なう | ||
| 273 : | ; | ||
| 274 : | |||
| 275 : | (defun setpart1 (l) | ||
| 276 : | (and l | ||
| 277 : | (lets ((last (car l)) | ||
| 278 : | (curx (cadr last)) | ||
| 279 : | (cury (caddr last)) | ||
| 280 : | (x0)(y0)(x1)(y1)(x2)(y2) | ||
| 281 : | (ret `((,(fix curx).,(fix cury))))) | ||
| 282 : | (do ((ll (cdr l) (cdr ll))) | ||
| 283 : | ((atom ll)ret) | ||
| 284 : | (match ll | ||
| 285 : | ((('angle x0 y0).next) | ||
| 286 : | (setq ret `((,(fix x0).,(fix y0)).,ret)) | ||
| 287 : | (setq curx x0 cury y0)) | ||
| 288 : | ((('bezier x0 y0)('bezier x1 y1)) | ||
| 289 : | (exit (bez curx cury x0 y0 x1 y1 (cadr last)(caddr last) ret))) | ||
| 290 : | ((('bezier x0 y0)('bezier x1 y1)('angle x2 y2).next) | ||
| 291 : | (setq ret (bez curx cury x0 y0 x1 y1 x2 y2 ret)) | ||
| 292 : | (setq curx x2 cury y2) | ||
| 293 : | (setq ll (cddr ll))) | ||
| 294 : | (any (break) ; 想定しない入力 | ||
| 295 : | )))))) | ||
| 296 : | |||
| 297 : | (defun jointtest (prim1 prim2 affine type) | ||
| 298 : | (filltest | ||
| 299 : | (rmlimit (appendpart prim1 | ||
| 300 : | (affinepart prim2 affine))) type)) |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |