Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv11738
Modified Files: Celtk.lisp composites.lisp run.lisp tk-interp.lisp togl.lisp widget.lisp Added Files: CelloTk-test.lisp CelloTk.lpr Celtk3D.lpr cellogears.lisp gears.asd Log Message:
--- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/11/13 05:28:52 1.37 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/12/12 16:00:44 1.38 @@ -16,7 +16,7 @@
|#
-;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.37 2006/11/13 05:28:52 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.38 2006/12/12 16:00:44 ktilton Exp $
(defpackage :celtk (:nicknames "CTK") @@ -53,6 +53,7 @@
(in-package :Celtk)
+ #+(and allegrocl ide (not runtime-system)) (ide::defdefiner defcallback defun)
@@ -111,7 +112,7 @@ ; --- debug stuff --------------------------------- ;
- (let ((yes '("pack")) + (let ((yes '()) (no '("font"))) (declare (ignorable yes no)) (when (and (or ;; (null yes) --- /project/cells/cvsroot/Celtk/composites.lisp 2006/11/13 05:28:52 1.21 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/12/12 16:00:44 1.22 @@ -147,6 +147,7 @@ )
+ (defmethod do-on-key-down :before (self &rest args &aux (keysym (car args))) (trc nil "ctk::do-on-key-down window" keysym (keyboard-modifiers .tkw)) (bwhen (mod (keysym-to-modifier keysym)) --- /project/cells/cvsroot/Celtk/run.lisp 2006/11/13 05:28:52 1.23 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/12/12 16:00:44 1.24 @@ -117,15 +117,17 @@ #+shhh (call-dump-event client-data xe))
(:configurenotify - (setf (^width) (ekx new-width!!! parse-integer (tk-eval "winfo width ."))) + (setf (^width) (parse-integer (tk-eval "winfo width ."))) (with-cc :height (setf (^height) (parse-integer (tk-eval "winfo height .")))) )
(:visibilitynotify - (mathx::a1-snack-off :startup "" 0.8)) + ;;(funcall (find-symbol "A1-SOUND-EFFECT-PLAY" '#:mathx) self :startup "" 0.8) + ) + (:destroyNotify - (mathx::a1-snack-off :quit "-blocking yes" 0.5) + ;(funcall (find-symbol "A1-SOUND-EFFECT-PLAY" '#:mathx) self :quit "-blocking yes" 0.5)
(let ((*windows-destroyed* (cons *tkw* *windows-destroyed*))) (ensure-destruction *tkw*))) --- /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/06/07 22:13:41 1.15 +++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/12/12 16:00:45 1.16 @@ -183,7 +183,10 @@ (defun argv0 () #+allegro (sys:command-line-argument 0) #+lispworks (nth 0 system:*line-arguments-list*) ;; portable to OS X - #+sbcl (nth 0 sb-ext:*posix-argv*)) + #+sbcl (nth 0 sb-ext:*posix-argv*) + #+openmcl (car ccl:*command-line-argument-list*) + #-(or allegro lispworks sbcl openmcl) + (error "argv0 function not implemented for this lisp"))
(defun tk-interp-init-ensure () (unless *initialized* --- /project/cells/cvsroot/Celtk/togl.lisp 2006/11/04 20:53:08 1.23 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/12/12 16:00:46 1.24 @@ -197,8 +197,8 @@ ; ; just comment out these two lines if not using Cello ; - (setf cl-ftgl:*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready - (kt-opengl:kt-opengl-reset) + ;; (setf cl-ftgl:*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready + ;;(kt-opengl:kt-opengl-reset) (setf (togl-ptr self) togl-ptr) ;; this cannot be deferred (setf (togl-ptr-set self) togl-ptr) ;; this gets deferred, which is OK (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self)) --- /project/cells/cvsroot/Celtk/widget.lisp 2006/10/02 02:56:01 1.18 +++ /project/cells/cvsroot/Celtk/widget.lisp 2006/12/12 16:00:46 1.19 @@ -121,10 +121,22 @@ (^path) new-value (^parent-y)))))
(defcallback widget-event-handler-callback :void ((client-data :pointer)(xe :pointer)) + #+demo + (handler-case + (bif (self (tkwin-widget client-data)) + (widget-event-handle self xe) + ;; sometimes I hit the next branch restarting after crash.... + (trc "widget-event-handler > no widget for tkwin ~a" client-data)) + (t (error) + (declare (ignorable error)) + ;;(mathx::a1-sound-play :backtrace) + #-demo (invoke-debugger error) + )) + #-demo (bif (self (tkwin-widget client-data)) - (widget-event-handle self xe) - ;; sometimes I hit the next branch restarting after crash.... - (trc "widget-event-handler > no widget for tkwin ~a" client-data))) + (widget-event-handle self xe) + ;; sometimes I hit the next branch restarting after crash.... + (trc "widget-event-handler > no widget for tkwin ~a" client-data)))
(defmethod widget-event-handle ((self widget) xe) ;; override for class-specific handling (trc nil "bingo widget-event-handle" (xevent-type xe))
--- /project/cells/cvsroot/Celtk/CelloTk-test.lisp 2006/12/12 16:00:47 NONE +++ /project/cells/cvsroot/Celtk/CelloTk-test.lisp 2006/12/12 16:00:47 1.1 #|
This library is meant to be the minimal Tk/Togl reuired to support a Cello application that dpes not use Tk widgets other than the Window, Menus, and Togl.
This library does not have a test function.
To test, look for Celtk3D which pulls in cl-opengl, this project, and the gears demo.
|#--- /project/cells/cvsroot/Celtk/CelloTk.lpr 2006/12/12 16:00:47 NONE +++ /project/cells/cvsroot/Celtk/CelloTk.lpr 2006/12/12 16:00:47 1.1 ;; -*- lisp-version: "8.0 [Windows] (Dec 9, 2006 20:44)"; cg: "1.81"; -*-
(in-package :cg-user)
(defpackage :CELTK)
(define-project :name :celtk :modules (list (make-instance 'module :name "Celtk.lisp") (make-instance 'module :name "tk-structs.lisp") (make-instance 'module :name "tk-interp.lisp") (make-instance 'module :name "tk-events.lisp") (make-instance 'module :name "tk-object.lisp") (make-instance 'module :name "font.lisp") (make-instance 'module :name "widget.lisp") (make-instance 'module :name "layout.lisp") (make-instance 'module :name "timer.lisp") (make-instance 'module :name "menu.lisp") (make-instance 'module :name "composites.lisp") (make-instance 'module :name "frame.lisp") (make-instance 'module :name "fileevent.lisp") (make-instance 'module :name "togl.lisp") (make-instance 'module :name "run.lisp") (make-instance 'module :name "CelloTk-test.lisp")) :projects (list (make-instance 'project-module :name "..\cells\cells") (make-instance 'project-module :name "C:\1-devtools\cffi\cffi")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :celtk :main-form nil :compilation-unit t :verbose nil :runtime-modules '(:cg-dde-utils :cg.base :cg.bitmap-pane :cg.bitmap-pane.clipboard :cg.bitmap-stream :cg.button :cg.caret :cg.check-box :cg.choice-list :cg.choose-printer :cg.clipboard :cg.clipboard-stack :cg.clipboard.pixmap :cg.color-dialog :cg.combo-box :cg.common-control :cg.comtab :cg.cursor-pixmap :cg.curve :cg.dialog-item :cg.directory-dialog :cg.directory-dialog-os :cg.drag-and-drop :cg.drag-and-drop-image :cg.drawable :cg.drawable.clipboard :cg.dropping-outline :cg.edit-in-place :cg.editable-text :cg.file-dialog :cg.fill-texture :cg.find-string-dialog :cg.font-dialog :cg.gesture-emulation :cg.get-pixmap :cg.get-position :cg.graphics-context :cg.grid-widget :cg.grid-widget.drag-and-drop :cg.group-box :cg.header-control :cg.hotspot :cg.html-dialog :cg.html-widget :cg.icon :cg.icon-pixmap :cg.ie :cg.item-list :cg.keyboard-shortcuts :cg.lamp :cg.lettered-menu :cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget :cg.list-view :cg.mci :cg.menu :cg.menu.tooltip :cg.message-dialog :cg.multi-line-editable-text :cg.multi-line-lisp-text :cg.multi-picture-button :cg.multi-picture-button.drag-and-drop :cg.multi-picture-button.tooltip :cg.ocx :cg.os-widget :cg.os-window :cg.outline :cg.outline.drag-and-drop :cg.outline.edit-in-place :cg.palette :cg.paren-matching :cg.picture-widget :cg.picture-widget.palette :cg.pixmap :cg.pixmap-widget :cg.pixmap.file-io :cg.pixmap.printing :cg.pixmap.rotate :cg.printing :cg.progress-indicator :cg.project-window :cg.property :cg.radio-button :cg.rich-edit :cg.rich-edit-pane :cg.rich-edit-pane.clipboard :cg.rich-edit-pane.printing :cg.sample-file-menu :cg.scaling-stream :cg.scroll-bar :cg.scroll-bar-mixin :cg.selected-object :cg.shortcut-menu :cg.static-text :cg.status-bar :cg.string-dialog :cg.tab-control :cg.template-string :cg.text-edit-pane :cg.text-edit-pane.file-io :cg.text-edit-pane.mark :cg.text-or-combo :cg.text-widget :cg.timer :cg.toggling-widget :cg.toolbar :cg.tooltip :cg.trackbar :cg.tray :cg.up-down-control :cg.utility-dialog :cg.web-browser :cg.web-browser.dde :cg.wrap-string :cg.yes-no-list :cg.yes-no-string :dde) :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") :include-flags '(:top-level :debugger) :build-flags '(:allow-runtime-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil :default-command-line-arguments "+M +t "Console for Debugging"" :additional-build-lisp-image-arguments '(:read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard :on-initialization 'celtk::cellogears :on-restart 'do-default-restart)
;; End of Project Definition --- /project/cells/cvsroot/Celtk/Celtk3D.lpr 2006/12/12 16:00:47 NONE +++ /project/cells/cvsroot/Celtk/Celtk3D.lpr 2006/12/12 16:00:47 1.1 ;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*-
(in-package :cg-user)
(defpackage :CELTK)
(define-project :name :celtk3d :modules (list (make-instance 'module :name "cellogears.lisp")) :projects (list (make-instance 'project-module :name "..\cells\cells") (make-instance 'project-module :name "C:\1-devtools\cffi\cffi") (make-instance 'project-module :name "cellotk") (make-instance 'project-module :name "C:\1-devtools\cl-opengl\glu")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :celtk :main-form nil :compilation-unit t :verbose nil :runtime-modules '(:cg-dde-utils :cg.base :cg.bitmap-pane :cg.bitmap-pane.clipboard :cg.bitmap-stream :cg.button :cg.caret :cg.check-box :cg.choice-list :cg.choose-printer :cg.clipboard :cg.clipboard-stack :cg.clipboard.pixmap :cg.color-dialog :cg.combo-box :cg.common-control :cg.comtab :cg.cursor-pixmap :cg.curve :cg.dialog-item :cg.directory-dialog :cg.directory-dialog-os :cg.drag-and-drop :cg.drag-and-drop-image :cg.drawable :cg.drawable.clipboard :cg.dropping-outline :cg.edit-in-place :cg.editable-text :cg.file-dialog :cg.fill-texture :cg.find-string-dialog :cg.font-dialog :cg.gesture-emulation :cg.get-pixmap :cg.get-position :cg.graphics-context :cg.grid-widget :cg.grid-widget.drag-and-drop :cg.group-box :cg.header-control :cg.hotspot :cg.html-dialog :cg.html-widget :cg.icon :cg.icon-pixmap :cg.ie :cg.item-list :cg.keyboard-shortcuts :cg.lamp :cg.lettered-menu :cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget :cg.list-view :cg.mci :cg.menu :cg.menu.tooltip :cg.message-dialog :cg.multi-line-editable-text :cg.multi-line-lisp-text :cg.multi-picture-button :cg.multi-picture-button.drag-and-drop :cg.multi-picture-button.tooltip :cg.ocx :cg.os-widget :cg.os-window :cg.outline :cg.outline.drag-and-drop :cg.outline.edit-in-place :cg.palette :cg.paren-matching :cg.picture-widget :cg.picture-widget.palette :cg.pixmap :cg.pixmap-widget :cg.pixmap.file-io :cg.pixmap.printing :cg.pixmap.rotate :cg.printing :cg.progress-indicator :cg.project-window :cg.property :cg.radio-button :cg.rich-edit :cg.rich-edit-pane :cg.rich-edit-pane.clipboard :cg.rich-edit-pane.printing :cg.sample-file-menu :cg.scaling-stream :cg.scroll-bar :cg.scroll-bar-mixin :cg.selected-object :cg.shortcut-menu :cg.static-text :cg.status-bar :cg.string-dialog :cg.tab-control :cg.template-string :cg.text-edit-pane :cg.text-edit-pane.file-io :cg.text-edit-pane.mark :cg.text-or-combo :cg.text-widget :cg.timer :cg.toggling-widget :cg.toolbar :cg.tooltip :cg.trackbar :cg.tray :cg.up-down-control :cg.utility-dialog :cg.web-browser :cg.web-browser.dde :cg.wrap-string :cg.yes-no-list :cg.yes-no-string :dde) :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") :include-flags '(:top-level :debugger) :build-flags '(:allow-runtime-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil :default-command-line-arguments "+M +t "Console for Debugging"" :additional-build-lisp-image-arguments '(:read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard :on-initialization 'celtk::cellogears :on-restart 'do-default-restart)
;; End of Project Definition --- /project/cells/cvsroot/Celtk/cellogears.lisp 2006/12/12 16:00:47 NONE +++ /project/cells/cvsroot/Celtk/cellogears.lisp 2006/12/12 16:00:47 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; gears.lisp --- Celtk/Togl version of cl-opengl Lisp version of gears.c (GLUT Mesa demos). ;;; ;;; Simple program with rotating 3-D gear wheels.
(in-package :celtk)
(defvar *startx*) (defvar *starty*) (defvar *xangle0*) (defvar *yangle0*) (defvar *xangle*) (defvar *yangle*)
(defparameter *vTime* 100)
(defun cellogears () ;; ACL project manager needs a zero-argument function, in project package (let ((*startx* nil) (*starty* nil) (*xangle0* nil) (*yangle0* nil) (*xangle* 0.2) (*yangle* 0.0)) (test-window 'gears-demo)))
(defmodel gears-demo (window) ((gear-ct :initform (c-in 1) :accessor gear-ct :initarg :gear-ct) (scale :initform (c-in 1) :accessor scale :initarg :scale)) (:default-initargs :title$ "Rotating Gear Widget Test" :kids (c? (the-kids (mk-stack (:packing (c?pack-self "-side left -fill both")) (make-instance 'gears :fm-parent *parent* :width 400 :height 400 :timer-interval (c? (let ((n$ "100")) (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 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)))))))))))
(defun RotStart (self x y) (setf *startx* x) (setf *starty* y) (setf *xangle0* (rotx self)) (setf *yangle0* (roty self)))
(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*) (togl-post-redisplay (togl-ptr self))))
(defconstant +pif+ (coerce pi 'single-float))
(defmodel gears (togl) ((rotx :initform (c-in 40) :accessor rotx :initarg :rotx) (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 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)) (draw-gear 1.0 4.0 1.0 20 0.7)) dl))) (gear2 :initarg :gear2 :accessor gear2 :initform (c_? (let ((dl (gl:gen-lists 1))) (gl:with-new-list (dl :compile) (gl:material :front :ambient-and-diffuse #(0.0 0.8 0.2 1.0)) (draw-gear 0.5 2.0 2.0 10 0.7)) dl))) (gear3 :initarg :gear3 :accessor gear3 :initform (c_? (let ((dl (gl:gen-lists 1))) (gl:with-new-list (dl :compile) (gl:material :front :ambient-and-diffuse #(0.2 0.2 1.0 1.0)) (draw-gear 1.3 2.0 0.5 10 0.7)) dl)))
(angle :initform (c-in 0.0) :accessor angle :initarg :angle) (frame-count :cell nil :initform 0 :accessor frame-count) (t0 :cell nil :initform 0 :accessor t0) ; (width :initarg :wdith :initform 400 :accessor width) (height :initarg :wdith :initform 400 :accessor height)))
(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-post-redisplay (togl-ptr self)) ;(loop until (zerop (ctk::Tcl_DoOneEvent 2))) )
(defmethod togl-create-using-class ((self gears)) (gl:light :light0 :position #(5.0 5.0 10.0 0.0)) (gl:enable :cull-face :lighting :light0 :depth-test) (gl:material :front :ambient-and-diffuse #(0.8 0.1 0.0 1.0)) (gl:enable :normalize) (truc self))
(defmethod togl-reshape-using-class ((self gears)) (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 nil "enter gear reshape" self width (width self)) (gl:viewport 0 (- height (height self)) (width self) (height self)) (unless truly (gl:matrix-mode :projection) (gl:load-identity) (let ((h (/ height width))) (gl:frustum -1 1 (- h) h 5 60))) (progn (gl:matrix-mode :modelview) (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)) (trc nil "display angle" (^rotx)(^roty)(^rotz)) (gl:clear-color 0 0 0 1) (gl:clear :color-buffer-bit :depth-buffer-bit)
(gl:with-pushed-matrix (gl:rotate (^rotx) 1 0 0) (gl:rotate (^roty) 0 1 0) (gl:rotate (^rotz) 0 0 1)
(gl:with-pushed-matrix (gl:translate -3 -2 0) (gl:rotate (^angle) 0 0 1) (gl:call-list (^gear1)))
(gl:with-pushed-matrix (gl:translate 3.1 -2 0) (gl:rotate (- (* -2 (^angle)) 9) 0 0 1) (gl:call-list (^gear2)))
(gl:with-pushed-matrix ; gear3 (gl:translate -3.1 4.2 0.0) (gl:rotate (- (* -2 (^angle)) 25) 0 0 1) (gl:call-list (^gear3))))
(Togl-Swap-Buffers (togl-ptr self))
#+shhh (print-frame-rate self))
(defun draw-gear (inner-radius outer-radius width n-teeth tooth-depth) "Draw a gear." (declare (single-float inner-radius outer-radius width tooth-depth) (fixnum n-teeth)) (let ((r0 inner-radius) (r1 (- outer-radius (/ tooth-depth 2.0))) (r2 (+ outer-radius (/ tooth-depth 2.0))) (da (/ (* 2.0 +pif+) n-teeth 4.0))) (gl:shade-model :flat) (gl:normal 0 0 1) ;; Draw front face. (gl:with-primitives :quad-strip (dotimes (i (1+ n-teeth)) (let ((angle (/ (* i 2.0 +pif+) n-teeth)))
[103 lines skipped] --- /project/cells/cvsroot/Celtk/gears.asd 2006/12/12 16:00:47 NONE +++ /project/cells/cvsroot/Celtk/gears.asd 2006/12/12 16:00:47 1.1
[120 lines skipped]
-
ktilton