View of /lisp/test/rev.l
Parent Directory
| 
Revision Log
Revision:
1.1 -
(
download)
(
annotate)
Thu Dec 28 08:54:19 2000 UTC (23 years, 11 months ago) by
ktanaka
Branch point for:
ktanaka, MAIN
Initial revision
(defun hrev (prim)
(do ((l (car prim)(cdr l))(newpoints))
((atom l)
(do ((ll (cadr prim)(cdr ll))(newelements))
((atom ll)
`(,(nreverse newpoints),(nreverse newelements) .,(cddr prim)))
(cond ((eq 'outline (caar ll))
(lets ((points (cadar ll))
(len (length points))
(curve (assq 'curve (cddar ll)))
(curve (cond (curve (cdr curve)))))
(push `(outline ,(reverse points)
(curve .,(reverse (mapcar curve
#'(lambda (x) (- len 1 x))))))
newelements)))
(t (push (car ll) newelements)))))
(push `(,(difference 400 (caar l)).,(cdar l)) newpoints)))
(defun vrev (prim)
(do ((l (car prim)(cdr l))(newpoints))
((atom l)
(do ((ll (cadr prim)(cdr ll))(newelements))
((atom ll)
`(,(nreverse newpoints),(nreverse newelements) .,(cddr prim)))
(cond ((eq 'outline (caar ll))
(lets ((points (cadar ll))
(len (length points))
(curve (assq 'curve (cddar ll)))
(curve (cond (curve (cdr curve)))))
(push `(outline ,(reverse points)
(curve .,(reverse (mapcar curve
#'(lambda (x) (- len 1 x))))))
newelements)))
(t (push (car ll) newelements)))))
(push `(,(caar l) ,(difference 400 (cadar l)).,(cddar l)) newpoints)))