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
