View of /lisp/test/makegothicprim.l

Parent Directory

Revision Log

Initial revision

(defun makegprim (primlist fonttype (filename))
  (lets ((standard-output (cond (filename 
				 (outopen (stream filename)))
				(t standard-output))))
    (do ((l primlist (cdr l)))
      ((atom l)(and filename (close standard-output)))
      (setq tmpprim (changetogprim (eval (car l))))
      (and tmpprim (prind `(defprimitive ,fonttype ,(car l) ',tmpprim))))))
(defun changetogprim (prim)
  (lets ((points (car prim))
	 (elements (cadr prim))
	 (newelements)
	 (yokopoints)(flag))
    (do ((l elements (cdr l))(p))
      ((atom l))
      (cond ((eq (caar l) 'yoko)
	     (setq p (cadar l))
	     (push (car p) yokopoints)
	     (push (cadr p) yokopoints))))
    (do ((l elements (cdr l))(p)(p1))
      ((atom l)
       (and flag `(,points ,newelements .,(cddr prim)))
       )
      (cond ((memq (caar l) '(tate magaritate))
	     (setq p (copy (cadar l)))
	     (setq p1cdr 
		   (nthcdr (cdr (assq (caar l) '((tate . 1)(magaritate . 2)))) p))
	     (setq p1 (car p1cdr))
	     (setq rp1 (nth p1 points))
	     (setq l1 (assq 'link (cddar l)))
	     (cond ((null l1)(push (car l) newelements))
		   ((memq p1 yokopoints)(push (car l) newelements))
		   (t
		    (setq l2 (filter (cdr l1) 
			       (function (lambda (x)(memq x yokopoints)))))
		    (do ((ll l2 (cdr ll)))
		      ((atom ll)
		       (push (car l) newelements))
;		      (break)
		      (cond ((lessp (metric2 (nth (car ll) points)
					     rp1)
				    50.0)
			     (rplaca p1cdr (car ll))
			     (setq flag t)
			     (push `(,(caar l) ,p (link .,(remq (car ll) (cdr l1))).,(cddar l)) newelements)
			     (exit)))))))
	    (t 
	     (push (car l) newelements))))))