[cells-cvs] CVS Celtk

ktilton ktilton at common-lisp.net
Thu May 4 06:11:10 UTC 2006


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

Modified Files:
	CELTK.lpr Celtk.lisp demos.lisp gears.lisp menu.lisp run.lisp 
	tk-interp.lisp tk-object.lisp togl.lisp 
Log Message:
Resurrected Gears Lite -- hopefully last stamp with faux events

--- /project/cells/cvsroot/Celtk/CELTK.lpr	2006/05/02 13:13:00	1.6
+++ /project/cells/cvsroot/Celtk/CELTK.lpr	2006/05/04 06:11:10	1.7
@@ -24,17 +24,18 @@
                  (make-instance 'module :name "item-shaped.lisp")
                  (make-instance 'module :name "composites.lisp")
                  (make-instance 'module :name "frame.lisp")
-                 (make-instance 'module :name "load-cl-opengl.lisp")
                  (make-instance 'module :name "togl.lisp")
                  (make-instance 'module :name "run.lisp")
                  (make-instance 'module :name "demos.lisp")
-                 (make-instance 'module :name "gears.lisp")
                  (make-instance 'module :name
-                                "ltktest-cells-inside.lisp"))
+                                "ltktest-cells-inside.lisp")
+                 (make-instance 'module :name "gears.lisp"))
   :projects (list (make-instance 'project-module :name
                                  "..\\cells\\cells")
                   (make-instance 'project-module :name
-                                 "C:\\0devtools\\cffi\\cffi"))
+                                 "C:\\0devtools\\cffi\\cffi")
+                  (make-instance 'project-module :name
+                                 "C:\\0devtools\\cl-opengl\\glu"))
   :libraries nil
   :distributed-files nil
   :internally-loaded-files nil
--- /project/cells/cvsroot/Celtk/Celtk.lisp	2006/05/03 20:02:36	1.16
+++ /project/cells/cvsroot/Celtk/Celtk.lisp	2006/05/04 06:11:10	1.17
@@ -52,6 +52,8 @@
 
 (in-package :Celtk)
 
+(defvar *tki* nil)
+
 (defparameter *tk-last* nil "Debug aid. Last recorded command send to Tk")
 
 (defparameter *tkw* nil)
--- /project/cells/cvsroot/Celtk/demos.lisp	2006/05/03 08:20:49	1.8
+++ /project/cells/cvsroot/Celtk/demos.lisp	2006/05/04 06:11:10	1.9
@@ -25,7 +25,7 @@
 
 (defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package
   ;;(test-window 'one-button)
-  (test-window 'ltktest-cells-inside)
+  (test-window 'gears-demo)
   )
 
 (defmodel one-button (window)
--- /project/cells/cvsroot/Celtk/gears.lisp	2006/05/03 08:20:49	1.3
+++ /project/cells/cvsroot/Celtk/gears.lisp	2006/05/04 06:11:10	1.4
@@ -1,7 +1,6 @@
 
-(in-package :celtk)
+(in-package :celtk-user)
 
-(in-package :celtk)
 
 (defparameter *startx* nil)
 (defparameter *starty* nil)
@@ -13,8 +12,13 @@
 (defparameter *vTime* 100)
 
 (defun gears () ;; ACL project manager needs a zero-argument function, in project package
-  (test-window 'gears-demo))
-
+  (let ((*startx* nil)
+        (*starty* nil)
+        (*xangle0* nil)
+        (*yangle0* nil)
+        (*xangle* 0.0)
+        (*yangle* 0.0))
+    (test-window 'gears-demo)))
 
 (defmodel gears-demo (window)
   ((gear-ct :initform (c-in 1) :accessor gear-ct :initarg :gear-ct)
@@ -40,35 +44,39 @@
                                                      (md-value (fm-other :vtime)))))
                    :double "yes"
                    :bindings (c? (list
-                                  (list '|<Button-1>|
-                                    (lambda (self event root-x root-y)
-                                      (declare (ignore event))
-                                      (RotStart self root-x root-y))
+                                  (list '|<1>| (lambda (self event root-x root-y) 
+                                                 (declare (ignorable self event root-x root-y))
+                                                 (RotStart self root-x root-y)
+                                                 0)
                                     "%X %Y")
                                   (list '|<B1-Motion>|
                                     (lambda (self event root-x root-y)
                                       (declare (ignore event))
-                                      (RotMove self root-x root-y))
+                                      (with-integrity (:change)
+                                        (RotMove self root-x root-y))
+                                      0)
                                     "%X %Y")))))))))
 
 (defun RotStart (self x y)
+  ;(trc "Rotstart!!!" self x y)
   (setf *startx* x)
   (setf *starty* y)
-  (let ((vPos (tk-eval-list "~a position" (^path)))) ;; this fails for me -- command not recognized, it seems
-    (trc "got vpos" vpos)
-    (setf *xangle0* (read-from-string (nth 0 vpos)))
-    (setf *yangle0* (read-from-string (nth 1 vpos)))))
+  (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*)))
-  (tk-format-now "~a rotate ~a ~a" (^path) *xangle* *yangle*))
+  (setf (rotx self) *xangle*)
+  (setf (roty self) *yangle*))
+
 (defconstant +pif+ (coerce pi 'single-float))
 
 (defmodel gears (togl)
-  ((view-rotx :initform (c-in 20.0) :accessor view-rotx :initarg :view-rotx)
-   (view-roty :initform (c-in 30.0) :accessor view-roty :initarg :view-roty)
-   (view-rotz :initform (c-in 0.0) :accessor view-rotz :initarg :view-rotz)
+  ((rotx :initform (c-in 0.0) :accessor rotx :initarg :rotx)
+   (roty :initform (c-in 0.0) :accessor roty :initarg :roty)
+   (rotz :initform (c-in 0.0) :accessor rotz :initarg :rotz)
    (gear1 :accessor gear1 :initform (c-in nil))
    (gear2 :accessor gear2 :initform (c-in nil))
    (gear3 :accessor gear3 :initform (c-in nil))
@@ -81,32 +89,35 @@
 
 (defmethod togl-timer-using-class ((self gears))
   (trc nil "enter gear timer" self (togl-ptr self) (get-internal-real-time))
-  (incf (^angle) 2.0)
-  (Togl_PostRedisplay (togl-ptr self)))
-
-(defmethod togl-reshape-using-class ((self gears) width height)
-  (trc "enter gear reshape" self width :height (type-of height) :voila height)
-  (gl:viewport 0 0 width height)
-  (gl:matrix-mode :projection)
-  (gl:load-identity)
-  (let ((h (/ height width)))
-    (gl:frustum -1 1 (- h) h 5 60))
-  (gl:matrix-mode :modelview)
-  (gl:load-identity)
-  (gl:translate 0 0 -40))
+  (with-integrity (:change)
+    (incf (^angle) 2.0)
+    (Togl_PostRedisplay (togl-ptr self))))
+
+(defmethod togl-reshape-using-class ((self gears))
+  (let ((width (Togl_width (togl-ptr self)))
+        (height (Togl_height (togl-ptr self))))
+    (trc "enter gear reshape" self width :height (type-of height) :voila height)
+    (gl:viewport 0 0 width height)
+    (gl:matrix-mode :projection)
+    (gl:load-identity)
+    (let ((h (/ height width)))
+      (gl:frustum -1 1 (- h) h 5 60))
+    (gl:matrix-mode :modelview)
+    (gl:load-identity)
+    (gl:translate 0 0 -40)))
 
 (defmethod togl-display-using-class ((self gears) &aux (scale (scale (upper self gears-demo))))
   (declare (ignorable scale))
-  (with-slots (view-rotx view-roty view-rotz angle gear1 gear2 gear3)
+  (with-slots (rotx roty rotz angle gear1 gear2 gear3)
       self
-    (trc nil "in gear display" self (togl-ptr self)gear1 gear2 gear3 scale)
+    
     (gl:clear-color 0 0 0 1)
     (gl:clear :color-buffer-bit :depth-buffer-bit)
     
     (gl:with-pushed-matrix
-      (gl:rotate (incf view-rotx) 1 0 0)
-      (gl:rotate view-roty 0 1 0)
-      (gl:rotate view-rotz 0 0 1)
+      (gl:rotate rotx 1 0 0)
+      (gl:rotate roty 0 1 0)
+      (gl:rotate rotz 0 0 1)
       
       (gl:with-pushed-matrix ; gear1
         (gl:translate -3 -2 0)
@@ -125,21 +136,7 @@
     
     (Togl_SwapBuffers (togl-ptr self))
     
-    (print-frame-rate self)))
-
-(defun print-frame-rate (window)
-  (with-slots (frame-count t0) window
-    (incf frame-count)
-    (let ((time (get-internal-real-time)))
-      (when (= t0 0)
-        (setq t0 time))
-      (when (>= (- time t0) (* 1 internal-time-units-per-second))
-        (let* ((seconds (/ (- time t0) internal-time-units-per-second))
-               (fps (/ frame-count seconds)))
-          (format *terminal-io* "~D frames in ~3,1F seconds = ~6,3F FPS~%"
-                  frame-count seconds fps))
-        (setq t0 time)
-        (setq frame-count 0)))))
+    #+shhh (print-frame-rate self)))
 
 (defmethod togl-create-using-class ((self gears))
   (gl:light :light0 :position #(5.0 5.0 10.0 0.0))
@@ -265,3 +262,18 @@
           (gl:normal (- (cos angle)) (- (sin angle)) 0.0)
           (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* (- width) 0.5))
           (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5)))))))
+
+(defun print-frame-rate (window)
+  (with-slots (frame-count t0) window
+    (incf frame-count)
+    (let ((time (get-internal-real-time)))
+      (when (= t0 0)
+        (setq t0 time))
+      (when (>= (- time t0) (* 5 internal-time-units-per-second))
+        (let* ((seconds (/ (- time t0) internal-time-units-per-second))
+               (fps (/ frame-count seconds)))
+          (declare (ignorable fps))
+          #+shh (format *terminal-io* "~D frames in ~3,1F seconds = ~6,3F FPS~%"
+                  frame-count seconds fps))
+        (setq t0 time)
+        (setq frame-count 0)))))
--- /project/cells/cvsroot/Celtk/menu.lisp	2006/05/03 17:34:58	1.9
+++ /project/cells/cvsroot/Celtk/menu.lisp	2006/05/04 06:11:10	1.10
@@ -79,12 +79,12 @@
 ;;;
 
 (defmodel menu-entry (tk-object)
-  ((index :cell nil :initarg :index :accessor index :initform nil))
+  ((idx :cell nil :initarg :idx :accessor idx :initform nil))
   (:documentation "e.g, New, Open, Save in a File menu"))
 
-(defmethod index :around ((self menu-entry))
+(defmethod idx :around ((self menu-entry))
   (or (call-next-method)
-    (setf (index self)
+    (setf (idx self)
       (block count-to-self
         (let ((i -1)
               (menu (upper self menu)))
@@ -97,15 +97,15 @@
 
 (defmethod make-tk-instance ((self menu-entry))
   "Parent has to do this to get them in the right order"
-  (setf (gethash (path-index self) (dictionary .tkw)) self))
+  (setf (gethash (path-idx self) (dictionary .tkw)) self))
 
 (defmethod parent-path ((self menu-entry))
   (path .parent))
 
-(defmethod path-index ((self menu-entry))
+(defmethod path-idx ((self menu-entry))
   "This method hopefully gets used only internally and not given to Tcl qua thing name, which will not recognize it"
-  (assert (index self))
-  (format nil "~a.~a" (path (upper self menu))(index self)))
+  (assert (idx self))
+  (format nil "~a.~a" (path (upper self menu))(idx self)))
 
 (defun fm-menu-traverse (family fn)
   "Traverse family arbitrarily deep as need to reach all menu-entries
@@ -121,12 +121,12 @@
 
 (defmethod not-to-be :after ((self menu-entry))
   (trc nil "whacking menu-entry" self)
-  (tk-format `(:destroy ,self) "~a delete ~a" (path .parent) (index self)))
+  (tk-format `(:destroy ,self) "~a delete ~a" (path .parent) (idx self)))
 
 (defmethod tk-configure ((self menu-entry) option value)
-  (assert (>= (index self) 0) () "cannot configure menu-entry ~a until instantiated and index decided" self)
+  (assert (>= (idx self) 0) () "cannot configure menu-entry ~a until instantiated and index decided" self)
   (tk-format `(:configure ,self) "~A entryconfigure ~a ~(~a~) ~a"
-    (path (upper self menu)) (index self) option (tk-send-value value)))
+    (path (upper self menu)) (idx self) option (tk-send-value value)))
 
 (deftk menu-entry-separator (menu-entry)
   ()
@@ -143,7 +143,7 @@
   (call-next-method)
   (with-integrity (:client '(:bind nil))
     (when new-value
-      (tk-format-now "bind . <~a> {~a invoke ~a}" new-value (path (upper self menu)) (index self)))))
+      (tk-format-now "bind . <~a> {~a invoke ~a}" new-value (path (upper self menu)) (idx self)))))
 
 
 (deftk menu-entry-cascade (selector family menu-entry-usable)
@@ -172,7 +172,7 @@
   ()
   (:tk-spec command -command)
   (:default-initargs
-      :command (c? (format nil "call-back ~(~a~)" (path-index self)))))
+      :command (c? (format nil "call-back ~(~a~)" (path-idx self)))))
 
 (defmacro mk-menu-entry-command-ex ((&rest menu-command-initargs) lbl callback-body)
   `(mk-menu-entry-command
--- /project/cells/cvsroot/Celtk/run.lisp	2006/05/03 20:02:36	1.5
+++ /project/cells/cvsroot/Celtk/run.lisp	2006/05/04 06:11:10	1.6
@@ -52,14 +52,10 @@
   ;; (tk-format-now "bind . <Escape> {call-back-event %W :type <Escape> :time %t}")
     
   (with-integrity ()
-    (setf *tkw* (make-instance root-class))
-    (bind *tkw* '|<Escape>|
-      (lambda (self &rest args)
-        (trc "better event handler!!!!" self args))
-      ":time %t"))
+    (setf *tkw* (make-instance root-class)))
 
   (tk-format `(:fini) "wm deiconify .")
-    
+  (tk-format-now "bind . <Escape> {destroy .}")
   ;; one or the other of...
   (tcl-do-one-event-loop)
   #+either-or (Tk_MainLoop)
@@ -70,24 +66,29 @@
 
 (defparameter *event-loop-delay* 0.08 "Minimum delay [s] in event loop not to lock out IDE (ACL anyway)")
 
-(defun tcl-do-one-event-loop ()
-  (loop with start-time = (get-internal-real-time)
-        while (and (plusp (tk-get-num-main-windows))
-                (> 10 (floor (- (get-internal-real-time) start-time) internal-time-units-per-second)))
-        do
-        (bif (events (prog1
+(let ((last-check nil)
+      (check-interval (floor internal-time-units-per-second 100)))
+  (defun check-faux-events ()
+    (let ((now (get-internal-real-time)))
+      (when (or (null last-check) (> (- now last-check) check-interval))
+        (setf last-check now)
+        (bwhen (events (prog2 (trc nil "tcl-do-one-event-loop checking for events" (get-internal-real-time))
                          (tk-eval-list "set tk-events")
                        (tk-eval "set tk-events {}")))
-          (progn
-            #+shhh (loop for e in events
-              do (trc "event preview" e))
-            (trc "main windows count =" (tk-get-num-main-windows))
-            (loop for e in events
-              do (setf start-time (get-internal-real-time))
-            (tk-process-event e)))
-          (sleep *event-loop-delay*))
-        (loop until (zerop (Tcl_DoOneEvent 2)))
-        finally (trc "tcl-do-one-event-loop has left the building")))
+          (loop for e in events
+                do (tk-process-event e))))
+      (progn
+        (trc nil "tcl-do-one-event-loop sees no events" (get-internal-real-time))
+        #+iwantmyide (sleep *event-loop-delay*)))))
+
+(defun tcl-do-one-event-loop ()
+  (loop while (plusp (tk-get-num-main-windows))
+      do (check-faux-events)
+        (loop  until (zerop (Tcl_DoOneEvent 2))) ;; 2== TCL_DONT_WAIT
+      finally ;;(tk-eval "exit")
+        (tcl-delete-interp *tki*)
+        (setf *tki* nil)
+        (trc "tcl-do-one-event-loop has left the building")))
 
 (defun tk-process-event (event)
   (destructuring-bind (fn w-name &rest args)
@@ -103,7 +104,7 @@
 
 (defmethod do-on-event (self event-type$ &rest args &aux (event-type (intern event-type$)))
   (assert (symbolp event-type))
-  (trc "on event!!!" self event-type args)
+  (trc nil "on event!!!" self event-type args)
   (bif (ecb (gethash event-type (event-handlers self)))
     (apply ecb self event-type args)
     (progn
--- /project/cells/cvsroot/Celtk/tk-interp.lisp	2006/05/03 20:02:36	1.3
+++ /project/cells/cvsroot/Celtk/tk-interp.lisp	2006/05/04 06:11:10	1.4
@@ -5,7 +5,6 @@
 ;;------------------------------------------------------------------------------
 
 
-(defvar *tki* nil)
 ;;------------------------------------------------------------------------------
 ;; External LIBRARIES
 ;;------------------------------------------------------------------------------
@@ -116,7 +115,7 @@
 
       ;; Togl Initialization
 
-      (Togl_Init interp)            
+      ;;(Togl_Init interp)            
       
       ;; Say hello
 
@@ -143,10 +142,13 @@
     ;; Tcl_CreateInterp
       
     (defcfun ("Tcl_CreateInterp" %Tcl_CreateInterp) :pointer)
-
     (defun Tcl_CreateInterp ()
       (%Tcl_CreateInterp))
 
+    (defcfun ("Tcl_DeleteInterp" tcl-delete-interp)
+        :void
+      (interp        :pointer))
+
     ;; Tcl_EvalFile
 
     (defcfun ("Tcl_EvalFile" %Tcl_EvalFile) tcl-retcode
@@ -335,9 +337,8 @@
     (use-foreign-library Tcl)
     (use-foreign-library Tk)
     (use-foreign-library Togl)
-    (prog1
-      (Tcl_FindExecutable)
-      (set-initialized))))
+    (Tcl_FindExecutable)
+    (set-initialized)))
 
 ;; Send a script to a piven Tcl/Tk interpreter
 
--- /project/cells/cvsroot/Celtk/tk-object.lisp	2006/05/03 08:20:49	1.2
+++ /project/cells/cvsroot/Celtk/tk-object.lisp	2006/05/04 06:11:10	1.3
@@ -35,8 +35,7 @@
   (:documentation "Root class for widgets and (canvas) items"))
 
 (defmethod md-awaken :before ((self tk-object))
-  (progn ;; sorry, some next need more granularity in client queueso no: with-integrity (:client `(:make-tk ,self))
-    (make-tk-instance self)))
+  (make-tk-instance self))
 
 ;;; --- deftk --------------------
 
--- /project/cells/cvsroot/Celtk/togl.lisp	2006/05/02 12:48:05	1.1
+++ /project/cells/cvsroot/Celtk/togl.lisp	2006/05/04 06:11:10	1.2
@@ -28,7 +28,10 @@
 ;;;(defcfun ("Togl_Init" togl-init) tcl-retcode
 ;;;  (interp :pointer))
 
-
+(eval-when (compile load eval)
+  (export '(togl_swapbuffers togl_postredisplay togl-ptr togl-reshape-func
+             togl togl-timer-using-class Togl_PostRedisplay togl-reshape-using-class
+             togl-display-using-class togl_width togl_height togl-create-using-class)))
 
 ;; --- gotta call this bad boy during initialization, I guess any time after we have an interpreter
 ;;
@@ -121,28 +124,20 @@
 
 (defvar *togl*)
 (defvar *togls*)
+
 (def-togl-callback create
     (setf (togl-ptr *togl*) togl)
     (push (cons togl *togl*) *togls*))
 (def-togl-callback display)
-
-#+nah (def-togl-callback reshape)
-(progn (defcfun ("Togl_ReshapeFunc" togl-reshape-func) :void (callback :pointer))
-  (defcallback togl-reshape :void ((togl :pointer))
-    (trc "reshape cb sees" togl)
-    (togl-reshape-using-class (cdr (assoc togl *togls*)) 400 400))
-  (defmethod togl-reshape-using-class :around ((self togl) width height)
-    (trc "reshape-uc cb sees" self width height)
-    (if (cb-reshape self)
-        (funcall (cb-reshape self) self width height)
-      (call-next-method)))
-  (defmethod togl-reshape-using-class ((self togl) width height)
-    (declare (ignore width height))))
-
+(def-togl-callback reshape)
 (def-togl-callback destroy)
-(def-togl-callback timer)
+(def-togl-callback timer
+    (check-faux-events))
 
-(defmethod make-tk-instance :around ((self togl))
-  (let ((*togl* self))
-    (call-next-method))) ;; this leads to "togl <path> [-<config option> <value]*", in turn to togl_create
+(defmethod make-tk-instance ((self togl))
+  (with-integrity (:client `(:make-tk ,self))
+    (let ((*togl* self))
+      (setf (gethash (^path) (dictionary .tkw)) self)
+      (tk-format-now "togl ~a ~{~(~a~) ~a~^ ~}"
+        (path self)(tk-configurations self))))) ;; this leads to "togl <path> [-<config option> <value]*", in turn to togl_create
 




More information about the Cells-cvs mailing list