Annotation of /lisp/test/makegothicprim.lAnnotation of /lisp/test/makegothicprim.l
Parent Directory
| 
Revision Log
Revision: 1.1 - (view) (download)
| 1 : | ktanaka | 1.1 | (defun makegprim (primlist fonttype (filename)) |
| 2 : | (lets ((standard-output (cond (filename | ||
| 3 : | (outopen (stream filename))) | ||
| 4 : | (t standard-output)))) | ||
| 5 : | (do ((l primlist (cdr l))) | ||
| 6 : | ((atom l)(and filename (close standard-output))) | ||
| 7 : | (setq tmpprim (changetogprim (eval (car l)))) | ||
| 8 : | (and tmpprim (prind `(defprimitive ,fonttype ,(car l) ',tmpprim)))))) | ||
| 9 : | (defun changetogprim (prim) | ||
| 10 : | (lets ((points (car prim)) | ||
| 11 : | (elements (cadr prim)) | ||
| 12 : | (newelements) | ||
| 13 : | (yokopoints)(flag)) | ||
| 14 : | (do ((l elements (cdr l))(p)) | ||
| 15 : | ((atom l)) | ||
| 16 : | (cond ((eq (caar l) 'yoko) | ||
| 17 : | (setq p (cadar l)) | ||
| 18 : | (push (car p) yokopoints) | ||
| 19 : | (push (cadr p) yokopoints)))) | ||
| 20 : | (do ((l elements (cdr l))(p)(p1)) | ||
| 21 : | ((atom l) | ||
| 22 : | (and flag `(,points ,newelements .,(cddr prim))) | ||
| 23 : | ) | ||
| 24 : | (cond ((memq (caar l) '(tate magaritate)) | ||
| 25 : | (setq p (copy (cadar l))) | ||
| 26 : | (setq p1cdr | ||
| 27 : | (nthcdr (cdr (assq (caar l) '((tate . 1)(magaritate . 2)))) p)) | ||
| 28 : | (setq p1 (car p1cdr)) | ||
| 29 : | (setq rp1 (nth p1 points)) | ||
| 30 : | (setq l1 (assq 'link (cddar l))) | ||
| 31 : | (cond ((null l1)(push (car l) newelements)) | ||
| 32 : | ((memq p1 yokopoints)(push (car l) newelements)) | ||
| 33 : | (t | ||
| 34 : | (setq l2 (filter (cdr l1) | ||
| 35 : | (function (lambda (x)(memq x yokopoints))))) | ||
| 36 : | (do ((ll l2 (cdr ll))) | ||
| 37 : | ((atom ll) | ||
| 38 : | (push (car l) newelements)) | ||
| 39 : | ; (break) | ||
| 40 : | (cond ((lessp (metric2 (nth (car ll) points) | ||
| 41 : | rp1) | ||
| 42 : | 50.0) | ||
| 43 : | (rplaca p1cdr (car ll)) | ||
| 44 : | (setq flag t) | ||
| 45 : | (push `(,(caar l) ,p (link .,(remq (car ll) (cdr l1))).,(cddar l)) newelements) | ||
| 46 : | (exit))))))) | ||
| 47 : | (t | ||
| 48 : | (push (car l) newelements)))))) | ||
| 49 : |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |