[wadalabfont-kit] / lisp / test / makegothicprim.l  

Annotation 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