Update of /project/cells/cvsroot/gears In directory clnet:/tmp/cvs-serv27612

Modified Files: gears.lisp Log Message: Celtk2 alpha release

--- /project/cells/cvsroot/gears/gears.lisp 2006/05/12 08:33:46 1.1 +++ /project/cells/cvsroot/gears/gears.lisp 2006/05/16 02:53:12 1.2 @@ -47,33 +47,29 @@ :timer-interval (c? (let ((n$ (md-value (fm-other :vtime)))) (format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0))))) :double 1 ;; "yes" - :bindings (c? (list - (list '(ctk::|<1>| "%X %Y") - (lambda (self event root-x root-y) - (declare (ignorable self event root-x root-y)) - (RotStart self root-x root-y) - 0)) - (list '(ctk::|<B1-Motion>| "%X %Y") - (lambda (self event root-x root-y) - (declare (ignore event)) - (RotMove self root-x root-y) - 0)))))))))) + :event-handler (c? (lambda (self xe) + (case (tk-event-type (xsv type xe)) + (:virtualevent + (trc "canvas virtual" (xsv name xe))) + (:buttonpress + (RotStart self (xsv x-root xe) (xsv y-root xe))) + (:motionnotify + (RotMove self (xsv x-root xe) (xsv y-root xe))) + (:buttonrelease + (setf *startx* nil)))))))))))

(defun RotStart (self x y) - ;(trc "Rotstart!!!" self x y) (setf *startx* x) (setf *starty* y) (setf *xangle0* (rotx self)) (setf *yangle0* (roty self)))

(defun RotMove (self x y) - ;(trc "RotMove!!!!" self x y) - (setf *xangle* (+ *xangle0* (- x *startx*))) - (setf *yangle* (+ *yangle0* (- y *starty*))) - (setf (rotx self) *xangle*) - (assert (eql *xangle* (rotx self))) - (setf (roty self) *yangle*) - (trc nil "RotMove x y" *xangle* *yangle*)) + (when *startx* + (setf *xangle* (+ *xangle0* (- x *startx*))) + (setf *yangle* (+ *yangle0* (- y *starty*))) + (setf (rotx self) *xangle*) + (setf (roty self) *yangle*)))

(defconstant +pif+ (coerce pi 'single-float))

@@ -138,6 +134,7 @@ (gl:load-identity) (gl:translate 0 0 -30))))

+ (defmethod togl-display-using-class ((self gears) &aux (scale (scale (upper self gears-demo)))) (declare (ignorable scale))