View of /renderer/sym.l

Parent Directory

Revision Log

*** empty log message ***

(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))))))