[cells-cvs] CVS Celtk/gears

[ktilton]

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

Modified Files:
	gears.lisp 
Log Message:
Resurrect under Lispworks

--- /project/cells/cvsroot/Celtk/gears/gears.lisp	2006/05/26 17:50:36	1.1
+++ /project/cells/cvsroot/Celtk/gears/gears.lisp	2006/06/07 22:13:41	1.2
@@ -35,10 +35,10 @@
                (mk-stack (:packing (c?pack-self "-side left -fill both"))
                  (mk-label :text "Click and drag to rotate image")
                  (mk-row ()
-                         (mk-label :text "Spin delay (ms):")
-                         (mk-entry :id :vtime
-                           :md-value (c-in "10"))
-                         (mk-button-ex (" Quit " (tk-eval "destroy ."))))
+                   (mk-label :text "Spin delay (ms):")
+                   (mk-entry :id :vtime
+                     :md-value (c-in "100"))
+                   (mk-button-ex (" Quit " (tk-eval "destroy ."))))
                  (make-instance 'gears
                    :fm-parent *parent*
                    :width 400 :height 400
@@ -46,12 +46,15 @@
                                          (format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0)))))
                    :double 1 ;; "yes"
                    :event-handler (c? (lambda (self xe)
+                                        (trc nil "togl event" (tk-event-type (xsv type xe)))
                                         (case (tk-event-type (xsv type xe))
                                           (:virtualevent
-                                           (trc "canvas virtual" (xsv name xe)))
+                                           (trc nil "canvas virtual" (xsv name xe)))
                                           (:buttonpress
+                                           #+not (RotStart self (xsv x xe) (xsv y xe))
                                            (RotStart self (xsv x-root xe) (xsv y-root xe)))
                                           (:motionnotify
+                                           #+not (RotMove self (xsv x xe) (xsv y xe))
                                            (RotMove self (xsv x-root xe) (xsv y-root xe)))
                                           (:buttonrelease
                                            (setf *startx* nil)))))))))))
@@ -64,10 +67,12 @@
 
 (defun RotMove (self x y)
   (when *startx*
+    (trc nil "rotmove started" x *startx* *xangle0*)
     (setf *xangle* (+ *xangle0* (- x *startx*)))
     (setf *yangle* (+ *yangle0* (- y *starty*)))
     (setf (rotx self) *xangle*)
-    (setf (roty self) *yangle*)))
+    (setf (roty self) *yangle*)
+    (togl-post-redisplay (togl-ptr self))))
 
 (defconstant +pif+ (coerce pi 'single-float))
 
@@ -76,7 +81,7 @@
    (roty :initform (c-in 25) :accessor roty :initarg :roty)
    (rotz :initform (c-in 10) :accessor rotz :initarg :rotz)
    (gear1 :initarg :gear1 :accessor gear1
-     :initform (c_? (trc "making list!!!!! 1")
+     :initform (c_? (trc nil "making list!!!!! 1")
                  (let ((dl (gl:gen-lists 1)))
                    (gl:with-new-list (dl :compile)
                      (gl:material :front :ambient-and-diffuse #(0.8 0.1 0.0 1.0))
@@ -105,7 +110,7 @@
 (defmethod togl-timer-using-class ((self gears))
   (trc nil "enter gear timer" self (togl-ptr self) (get-internal-real-time))
   (incf (^angle) 5.0)
-  (Togl_PostRedisplay (togl-ptr self))
+  (togl-post-redisplay (togl-ptr self))
   ;(loop until (zerop (ctk::Tcl_DoOneEvent 2)))
   )
 
@@ -117,14 +122,14 @@
   (truc self))
 
 (defmethod togl-reshape-using-class ((self gears)) 
-  (trc "reshape")
+  (trc nil "reshape")
   (truc self t)
   )
 
 (defun truc (self &optional truly)
-  (let ((width (Togl_width (togl-ptr self)))
-        (height (Togl_height (togl-ptr self))))
-    (trc "enter gear reshape" self width (width self))
+  (let ((width (Togl-width (togl-ptr self)))
+        (height (Togl-height (togl-ptr self))))
+    (trc nil "enter gear reshape" self width (width self))
     (gl:viewport 0 (- height (height self)) (width self) (height self))
     (unless truly
       (gl:matrix-mode :projection)
@@ -139,7 +144,7 @@
 
 (defmethod togl-display-using-class ((self gears) &aux (scale (scale (upper self gears-demo))))
   (declare (ignorable scale))
-  
+  (trc nil "display angle" (^rotx)(^roty)(^rotz))
   (gl:clear-color 0 0 0 1)
   (gl:clear :color-buffer-bit :depth-buffer-bit)
   
@@ -163,7 +168,7 @@
       (gl:rotate (- (* -2 (^angle)) 25) 0 0 1)
       (gl:call-list (^gear3))))
   
-  (Togl_SwapBuffers (togl-ptr self))
+  (Togl-Swap-Buffers (togl-ptr self))
   
   #+shhh (print-frame-rate self))