[cells-cvs] CVS gears

[ktilton]

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