(defelement mincho outline (lets ((points (reverse (cdr (reverse (mapcar points #'(lambda (x) `(,(car x) ,(cadr x)))))))) (npoints (length points)) (cpoints (assq 'curve alist)) (cpoints (and cpoints (cdr cpoints))) ; (dummy (print `(cpoints ,cpoints))) (apoints (do ((i 0 (1+ i))(l cpoints)(ret)) ((>= i npoints)(nreverse ret)) (cond ((and l (equal i (car l))) (setq l (cdr l))) (t (push i ret))))) ; (dummy (print `(apoints ,apoints))) ; (apoints (and apoints (cdr apoints))) ; (apoints (filter apoints #'(lambda (x) (< x npoints)))) ) (cond (apoints (do ((l apoints (cdr l)) (ret `((angle .,(nth (car apoints) points))))) ((atom (cdr l)) (setq ret (append ret (cdr (curve_points (append (nthcdr (car l) points) (take (1+ (car apoints)) points)))))) ; (prind ret) `(,(adjust-points (car points)ret) ((angle .,(car points))(angle .,(car points))))) (setq ret (append ret (cdr (curve_points (take (1+ (- (cadr l) (car l))) (nthcdr (car l) points)))))) ; (prind ret) )) (t (round_points points))))) (defun adjust-points (point points) (do ((i 0 (1+ i))(l points (cdr l))) ((atom l)points) (and (equal (car point) (cadr (car l))) (equal (cadr point)(caddr (car l))) (exit (append l (take i (cdr points))))))) (defun take (n l) (cond ((or (<= n 0)(atom l))nil) (t (cons (car l)(take (1- n) (cdr l)))))) (defun curve_points (points) ; (prind points) (cond ((equal 2 (length points)) `((angle .,(car points))(angle .,(cadr points)))) (t (tenhokan points #'(lambda (x) x))))) (defun round_points (points) (lets ((out1 (tenhokan points #'(lambda (x) x) t))) `(,out1 ((angle .,(car points))(angle .,(car points))))))