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