[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Tue Dec 12 16:00:47 UTC 2006
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]
More information about the Cells-cvs
mailing list