View of /skeleton-edit/affinprim.l

Parent Directory

Revision Log

*** empty log message ***

;;-------------;;
;; affinprim.l ;;
;;-------------;;

(progn
  (setq kumiawase-directive 
	(list 'tate12 'tate2 'tate21 'tate3 'tate4 'tate5
	      'yoko12 'yoko2 'yoko21 'yoko3
	      'tare 
	      'nyuutsukuri
	      'kamae
	      'kashira))

  (mapcar kumiawase-directive
	  #'(lambda (kumi)
	      (putprop kumi
		       (intern (string-append "affine-"
					      (string kumi)))
		       'kumiawase-affine-function)))
  (putprop 'tate12 #'affine-tate2 'kumiawase-affine-function)
  (putprop 'tate21 #'affine-tate2 'kumiawase-affine-function)
  (putprop 'yoko12 #'affine-yoko2 'kumiawase-affine-function)
  (putprop 'yoko21 #'affine-yoko2 'kumiawase-affine-function)

  )

(defun affine-translate-points (points vec)
    (let ((a (vref vec 0))
	  (b (vref vec 2))
	  (c (vref vec 1))
	  (d (vref vec 3))
	  (e (vref vec 4))
	  (f (vref vec 5)))
    (mapcar points
	    #'(lambda (p)
		(let* ((x (first p))
		       (y (second p))
		       (info (cddr p)))
		  (cons (plus (times a x) (times b y) e)
			(cons (plus (times c x) (times d y) f)
			      info)))))))

(defun affine-translate-pure-primitive (prim vec)
  (let* ((points (car prim))
	 (etc    (cdr prim)))
    (cons (affine-translate-points points vec) etc)))

(defun pure-primitive-name? (sym)
  (cond ((stringp sym) 
	 t)
	((listp sym)
	 (not (memq (car sym) kumiawase-directive)))
	((and (symbolp sym) (not (boundp sym)))
	 nil)
	(t
	 (setq sym (eval sym))
	 (if (stringp sym) (setq sym (unpackprim sym)))
	 (and (listp sym) (not (memq (car sym) kumiawase-directive))))))

(defun kumiawased-primitive-name? (sym)
  (not (pure-primitive-name? sym)))

(defun get-affine-of-kumiawased-primitive (prim)
  (let* ((kumi  (car prim))
	 (prims (cdr prim))
	 (applyprims (mapcar prims #'applykanji))
	 (vecs  (apply (get kumi 'kumiawase-affine-function) 
		       applyprims))
	 (ret nil))
    (do ((p prims (cdr p))
	 (a applyprims (cdr a))
	 (v vecs  (cdr v)))
	((or (null p) (null v)) ret)
	(setq ret (cons (cons (car p) 
			      (cons (hegemony-of-primitive
				     (car a) (car v))
				    (cons (car a) (car v))))
			ret)))))

(defun draw-kumiawased-primitive-win! (win prim (mincho-gothic 'mincho))
  (let* ((affine-prim (get-affine-of-kumiawased-primitive prim))
	 (prims nil))
    (mapcar affine-prim
	    #'(lambda (p)
		(let ((name (car p))
		      (vec  (cdr p)))
		  (push (affine-translate-pure-primitive (applykanji name) vec)
			prims))))
    (clear-win! win)
    (mapcar prims
	    #'(lambda (p)
		(draw-nikuduked-skeleton-win! win p mincho-gothic)))
    prims))

(defun affine-affine (vec2 vec)
  (let* ((a (vref vec 0))
	 (b (vref vec 2))
	 (c (vref vec 1))
	 (d (vref vec 3))
	 (e (vref vec 4))
	 (f (vref vec 5))
	 (a2 (vref vec2 0))
	 (b2 (vref vec2 2))
	 (c2 (vref vec2 1))
	 (d2 (vref vec2 3))
	 (e2 (vref vec2 4))
	 (f2 (vref vec2 5))
	 
	 (ret (vector 6)))
    
    (vset ret 0 (plus (times a2 a) (times b2 c)))
    (vset ret 2 (plus (times a2 b) (times b2 d)))
    (vset ret 4 (plus (times a2 e) (times b2 f) e2))
    
    (vset ret 1 (plus (times c2 a) (times d2 c)))
    (vset ret 3 (plus (times c2 b) (times d2 d)))
    (vset ret 5 (plus (times c2 e) (times d2 f) f2))
    ret))

(defun resolve-affine (from to)
  (let* ((f1 (car from))  (f2 (cadr from))
	 (t1 (car to))    (t2 (cadr to))

	 (fx1 (toflo (car f1)))   (fy1 (toflo (cadr f1)))
	 (fx2 (toflo (car f2)))   (fy2 (toflo (cadr f2)))

	 (tx1 (toflo (car t1)))   (ty1 (toflo (cadr t1)))
	 (tx2 (toflo (car t2)))   (ty2 (toflo (cadr t2)))

	 (a (quotient (difference tx2 tx1) (difference fx2 fx1)))
	 (d (quotient (difference ty2 ty1) (difference fy2 fy1)))

	 (e (difference tx1 (times a fx1)))
	 (f (difference ty1 (times d fy1)))
	 
	 (ret (vector 6)))
    (vset ret 0 a)
    (vset ret 1 0.0)
    (vset ret 2 0.0)
    (vset ret 3 d)
    (vset ret 4 e)
    (vset ret 5 f)
    ret))