- cello-cvs@common-lisp.net - mailman3.common-lisp.net

[cello-cvs] CVS cello/cellodemo
by ktilton 03 Jun '06

03 Jun '06

Update of /project/cello/cvsroot/cello/cellodemo In directory clnet:/tmp/cvs-serv8832/cellodemo Modified Files: cellodemo.lisp cellodemo.lpr demo-window.lisp hedron-decoration.lisp hedron-render.lisp light-panel.lisp tutor-geometry.lisp Log Message: Somewhat resurrected; clean compile anyway --- /project/cello/cvsroot/cello/cellodemo/cellodemo.lisp 2006/05/17 16:14:28 1.2 +++ /project/cello/cvsroot/cello/cellodemo/cellodemo.lisp 2006/06/03 12:05:55 1.3 @@ -22,7 +22,6 @@ (in-package :cello) - #+(or) (list (demo-image-subdir "shapers") --- /project/cello/cvsroot/cello/cellodemo/cellodemo.lpr 2006/05/17 16:14:28 1.2 +++ /project/cello/cvsroot/cello/cellodemo/cellodemo.lpr 2006/06/03 12:05:55 1.3 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "7.0 [Windows] (Aug 5, 2005 12:23)"; cg: "1.54.2.17"; -*- +;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- (in-package :cg-user) @@ -10,8 +10,8 @@ (make-instance 'module :name "tutor-geometry.lisp") (make-instance 'module :name "light-panel.lisp") (make-instance 'module :name "hedron-render.lisp") - (make-instance 'module :name "hedron-decoration.lisp") - (make-instance 'module :name "virtual-human.lisp")) + (make-instance 'module :name + "hedron-decoration.lisp")) :projects (list (make-instance 'project-module :name "..\\cello")) :libraries nil :distributed-files nil --- /project/cello/cvsroot/cello/cellodemo/demo-window.lisp 2006/05/17 16:14:28 1.2 +++ /project/cello/cvsroot/cello/cellodemo/demo-window.lisp 2006/06/03 12:05:55 1.3 @@ -20,13 +20,18 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. + (in-package :cello) (defun cello-test () (let ((cells::*c-debug* (get-internal-real-time))) - (run-stylish-demos '(light-panel ft-jpg tu-geo ftgl-test demo-scroller) + (run-stylish-demos '(#+No light-panel + ;;ft-jpg + tu-geo + ;;ftgl-test + #+no demo-scroller) ;;'tu-geo - 'light-panel + 'tu-geo :skin (c? (wand-ensure-typed 'wand-texture (car (md-value (fm-other :texture-picker))))) :focus (c-in nil) @@ -102,7 +107,7 @@ :text-color +green+)) (apply 'run-demos demo-names start-at iargs))) -(defmodel demo-window (sound-manager window) +(defmodel demo-window (sound-manager cello-window) () (:default-initargs :sound `((:open . @@ -322,23 +327,8 @@ :must-find t :skip-tree self)))))) -(defmodel proctor-class (ix-row) - () - (:default-initargs - :kids (c? (the-kids - (mk-part :class (ct-text) - :text-font (make-font-glut-bitmapped - :glut-id glut_bitmap_8_by_13) - :pre-layer (with-layers +red+) - :text$ (c? (string (class-name (md-value .parent))))) - (mk-part :subks (ix-inline) - :orientation :vertical - :kids (c? (loop for subk in (class-direct-subclasses (md-value .parent)) - collecting (mk-part :sub (proctor-class) - :md-value subk)))))))) -(defun proctor () - (mk-part :top (proctor-class) - :md-value (c? (find-class 'standard-object)))) + + (defparameter *starter-font* nil) @@ -353,10 +343,9 @@ ;:inset (mkv2 (uPts 4)(uPts 2)) ;:lr (uin 1) :text$ "Close" - :ct-action (lambda (self event &aux (gw (glutw .w.))) - (declare (ignorable event)) - (trc "whacking" .w. gw) - (glut-destroy-window gw))) + :ct-action (lambda (self event) + (declare (ignorable self event)) + (ctk::tcl-eval-ex ctk::*tki* "{destroy .}"))) (mk-part :neww (ct-button) ;:inset (mkv2 (uPts 4)(uPts 2)) --- /project/cello/cvsroot/cello/cellodemo/hedron-decoration.lisp 2005/07/05 17:00:29 1.1 +++ /project/cello/cvsroot/cello/cellodemo/hedron-decoration.lisp 2006/06/03 12:05:55 1.2 @@ -22,6 +22,7 @@ (in-package :cello) + (defun hedron-options () (mk-part :options (ix-inline) :orientation :vertical --- /project/cello/cvsroot/cello/cellodemo/hedron-render.lisp 2005/07/05 17:00:29 1.1 +++ /project/cello/cvsroot/cello/cellodemo/hedron-render.lisp 2006/06/03 12:05:55 1.2 @@ -20,6 +20,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. + (in-package :cello) (defun glut-solid-cylinder (quadric base-radius top-radius height slices stacks) --- /project/cello/cvsroot/cello/cellodemo/light-panel.lisp 2006/05/17 16:14:28 1.2 +++ /project/cello/cvsroot/cello/cellodemo/light-panel.lisp 2006/06/03 12:05:55 1.3 @@ -20,9 +20,10 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. + (in-package :cello) -(def-c-output rgba-value () +(defobserver rgba-value () (when old-value (fgn-free (rgba-fo old-value)))) --- /project/cello/cvsroot/cello/cellodemo/tutor-geometry.lisp 2005/07/05 17:00:29 1.1 +++ /project/cello/cvsroot/cello/cellodemo/tutor-geometry.lisp 2006/06/03 12:05:55 1.2 @@ -20,6 +20,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. + (in-package :cello) (defun degree-radians (degrees) @@ -63,9 +64,9 @@ :px (c? (/ (l-width .w.) 2)) :py (c? (downs (/ (l-height .w.) 2))) :text$ "Close" - :ct-action (lambda (self event &aux (gw (glutw .w.))) + :ct-action (lambda (self event) (declare (ignorable event)) - (glut-destroy-window gw)))))))) + (ctk::tcl-eval-ex ctk::*tki* "{destroy .}")))))))) \ No newline at end of file

1 0

[cello-cvs] CVS cello
by ktilton 03 Jun '06

03 Jun '06

Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv8832 Modified Files: NeHe-06.lpr application.lisp cello-ftgl.lisp cello.lisp cello.lpr control.lisp ctl-drag.lisp ctl-markbox.lisp ctl-selectable.lisp frame.lisp image.lisp ix-layer-expand.lisp ix-styled.lisp ix-text.lisp mouse-click.lisp nehe-06.lisp nehe-14x.lisp pick.lisp window-callbacks.lisp window-utilities.lisp window.lisp wm-mouse.lisp Log Message: Somewhat resurrected; clean compile anyway --- /project/cello/cvsroot/cello/NeHe-06.lpr 2006/05/27 06:01:38 1.1 +++ /project/cello/cvsroot/cello/NeHe-06.lpr 2006/06/03 12:05:54 1.2 @@ -87,7 +87,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'nehe-06::nehe-06 + :on-initialization 'nehe-06::nehe-14 :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cello/cvsroot/cello/application.lisp 2006/05/17 16:14:27 1.2 +++ /project/cello/cvsroot/cello/application.lisp 2006/06/03 12:05:54 1.3 @@ -30,7 +30,7 @@ (ffx-reset) (cells-reset 'tk-client-queue-handler) (when system-type - (setf *sys* (to-be (make-instance system-type :md-name 'mgsys)))) + (setf *sys* (make-instance system-type :md-name 'mgsys))) (values)) (defmodel mg-system (family) @@ -48,7 +48,7 @@ (sys-time *sys*)) (defmethod initialize-instance :after ((self mg-system) &key) - (setf (mouse self) (cells::make-be 'mouse))) + (setf (mouse self) (cells::make-instance 'mouse))) ;; 2006-06-01 was make-be (defmethod sys-close (other) (declare (ignore other))) --- /project/cello/cvsroot/cello/cello-ftgl.lisp 2006/05/17 16:14:27 1.2 +++ /project/cello/cvsroot/cello/cello-ftgl.lisp 2006/06/03 12:05:54 1.3 @@ -104,11 +104,11 @@ (run-window (make-instance 'ftgl-window) (lambda () ;;; -- not sure how much of this new reset stuff is necessary --- - (cl-opengl-init) + (kt-opengl-init) (cl-ftgl-reset) (cl-ftgl-init)))))) -(defmodel ftgl-window (window) +(defmodel ftgl-window (cello-window) () (:default-initargs :idler nil @@ -144,7 +144,7 @@ (ftgl-test) (defun ftgl-test () - (setq ftgl::*ftgl-dll* nil) + (cl-ftgl-init) (let ((fns (mapcar (lambda (p) (pathname-name p)) (butlast (directory *font-directory-path*) 0))) --- /project/cello/cvsroot/cello/cello.lisp 2006/05/26 22:08:55 1.3 +++ /project/cello/cvsroot/cello/cello.lisp 2006/06/03 12:05:54 1.4 @@ -30,11 +30,14 @@ #:utils-kt #:cells #:ffx - #:cl-opengl + #:kt-opengl #:cl-openal #:cl-ftgl - #:cl-magick - #:celtk) - (:shadowing-import-from #:celtk #:window)) + #:cl-magick)) + +;;; in step one we will just have Celtk playing the part of Freeglut +;;; +;;; #:celtk) +;;; (:shadowing-import-from #:celtk #:window)) (in-package :cello) --- /project/cello/cvsroot/cello/cello.lpr 2006/05/26 22:08:55 1.3 +++ /project/cello/cvsroot/cello/cello.lpr 2006/06/03 12:05:54 1.4 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (May 11, 2006 6:29)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- (in-package :cg-user) @@ -27,7 +27,7 @@ (make-instance 'module :name "focus-utilities.lisp") (make-instance 'module :name "ix-styled.lisp") (make-instance 'module :name "ix-text.lisp") - (make-instance 'module :name "window.lisp") + (make-instance 'module :name "ix-togl.lisp") (make-instance 'module :name "window-callbacks.lisp") (make-instance 'module :name "lighting.lisp") (make-instance 'module :name "ctl-toggle.lisp") @@ -41,17 +41,15 @@ (make-instance 'module :name "pick.lisp") (make-instance 'module :name "ix-render.lisp") (make-instance 'module :name "ix-polygon.lisp") - (make-instance 'module :name "ct-scroll-pane.lisp") - (make-instance 'module :name "ct-scroll-bar.lisp") (make-instance 'module :name "cello-ftgl.lisp") (make-instance 'module :name "cello-magick.lisp") (make-instance 'module :name "cello-openal.lisp")) :projects (list (make-instance 'project-module :name "..\\Celtk\\CELTK") (make-instance 'project-module :name - "hello-cffi\\hello-cffi") + "cffi-extender\\cffi-extender") (make-instance 'project-module :name - "cl-opengl\\cl-opengl") + "kt-opengl\\kt-opengl") (make-instance 'project-module :name "cl-magick\\cl-magick") (make-instance 'project-module :name --- /project/cello/cvsroot/cello/control.lisp 2006/05/17 16:14:27 1.2 +++ /project/cello/cvsroot/cello/control.lisp 2006/06/03 12:05:54 1.3 @@ -31,7 +31,7 @@ (click-repeat-p :initarg :click-repeat-p :initform nil :reader click-repeat-p) (click-repeat-event :initarg :click-repeat-event :accessor click-repeat-event - :initform (c? (break "wire tk") #+not (bwhen (c (^click-evt)) + :initform (c? (bwhen (c (^click-evt)) (let ((age (f-sensitivity :age (0.1) (click-age c )))) (when (> age 0.5) age))))) @@ -58,7 +58,7 @@ (defmethod enabled (other)(assert other) nil) -(defmethod do-keydown ((self control) k event) +(defmethod do-cello-keydown ((self control) k event) (declare (ignorable event)) (when (control-triggered-by self k event) (funcall (ct-action self) self event) @@ -66,7 +66,7 @@ ; ---------------------------------------------------------- -(defmethod do-keydown :around (self key-char event) +(defmethod do-cello-keydown :around (self key-char event) (declare (ignorable key-char)) (typecase self (null) @@ -75,7 +75,7 @@ (otherwise (when (ctl-notify-keydown .parent self key-char event) (unless (call-next-method) - (do-keydown .parent key-char event)))))) + (do-cello-keydown .parent key-char event)))))) (defmethod ctl-notify-keydown (self target key-char click) (ctl-notify-keydown (fm-parent self) target key-char click)) --- /project/cello/cvsroot/cello/ctl-drag.lisp 2006/05/17 16:14:27 1.2 +++ /project/cello/cvsroot/cello/ctl-drag.lisp 2006/06/03 12:05:54 1.3 @@ -62,13 +62,6 @@ (div-safe dv rh))))) (trc "no dragr for ctdrag?" self new-value)))) -;;;(defmethod context-cursor ((self CTDrag) kbdModifiers) -;;; (declare (ignore kbdmodifiers)) -;;; (ecase (dragdirection self) -;;; (:horizontal GLUT_CURSOR_LEFT_RIGHT) -;;; (:vertical GLUT_CURSOR_UP_DOWN) -;;; (:horizontal-vt GLUT_CURSOR_CROSSHAIR))) - (defmodel ct-poly-drag (ct-drag ix-polygon)()) (defmodel tab-bar-tracker () --- /project/cello/cvsroot/cello/ctl-markbox.lisp 2006/05/17 16:14:27 1.2 +++ /project/cello/cvsroot/cello/ctl-markbox.lisp 2006/06/03 12:05:54 1.3 @@ -64,14 +64,6 @@ (gl-vertex3f bl bb 0)(gl-vertex3f br bt 0)) (ogl::glec :f3d))))) -;---------------------------- - -(defmethod context-cursor ((self ct-mark-box) kbd-modifiers) - (declare (ignore kbd-modifiers)) - (if (enabled self) - glut_cursor_crosshair - glut_cursor_destroy)) - ; ----- radios ------------------------------- (defmodel ct-radio-item (ct-toggle) --- /project/cello/cvsroot/cello/ctl-selectable.lisp 2005/05/31 14:39:44 1.1 +++ /project/cello/cvsroot/cello/ctl-selectable.lisp 2006/06/03 12:05:54 1.2 @@ -78,17 +78,6 @@ (member (^md-value) (selection selector)))) :reader selectedp)) (:default-initargs -;;; nah, no image behavior here. put in mixin if desired -;;; :bkg-color (c? (if (^enabled) -;;; (if (^hilited) -;;; +blue+ -;;; (if (^selectedp) -;;; +yellow+ -;;; +white+)) -;;; +lt-gray+)) -;;; :pre-layer (with-layers (:rgba (^bkg-color)) -;;; :fill -;;; +black+) :ct-action (lambda (self event &aux (buttons (evt-buttons event)) --- /project/cello/cvsroot/cello/frame.lisp 2005/05/31 14:39:44 1.1 +++ /project/cello/cvsroot/cello/frame.lisp 2006/06/03 12:05:54 1.2 @@ -169,6 +169,7 @@ (render) (ogl::glec :f3d)))))))) +#| (defclass cone3d (frame-3d)()) (defmethod ix-render-layer ((self cone3d) lbox) @@ -194,4 +195,6 @@ (gl-translatef 0 0 1000) (gl-scalef 1.1 1.1 1.1) (glut-solid-sphere (* 100 r) 9 1) - (ogl::glec :f3d))) \ No newline at end of file + (ogl::glec :f3d))) + +|# \ No newline at end of file --- /project/cello/cvsroot/cello/image.lisp 2006/05/17 16:14:27 1.2 +++ /project/cello/cvsroot/cello/image.lisp 2006/06/03 12:05:54 1.3 @@ -181,14 +181,19 @@ (defmethod ogl-dsp-list-prep progn ((self wand-texture)) (texture-name self)) - +(defmacro uskin () + `(labels ((usk (self) + (when (typep self 'image) + (or (skin self) + (usk .parent))))) + (usk self))) ;------------------------------ (defobserver mouse-over-p () (bwhen (p .parent) (when (typep p 'image) - (with-deference - (setf (mouse-over-p p) new-value))))) + (with-integrity(:change) + (setf (mouse-over-p p) new-value))))) (defmethod ix-selectable ((self image)) nil) --- /project/cello/cvsroot/cello/ix-layer-expand.lisp 2006/05/17 16:14:28 1.2 +++ /project/cello/cvsroot/cello/ix-layer-expand.lisp 2006/06/03 12:05:54 1.3 @@ -186,6 +186,8 @@ (round (hypotenuse (r-width lbox)(r-height lbox)) 2) slices stacks))) +(defun hypotenuse (a b) + (sqrt (+ (* a a)(* b b)))) (defun ogl-vertex-normaling (e xyn x y z) (multiple-value-bind (xn yn zn) --- /project/cello/cvsroot/cello/ix-styled.lisp 2006/05/17 16:14:28 1.2 +++ /project/cello/cvsroot/cello/ix-styled.lisp 2006/06/03 12:05:54 1.3 @@ -109,7 +109,7 @@ (ftgl-extruded (unless (ftgl::ftgl-disp-ready-p font) (setf (ftgl::ftgl-disp-ready-p font) t) - (fgc-set-face-size (ftgl-ensure-ifont font) + (ftgl::fgc-set-face-size (ftgl::ftgl-get-metrics-font font) (ftgl::ftgl-size font) (ftgl::ftgl-target-res font))) (ix-string-width self (display-text$ self))))) ;; ugh. make better. subclass must have display-text$ --- /project/cello/cvsroot/cello/ix-text.lisp 2006/05/17 16:14:28 1.2 +++ /project/cello/cvsroot/cello/ix-text.lisp 2006/06/03 12:05:54 1.3 @@ -77,7 +77,7 @@ (ftgl-extruded (unless (ftgl::ftgl-disp-ready-p font) (setf (ftgl::ftgl-disp-ready-p font) t) - (fgc-set-face-size (ftgl-ensure-ifont font) + (ftgl::fgc-set-face-size (ftgl::ftgl-get-metrics-font font) (ftgl::ftgl-size font) (ftgl::ftgl-target-res font))) (ix-string-width self (^display-text$))))) --- /project/cello/cvsroot/cello/mouse-click.lisp 2006/05/17 16:14:28 1.2 +++ /project/cello/cvsroot/cello/mouse-click.lisp 2006/06/03 12:05:54 1.3 @@ -73,7 +73,7 @@ (unless (control-key-down (evt-buttons (os-event self))) ;; lame debugging enabler; make better (focus-navigate (focus (click-window self)) (clickee self)))) - (to-be self) ;; unnecessary? 2301kt just moved this from after next line + ;;;20060601 (to-be self) ;; unnecessary? 2301kt just moved this from after next line (trc nil "echo click set self clickee" self (clickee self)) (when (clickee self) --- /project/cello/cvsroot/cello/nehe-06.lisp 2006/05/27 06:01:38 1.1 +++ /project/cello/cvsroot/cello/nehe-06.lisp 2006/06/03 12:05:54 1.2 @@ -62,7 +62,7 @@ (defmethod togl-timer-using-class ((self nehe06)) (trc nil "enter nehe-06 timer" self (togl-ptr self) (get-internal-real-time)) - (Togl_PostRedisplay (togl-ptr self)) + (togl-post-redisplay (togl-ptr self)) (if (shoot-me self) (unless (cl-openal::al-source-playing-p (shoot-me self)) (cl-openal::al-source-play (shoot-me self))) @@ -70,8 +70,8 @@ (cl-openal::wav-play-start "/0dev/cello/user/sounds/spinning.wav")))) (defmethod togl-reshape-using-class ((self nehe06)) - (let ((width (Togl_width (togl-ptr self))) - (height (Togl_height (togl-ptr self)))) + (let ((width (togl-width (togl-ptr self))) + (height (togl-height (togl-ptr self)))) (trc "enter nh6 reshape" self width height) (unless (or (zerop width) (zerop height)) @@ -82,6 +82,7 @@ (gl-matrix-mode gl_modelview) (gl-load-identity)))) + (defparameter *jmc-font* (ftgl-make :texture 'sylfaen 48 96 18)) (defmethod togl-display-using-class ((self nehe06)) @@ -160,7 +161,7 @@ ) ) - (Togl_SwapBuffers (togl-ptr self)) + (togl-swap-buffers (togl-ptr self)) #+shhh (print-frame-rate self)) (defmethod togl-create-using-class ((self nehe06)) --- /project/cello/cvsroot/cello/nehe-14x.lisp 2006/05/27 06:01:38 1.1 +++ /project/cello/cvsroot/cello/nehe-14x.lisp 2006/06/03 12:05:54 1.2 @@ -50,11 +50,11 @@ (defmethod togl-timer-using-class ((self nehe14)) (trc nil "enter nehe-14 timer" self (togl-ptr self) (get-internal-real-time)) - (Togl_PostRedisplay (togl-ptr self))) + (togl-post-redisplay (togl-ptr self))) (defmethod togl-reshape-using-class ((self nehe14)) - (let ((width (Togl_width (togl-ptr self))) - (height (Togl_height (togl-ptr self)))) + (let ((width (togl-width (togl-ptr self))) + (height (togl-height (togl-ptr self)))) (trc "reshape" width height) (unless (or (zerop width) (zerop height)) (trc "reshape" width height) @@ -124,7 +124,7 @@ (ftgl-render (test-font :bitmap) "NeHe 14 bitmap") (gl-pop-matrix) - (Togl_SwapBuffers (togl-ptr self)) + (togl-swap-buffers (togl-ptr self)) (incf g_rot 0.4f0)) --- /project/cello/cvsroot/cello/pick.lisp 2006/05/17 16:14:28 1.2 +++ /project/cello/cvsroot/cello/pick.lisp 2006/06/03 12:05:54 1.3 @@ -23,7 +23,7 @@ (defun buffy (y) (cffi:mem-aref *ix-select-buffer* 'gluint) y) -(defun ix-select (pos tolerance &key (select :nearest) (target *tkw*)) +(defun ix-select (pos tolerance &key (select :nearest) (target ctk::*tkw*)) (declare (ignorable select pos tolerance)) (gl-get-integerv gl_viewport *ix-select-r*) --- /project/cello/cvsroot/cello/window-callbacks.lisp 2006/05/17 16:14:28 1.2 +++ /project/cello/cvsroot/cello/window-callbacks.lisp 2006/06/03 12:05:54 1.3 @@ -22,134 +22,38 @@ (in-package :cello) -(defmacro def-window-callback (fn-name args &body body) - `(ff-defun-callable :cdecl :void ,fn-name ,args - (window-callback ',fn-name - (lambda ,(mapcar 'car args) ,@body) - ,@(mapcar 'car args)))) - -(defun window-callback (fn-name callback &rest args) - (declare (ignorable fn-name)) - (with-metrics (nil nil "window-callback" fn-name) - (unless (c-stopped) - ;; - ;; this next bit makes sense because no cell rule evaluation could - ;; depend on something touched during a callback, but then no cell - ;; rule should dynamically encompass a callback, so...why reset - ;; the calculators (dependents) global? it is necessary - ;; because, when an error occurs, error-handling can cause - ;; re-entrance and, if a cell rule was being evaluated, suddenly - ;; the programmer is looking at an error about "too many dependencies" - ;; instead of the original error. there is probably a better way to handle - ;; all this, but for now... 2003-04-05kwt - ;; - (let* (cells::*c-calculators* - (*w* (mg-window-current))) - (if *w* - (prog2 - (setf (redisplayp *w*) nil) - (apply callback args) - (when (redisplayp *w*) - (w-post-redisplay *w*))) - (apply callback args)))))) - -(def-window-callback mgwkey ((k :int)(x :int)(y :int)) - (trc "mgwkey" k x y (glutgetwindow)) - (bwhen (w *w*) - (trc nil "mgwkey" k x y w) - (let ((mods (glut-get-modifiers)) - (tgt (or (focus w) w))) - ;;(print (list :keyboard k mods x y (code-char (logand k #xff)) (focus w))) - (do-keydown tgt - (code-char (logand k #xff)) - (mk-os-event mods (mkv2 x y)))))) - -(def-window-callback mgw-special ((k :int)(x :int)(y :int)) - (trc nil "mgwspecial" k x y (glutgetwindow)) - (bwhen (w *w*) - (trc nil "mgwspecial" k x y w) - (let ((mods (glut-get-modifiers))) - (do-specialkeydown (or (focus w) w) - k - (mk-os-event mods (mkv2 x y)))))) - -(defmethod do-specialkeydown ((w window) k event) - (declare (ignorable k event))) - -(defmethod ix-idle ((w window)) - ;(PRINT `(IDLING ,(now))) - (setf (sys-time *sys*) (now))) - -(def-window-callback mg-glut-idle () - ;; (print 'mg-glut-idle) - (unless (c-stopped) - (bwhen (w (mg-window-current)) - (ix-idle w)))) +(defmethod ctk::togl-display-using-class ((self ix-togl)) + (unless (or *ogl-listing-p* ;; re-entrance happens if a DLL puts up a MessageBox + (c-stopped)) + (with-metrics (nil nil "ctk::togl-display-using-class") + (bif (dl (dsp-list self)) + (progn + (trc nil "window using disp list") + (gl-call-list (dsp-list self))) + (ix-paint self))) + (incf (frame-ct self)))) -(def-window-callback mg-glut-display () +(defmethod ctk::togl-timer-using-class ((self ix-togl)) (unless (or *ogl-listing-p* ;; re-entrance happens if a DLL puts up a MessageBox - (c-stopped) (null *w*)) - (with-metrics (nil nil "mg-glut-display") - (trc nil "mg-glut-display > about to render w " *w* (glutgetwindow)) - (window-display *w*)))) - -(defmethod window-display ((self window)) - - (bif (dl (dsp-list self)) - (progn - (trc nil "window using disp list") - (gl-call-list (dsp-list self))) - (ix-paint self)) - - (glut-swap-buffers) - - (trc nil "window-display > rendered w " self (glutgetwindow)) - (incf (frame-ct self)) - #+(or) (when (display-continuous self) + (c-stopped)) + (with-metrics (nil nil "ctk::togl-display-using-class") + (when (display-continuous self) (trc nil "window-display > continuous specified so posting redisplay" self) - (glut-post-redisplay))) - - -(def-window-callback mg-glut-close () - (trc "bingo close ID" (glut-get-window)) - (when *w* - ;; knowing about a window CLO has forgotten - - (c-assert (fm-includes *sys* *w*)) - (trc "closing ~a" *w*) - (setf (kids *sys*) (remove *w* (kids *sys*))) - (trc nil "closed ~a" *w*))) - -(def-window-callback mg-glut-reshape ((x :int)(y :int)) - (unless (or (null *w*)(zerop x) (zerop y)(self-sizing *w*)) - (trc nil "mg-glut-reshape entry" (mg-window-current t) x y) - (mg-window-reshape *w* x y))) - -(defmethod do-menu-command ((w window) (cmd (eql :menu-file-close))) - (trc "destroying window" w (glutw w)) - (glut-destroy-window (glutw w))) - - + (ctk:togl-post-redisplay (ctk:togl-ptr self)))))) -(defmethod do-keydown ((w window) k event) - (case k - (#\escape (if (shift-key-down (evt-buttons event)) - (break "user break on window ~a" (mg-window-current)) - (progn - (trc "destroying window" (glutgetwindow) :out-of - (mapcar #'glutw (kids *sys*))) - (glut-destroy-window (glutgetwindow)) - (setf (kids *sys*) (remove w (kids *sys*)))))) - )) +(defmethod ctk::do-on-key-down ((self ix-togl) &rest args &aux (keysym (car args))) + (funcall (if (schar keysym 1) 'do-cello-special-keydown 'do-cello-keydown) + (or (focus self) self) + (mk-os-event (kbd-modifiers ctk::.tkw) (mkv2 0 0)))) -(defmethod do-keydown (self k event) +(defmethod do-cello-keydown (self k event) (declare (ignorable self k event))) -(defmethod do-specialkeydown :around (self k event) +(defmethod do-cello-special-keydown :around (self k event) (when self (unless (call-next-method) - (do-specialkeydown .parent k event)))) + (do-cello-special-keydown .parent k event)))) -(defmethod do-specialkeydown (self k event) +(defmethod do-cello-special-keydown (self k event) (declare (ignorable self k event))) --- /project/cello/cvsroot/cello/window-utilities.lisp 2006/05/17 16:14:28 1.2 +++ /project/cello/cvsroot/cello/window-utilities.lisp 2006/06/03 12:05:54 1.3 @@ -41,13 +41,13 @@ (print (list :pxy (cons (px i)(py i)) :lt (lt i) :lb (lb i))) (geo-dump (fm-parent i)))) -(defmethod wm-rbuttondown ((w window) buttons mouse-pos) +(defmethod wm-rbuttondown ((w cello-window) buttons mouse-pos) (declare (ignorable buttons mouse-pos)) (bwhen (i (find-ix-under w mouse-pos)) (trc "mpos ix=" i) (unless (do-right-button i buttons mouse-pos) (cond - ((logtest glut_active_ctrl buttons) (geo-dump i)) + ((control-key-down buttons) (geo-dump i)) (t (print `(inspecting ,i)) ;;(c-stop :inspecting) (inspect i))))) @@ -78,7 +78,7 @@ ; --------------- geometry ------------------------------- -(defmethod g-offset ((ap window) &optional (accum-h 0) (accum-v 0)) +(defmethod g-offset ((self cello-window) &optional (accum-h 0) (accum-v 0)) (mkv2 accum-h accum-v)) (defun point-in-box (pt box) --- /project/cello/cvsroot/cello/window.lisp 2006/05/26 22:08:55 1.3 +++ /project/cello/cvsroot/cello/window.lisp 2006/06/03 12:05:54 1.4 @@ -98,17 +98,65 @@ :tick-count (c-in (os-tickcount)) :clipped t + :event-handler 'cello-window-event-handler )) + + +(defun cello-window-event-handler (self xe) + (TRC "cello-window-event-handler" self (ctk::tk-event-type (ctk::xsv type xe)) ) + (case (ctk::tk-event-type (ctk::xsv type xe)) + (:virtualevent ) + (:KeyPress ) + (:KeyRelease ) + (:ButtonPress ) + (:ButtonRelease ) + (:MotionNotify ) + (:EnterNotify ) + (:LeaveNotify ) + (:FocusIn ) + (:FocusOut ) + (:KeymapNotify ) + (:Expose ) + (:GraphicsExpose ) + (:NoExpose ) + (:VisibilityNotify ) + (:CreateNotify ) + (:DestroyNotify ) + (:UnmapNotify ) + (:MapNotify ) + (:MapRequest ) + (:ReparentNotify ) + (:ConfigureNotify ) + (:ConfigureRequest ) + (:GravityNotify ) + (:ResizeRequest ) + (:CirculateNotify ) + (:CirculateRequest ) + (:PropertyNotify ) + (:SelectionClear ) + (:SelectionRequest ) + (:SelectionNotify ) + (:ColormapNotify ) + (:ClientMessage ) + (:MappingNotify ) + (:ActivateNotify ) + (:DeactivateNotify ) + (:MouseWheelEvent))) + (defobserver lights () (dolist (light new-value) (to-be light))) -(defmethod ogl-node-window ((self window)) +(defmethod ogl-dsp-list-prep progn ((self cello-window)) + (glutw self)) + +(defmethod ogl-node-window ((self cello-window)) self) -(defmethod ogl-shared-resource-tender ((self window)) +(defmethod ogl-shared-resource-tender ((self cello-window)) self) + (defun window-menus-basic () (list (list "File" @@ -123,22 +171,67 @@ (cons "Paste" :menu-edit-paste) (cons "Delete" :menu-edit-delete)))) -(defmethod ctl-notify-mouse-click ((self window) clickee click) +(defmethod ctl-notify-mouse-click ((self cello-window) clickee click) (declare (ignore clickee click)) t) -(defmethod ctl-notify-keydown ((self window) target key-char event) +(defmethod ctl-notify-keydown ((self cello-window) target key-char event) (declare (ignore target event key-char)) t) -(defmethod set-doubleclick? ((self window) click) +(defmethod set-doubleclick? ((self cello-window) click) (setf (double-click? self) click)) (defmethod context-cursor (other kbd-modifiers) (if (and other (fm-parent other)) (context-cursor (fm-parent other) kbd-modifiers) - glut_cursor_left_arrow)) + (cello-cursor :arrow))) +(defun cello-cursor (cursor-id) + (ecase cursor-id + (:crosshair #+celtk 'crosshair #+glut GLUT_CURSOR_CROSSHAIR) + (:arrow #+celtk 'arrow #+glut GLUT_CURSOR_LEFT_ARROW) + (:i-beam #+celtk 'ibeam #+glut (break)) + (:watch #+celtk 'watch #+glut (break)))) + + +;; tk native cursors mac and win32: watch xterm + +(defobserver glut-lbox () + (when (self-sizing self) ;; we drive os window + (with-glutw (self) + (let ((w (log2scr (l-width self))) + (h (log2scr (l-height self)))) + (gl-viewport 0 0 w h) + (trc "reshaping window #" self (glut-get-window) w h) + (glut-reshape-window w h))))) + +(defun buttons-shifted (buttons) + #+glut (logtest buttons glut_active_shift) + (find :shift-key buttons) + ) + +(defun shift-key-down (buttons) + #+glut (logtest buttons glut_active_shift) + (find :shift-key buttons) + ) + + +(defun control-key-down (buttons) + #+glut (logtest buttons glut_active_ctrl) + (find :control-key buttons)) + +(defun alt-key-down (buttons) + #+glut (logtest buttons glut_active_alt) + (find :alt-key buttons)) + +(defun control-shift-key-down (buttons) + (and (shift-key-down buttons) + (control-key-down buttons))) + +(defun shift-key-only? (buttons) + #+glut (eql glut_active_shift buttons) + (equal '(:shift-key) buttons)) ;------------------------------------------ @@ -180,6 +273,97 @@ (defparameter *mgw-near* 1500) (defparameter *mgw-far* -1500) +(define-symbol-macro .kg + (progn + (c-stop :user) + (glut-leave-main-loop))) + +(defmethod glutw-create ((self cello-window)) + (when *gw* (c-break "gwcre-renetered")) + (let ((*gw* t)) + #-darwin + (glut-set-option glut_action_on_window_close glut_action_glutmainloop_returns) + (glut-init-display-mode (+ glut_rgb glut_double)) + + (let ((glutw (bif (w (upper self cello-window)) + (progn + (glut-init-window-position + (log2scr (v2-h (glut-xy self))) + (log2scr (v2-v (glut-xy self)))) + + (apply 'glut-init-window-size + (if (self-sizing self) + (list 100 100) + (list (log2scr (l-width self)) + (log2scr (l-height self))))) + + (apply #'glut-create-sub-window (glutw w) + (v2-h (glut-xy self)) (v2-v (glut-xy self)) + (if (self-sizing self) + (list 100 100) + (list (log2scr (l-width self)) + (log2scr (l-height self)))))) + (progn + (if (self-sizing self) + (glut-init-window-size 100 100) + (glut-init-window-size (log2scr (l-width self)) + (log2scr (l-height self)))) + + (let ((key (or (title$ self) "Untitled"))) + (uffi:with-cstring (key-native key) + (glut-create-window key-native))))))) + + (setf (gl-name self) glutw) + + (trc nil "glutw-create setting gl-name" self :to (gl-name self) :glutw glutw + :glut-get-w (glut-get-window)) + + (cello-gl-init) ;; clear errors + + #+profile (macrolet ((glm (param num) + (declare (ignore num)) + `(trc ,(symbol-name param) (ogl-get-int ,param)))) + (glm gl_max_list_nesting 0) + (glm gl_max_eval_order #X0000) + (glm gl_max_lights #x3377 ) + (glm gl_max_clip_planes #x3378 ) + (glm gl_max_texture_size #x3379 ) + (glm gl_max_pixel_map_table #x3380 ) + (glm gl_max_attrib_stack_depth #x3381 ) + (glm gl_max_model-view_stack_depth #x3382 ) + (glm gl_max_name_stack_depth #x3383 ) + (glm gl_max_projection_stack_depth #x3384 ) + (glm gl_max_texture_stack_depth #x3385 ) + (glm gl_max_viewport_dims #x3386 ) + ) + + (trc "glutw-create'd window XY" (glut-get-window) self :from (glut-xy self) :to + (list (glut-get glut_window_x)(glut-get glut_window_y) + (glut-get glut_window_width)(glut-get glut_window_height))) + + + (gl-disable +gl-texture-2d+) + (gl-shade-model gl_smooth) ;; Enable Smooth Shading + (gl-clear-depth 1.0f0) ;; Depth Buffer Setup + (gl-enable gl_depth_test) ;; Enables Depth Testing + (gl-depth-func gl_lequal) ;; The Type Of Depth Testing To Do + (gl-hint gl_perspective_correction_hint gl_nicest) + + ;(gl-enable gl_cull_face) + ;(gl-cull-face gl_back) + + (glut-callbacks-set + :idle (idler self) + :keyboard 'mgwkey + :special 'mgw-special + :close 'mg-glut-close + :display 'mg-glut-display + :mouse 'mg-mouse-callback + :passive-motion 'mg-passive-motion-callback + :motion 'mg-motion-callback + :reshape 'mg-glut-reshape) + (trc "just created glutw" glutw) + glutw))) (defun cello-gl-init (&aux (ct 0)) (trc nil "clearing gl errors....") @@ -190,8 +374,36 @@ #+lispworks (return-from cello-gl-init)) (trc "clearing gl error" e))) -(defmethod ix-selectable ((self window)) t) +(defmethod ix-selectable ((self cello-window)) t) +(defun w-post-redisplay (self) + (when (slot-value self 'glutw) ;; not until ready, and use backdoor else reenter creation + (let ((w (glut-get-window)) + (gw (glutw self))) + (trc nil "w-post-redisplay sees old w" w gw) + (c-assert gw) + (glut-set-window gw) + (count-it :post-redisplay) + (trc nil "posting redisplay" self (glutw self) :currentw w) + (glut-post-redisplay) + (c-assert w) + (glut-set-window w)))) + +(defun mg-window-current (&optional must-find-p) + (unless (c-stopped) + (let ((gw (glut-get-window))) + (if (zerop gw) + (when must-find-p + (c-break "cannot find current window")) + (or (find gw (kids *sys*) :key 'glutw) + (catch 'mg-window-current + (fm-traverse *sys* (lambda (node) + (when (and (typep node 'window) + (eql gw (glutw node))) + (throw 'mg-window-current node))) + :skip-tree nil)) + (when must-find-p + (c-break "no mgw matches glutw ~d" gw))))))) (defmethod mg-window-reshape (self width height) (trc nil "mg-window-reshape" self width height) @@ -208,8 +420,15 @@ (setf (lr self) (+ (ll self) (scr2log width))) (setf (lb self) (- (lt self) (scr2log height)))) +(defun run-window (new-window-class &optional run-init-func) + (assert (symbolp new-window)) + (when run-init-func + (funcall run-init-func)) + (ctk::run-window new-window-class)) + + #+save -(defmethod ix-paint :around ((self window)) +(defmethod ix-paint :around ((self cello-window)) (flet ((projection () (gl-matrix-mode gl_projection) (gl-load-identity) --- /project/cello/cvsroot/cello/wm-mouse.lisp 2006/05/17 16:14:28 1.2 +++ /project/cello/cvsroot/cello/wm-mouse.lisp 2006/06/03 12:05:54 1.3 @@ -22,22 +22,6 @@ (in-package :cello) - -;-------------------- resize window --------------------------- -; - - -;;;(defparameter *resizers* nil) - - -(defmethod wm-lbuttondown ((w window) buttons mouse-pos) - (trc nil "WM_LBUTTONDOWN " buttons mouse-pos) - (setf (mouse-pos w) mouse-pos) ; trigger mouseImage recalc - (setf (mouse-down-evt w) (make-os-event - :modifiers buttons - :where mouse-pos - :realtime (now)))) - (defmethod do-click :around (self os-event) (declare (ignorable os-event)) (when self @@ -59,10 +43,6 @@ where realtime) -(defun now () - (/ (get-internal-real-time) - internal-time-units-per-second)) - (defun mk-os-event (modifiers where) (make-os-event :modifiers modifiers :where where @@ -86,85 +66,15 @@ (declare (optimize (speed 3) (safety 0) (debug 0))) (v2-v (evt-where os-event))) -(defmethod wm-lbuttonup ((w window) modifiers mouse-pos) +(defmethod wm-lbuttonup ((w cello-window) modifiers mouse-pos) (with-metrics (nil nil "win:WM_LBUTTONUP " w modifiers mouse-pos) - (setf (mouse-up-evt w) (make-os-event - :modifiers modifiers - :where mouse-pos - :realtime (now))))) + (setf (mouse-up-evt w) (mk-os-event modifiers mouse-pos)))) (defparameter *mouse-move-occupado* nil "Vestigial? Under CG/Win32 mouse move could be received during mouse move") (defparameter *mouse-where* nil) -(def-window-callback mg-motion-callback ((x :int)(y :int)) - (let ((w (mg-window-current t)) - (where (mkv2 (scr2log x) - (scr2log (- y))))) - (setf *mouse-where* where) - (trc nil "motion callback" w x y where *mouse-move-occupado*) - (unless (and *mouse-move-occupado* - (mouse-pos w)) - (let ((*mouse-move-occupado* t) - #+(or) (mtr (zerop (mod (get-internal-real-time) 10)))) - (c-assert where) - (with-metrics (nil nil () "Setf mousepos") - (trc nil "setting mouse pos" where (mod (get-internal-real-time) - (* 10 internal-time-units-per-second))) - (setf (mouse-pos w) where) - (glutpostredisplay) - ))))) - - -(def-window-callback mg-passive-motion-callback ((x :int)(y :int)) - (let ((w (mg-window-current t))) - (let ((where (mkv2 (scr2log x) - (scr2log (- y))))) - (setf *mouse-where* where) - (trc nil "passive motion callback" w x y where *mouse-move-occupado*) - (unless (and *mouse-move-occupado* - (mouse-pos w)) - (let ((*mouse-move-occupado* t) - (mtr nil #+(or) (zerop (mod (get-internal-real-time) 10)))) - (declare (ignorable mtr)) - (c-assert where) - (with-metrics (nil nil () "Setf mousepos") - ;;(ix-select nil (mkv2 10 10)) - (setf (mouse-pos w) where))))))) - - -(def-window-callback mg-mouse-callback ((button :int)(up-or-down :int)(x :int)(y :int)) - (trc nil "mouse callback entry" button up-or-down x y) - (let ((w (mg-window-current t)) - (mp (mkv2 (scr2log x) - (scr2log (- y)))) - (modifiers (glut-get-modifiers))) - (trc nil "mg-mouse-callback" w button x y) - (cond - ((eql button glut_left_button) - (setf (leftb (mouse *sys*)) (if (eql up-or-down glut_down) :down :up)) - (funcall (if (eql up-or-down glut_down) - #'wm-lbuttondown #'wm-lbuttonup) - w modifiers mp)) - - ((eql button glut_middle_button) - (setf (middleb (mouse *sys*)) (if (eql up-or-down glut_down) :down :up))) - - ((eql button glut_right_button) - (setf (rightb (mouse *sys*)) (if (eql up-or-down glut_down) :down :up)) - (when (eql up-or-down glut_up) - (wm-rbuttondown w modifiers mp))) - - ((eql button glut_mouse_wheel_click) - (trc "mouse wheel click>" button up-or-down x y)) - - ((eql button glut_mouse_wheel_back) - (trc "mouse wheel back>" button up-or-down x y)) - - ((eql button glut_mouse_wheel_fwd) - (trc "mouse wheel>" button up-or-down x y)) - (t (trc "unhandled button" (list button up-or-down x y))))))

1 0

[cello-cvs] CVS cello/kt-opengl
by ktilton 27 May '06

27 May '06

Update of /project/cello/cvsroot/cello/kt-opengl In directory clnet:/tmp/cvs-serv7090/kt-opengl Added Files: cl-opengl-config-2.lisp cl-opengl-config.lisp gears.lisp gl-constants.lisp gl-def.lisp gl-functions.lisp glu-functions.lisp kt-opengl.asd kt-opengl.lisp kt-opengl.lpr move-to-gl.lisp ogl-macros.lisp ogl-utils.lisp Log Message: --- /project/cello/cvsroot/cello/kt-opengl/cl-opengl-config-2.lisp 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/cl-opengl-config-2.lisp 2006/05/27 06:01:39 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*- ;;; ;;; Copyright © 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (in-package :kt-opengl) (defparameter *gl-dynamic-lib* (make-pathname ;;#+lispworks :host #-lispworks :device "c" :directory '(:absolute "windows" "system32") :name "opengl32" :type "dll")) (defparameter *glu-dynamic-lib* (make-pathname ;;#+lispworks :host #-lispworks :device "c" :directory '(:absolute "windows" "system32") :name "glu32" :type "dll")) (defun kt-opengl-load () (declare (ignorable load-oglfont-p)) (unless *opengl-dll* (print "loading open GL/GLU") (ffx:load-foreign-library (namestring *gl-dynamic-lib*)) ; :module "open-gl") ;; -lispworks#-lispworks (setf *opengl-dll* (ffx:load-foreign-library (namestring *glu-dynamic-lib*))))) (eval-when (load eval) (kt-opengl-load)) --- /project/cello/cvsroot/cello/kt-opengl/cl-opengl-config.lisp 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/cl-opengl-config.lisp 2006/05/27 06:01:39 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*- ;;; ;;; Copyright © 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (in-package :kt-opengl) --- /project/cello/cvsroot/cello/kt-opengl/gears.lisp 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/gears.lisp 2006/05/27 06:01:39 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. (defpackage :gears (:use :common-lisp :utils-kt :cells :celtk)) (in-package :gears) (defvar *startx*) (defvar *starty*) (defvar *xangle0*) (defvar *yangle0*) (defvar *xangle*) (defvar *yangle*) (defparameter *vTime* 100) (defun gears () ;; 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")) (mk-label :text "Click and drag to rotate image") (mk-row () (mk-label :text "Spin delay (ms):") (mk-entry :id :vtime :md-value (c-in "10")) (mk-button-ex (" Quit " (tk-eval "destroy .")))) (make-instance 'gears :fm-parent *parent* :width 400 :height 400 :timer-interval (c? (let ((n$ (md-value (fm-other :vtime)))) (format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0))))) :double 1 ;; "yes" :event-handler (c? (lambda (self xe) (case (tk-event-type (xsv type xe)) (:virtualevent (trc "canvas virtual" (xsv name xe))) (:buttonpress (RotStart self (xsv x-root xe) (xsv y-root xe))) (:motionnotify (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* (setf *xangle* (+ *xangle0* (- x *startx*))) (setf *yangle* (+ *yangle0* (- y *starty*))) (setf (rotx self) *xangle*) (setf (roty self) *yangle*))) (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 "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_PostRedisplay (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 "reshape") (truc self t) ) (defun truc (self &optional truly) (let ((width (Togl_width (togl-ptr self))) (height (Togl_height (togl-ptr self)))) (trc "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)) (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_SwapBuffers (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))) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5)) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5)) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5)) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5))))) ;; Draw front sides of teeth. (gl:with-primitives :quads (dotimes (i n-teeth) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5)) (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5)) (gl:vertex (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width 0.5)) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5))))) (gl:normal 0 0 -1) ;; Draw back face. (gl:with-primitives :quad-strip (dotimes (i (1+ n-teeth)) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5)) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5)) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width -0.5)) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5))))) ;; Draw back sides of teeth. (gl:with-primitives :quads (dotimes (i n-teeth) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* (- width) 0.5)) (gl:vertex (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* (- width) 0.5)) (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* (- width) 0.5)) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* (- width) 0.5))))) ;; Draw outward faces of teeth. (gl:with-primitives :quad-strip (dotimes (i n-teeth) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5)) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* (- width) 0.5)) (let* ((u (- (* r2 (cos (+ angle da))) (* r1 (cos angle)))) (v (- (* r2 (sin (+ angle da))) (* r1 (sin angle)))) (len (sqrt (+ (* u u) (* v v))))) (setq u (/ u len)) (setq v (/ u len)) (gl:normal v (- u) 0.0) (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5)) (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* (- width) 0.5)) (gl:normal (cos angle) (sin angle) 0.0) (gl:vertex (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width 0.5)) (gl:vertex (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* (- width) 0.5)) (setq u (- (* r1 (cos (+ angle (* 3 da)))) (* r2 (cos (+ angle (* 2 da)))))) (setq v (- (* r1 (sin (+ angle (* 3 da)))) (* r2 (sin (+ angle (* 2 da)))))) (gl:normal v (- u) 0.0) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5)) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* (- width) 0.5)) (gl:normal (cos angle) (sin angle) 0.0)))) (gl:vertex (* r1 (cos 0)) (* r1 (sin 0)) (* width 0.5)) (gl:vertex (* r1 (cos 0)) (* r1 (sin 0)) (* (- width) 0.5))) ;; Draw inside radius cylinder. (gl:shade-model :smooth) (gl:with-primitives :quad-strip (dotimes (i (1+ n-teeth)) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (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/cello/cvsroot/cello/kt-opengl/gl-constants.lisp 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/gl-constants.lisp 2006/05/27 06:01:39 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: kt-opengl; -*- ;;; ;;; Copyright © 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (in-package #:kt-opengl) #| blendingfactordest |# (dfc gl_zero 0) (dfc gl_one 1) (dfc gl_src_color #x0300) (dfc gl_one_minus_src_color #x0301) (dfc gl_src_alpha #x0302) (dfc gl_one_minus_src_alpha #x0303) (dfc gl_dst_alpha #x0304) (dfc gl_one_minus_dst_alpha #x0305) (dfc gl_dst_color #x0306) (dfc gl_one_minus_dst_color #x0307) (dfc gl_src_alpha_saturate #x0308) #| pixelcopytype |# (dfc gl_color #x1800) (dfc gl_depth #x1801) [463 lines skipped] --- /project/cello/cvsroot/cello/kt-opengl/gl-def.lisp 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/gl-def.lisp 2006/05/27 06:01:39 1.1 [525 lines skipped] --- /project/cello/cvsroot/cello/kt-opengl/gl-functions.lisp 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/gl-functions.lisp 2006/05/27 06:01:39 1.1 [906 lines skipped] --- /project/cello/cvsroot/cello/kt-opengl/glu-functions.lisp 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/glu-functions.lisp 2006/05/27 06:01:39 1.1 [1138 lines skipped] --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl.asd 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.asd 2006/05/27 06:01:39 1.1 [1163 lines skipped] --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lisp 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lisp 2006/05/27 06:01:39 1.1 [1280 lines skipped] --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lpr 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lpr 2006/05/27 06:01:39 1.1 [1320 lines skipped] --- /project/cello/cvsroot/cello/kt-opengl/move-to-gl.lisp 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/move-to-gl.lisp 2006/05/27 06:01:39 1.1 [1411 lines skipped] --- /project/cello/cvsroot/cello/kt-opengl/ogl-macros.lisp 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/ogl-macros.lisp 2006/05/27 06:01:39 1.1 [1561 lines skipped] --- /project/cello/cvsroot/cello/kt-opengl/ogl-utils.lisp 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/ogl-utils.lisp 2006/05/27 06:01:39 1.1 [1809 lines skipped]

1 0

[cello-cvs] CVS cello
by ktilton 27 May '06

27 May '06

Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv7090 Added Files: NeHe-06.lpr nehe-06.lisp nehe-14x.lisp Log Message: --- /project/cello/cvsroot/cello/NeHe-06.lpr 2006/05/27 06:01:38 NONE +++ /project/cello/cvsroot/cello/NeHe-06.lpr 2006/05/27 06:01:38 1.1 ;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- (in-package :cg-user) (defpackage :NEHE-06) (define-project :name :nehe-06 :modules (list (make-instance 'module :name "nehe-06.lisp") (make-instance 'module :name "nehe-14x.lisp")) :projects (list (make-instance 'project-module :name "..\\Celtk\\CELTK") (make-instance 'project-module :name "cffi-extender\\cffi-extender") (make-instance 'project-module :name "kt-opengl\\kt-opengl") (make-instance 'project-module :name "cl-magick\\cl-magick") (make-instance 'project-module :name "cl-ftgl\\cl-ftgl") (make-instance 'project-module :name "cl-openal\\cl-openal")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :nehe-06 :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 'nehe-06::nehe-06 :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cello/cvsroot/cello/nehe-06.lisp 2006/05/27 06:01:38 NONE +++ /project/cello/cvsroot/cello/nehe-06.lisp 2006/05/27 06:01:38 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; nehe-06.lisp --- Celtk/Togl version of cl-opengl Lisp version of ;;; nehe lesson 06 spinning cube with texture ;;; (defpackage :nehe-06 (:use :common-lisp :utils-kt :cells :celtk :kt-opengl :cl-magick )) (in-package :nehe-06) (defvar *startx*) (defvar *starty*) (defvar *xangle0*) (defvar *yangle0*) (defvar *xangle*) (defvar *yangle*) (defparameter *vTime* 100) (defparameter *grace* nil) (defconstant wcx 640) ;; Window Width (defconstant wcy 480) ;; Window Height (defparameter xrot 0.0f0) (defparameter yrot 0.0f0) (defparameter zrot 0.0f0) (defparameter *skin6* nil) (defun nehe-06 () ;; ACL project manager needs a zero-argument function, in project package (setf ogl::*gl-begun* nil) (test-window 'nehe-06-demo)) (defmodel nehe-06-demo (window) () (:default-initargs :title$ "Rotating nehe-06 Widget Test" :kids (c? (the-kids (mk-stack (:packing (c?pack-self)) (make-instance 'nehe06 :fm-parent *parent* :width 400 :height 400 :timer-interval 2 #+later (c? (let ((n$ (md-value (fm-other :vtime)))) (format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0))))) :double 1 ;; "yes" )))))) (defconstant +pif+ (coerce pi 'single-float)) (defmodel nehe06 (togl) ((shoot-me :cell nil :initform nil :accessor shoot-me) (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)) (:default-initargs :cb-destroy (lambda (self) (bwhen (s (shoot-me self)) (trc "stopping source" s) (cl-openal::al-source-stop s))))) (defmethod togl-timer-using-class ((self nehe06)) (trc nil "enter nehe-06 timer" self (togl-ptr self) (get-internal-real-time)) (Togl_PostRedisplay (togl-ptr self)) (if (shoot-me self) (unless (cl-openal::al-source-playing-p (shoot-me self)) (cl-openal::al-source-play (shoot-me self))) (setf (shoot-me self) (cl-openal::wav-play-start "/0dev/cello/user/sounds/spinning.wav")))) (defmethod togl-reshape-using-class ((self nehe06)) (let ((width (Togl_width (togl-ptr self))) (height (Togl_height (togl-ptr self)))) (trc "enter nh6 reshape" self width height) (unless (or (zerop width) (zerop height)) (gl-viewport 0 0 width height) (gl-matrix-mode gl_projection) (gl-load-identity) (glu-perspective 45 (/ width height) 0.1 100) (gl-matrix-mode gl_modelview) (gl-load-identity)))) (defparameter *jmc-font* (ftgl-make :texture 'sylfaen 48 96 18)) (defmethod togl-display-using-class ((self nehe06)) (gl-load-identity) (gl-clear (+ gl_color_buffer_bit gl_depth_buffer_bit)) (gl-line-width 1) (gl-color3f 1f0 1f0 1f0) (gl-translatef 0 0 -5) (gl-enable gl_texture_2d) ;-------------------------------------------- (progn ;; (gl-translatef 0 0 -5) (let ((f 0.2)) (gl-rotatef (incf xrot (* f 3)) 1 0 0) (gl-rotatef (incf yrot (* f 2)) 0 1 0) (gl-rotatef (incf zrot (* f 4)) 0 0 1)) (wand-texture-activate *skin6*) (flet ((v3f (x y z) (let ((scale 1)) (gl-vertex3f (* scale x)(* scale y)(* scale z))))) (with-gl-begun (gl_quads) ;; Front Face (gl-tex-coord2f 0 1)(v3f 1 -1 1) (gl-tex-coord2f 0 0)(v3f 1 1 1) (gl-tex-coord2f 1 0)(v3f -1 1 1) (gl-tex-coord2f 1 1)(v3f -1 -1 1) ;;; (gl-tex-coord2f 1 0)(v3f 1 -1 1) ;;; (gl-tex-coord2f 1 1)(v3f 1 1 1) ;;; (gl-tex-coord2f 0 1)(v3f -1 1 1) ;;; (gl-tex-coord2f 0 0)(v3f -1 -1 1) ;; Back Face (gl-tex-coord2f 1 0) (v3f -1 -1 -1) (gl-tex-coord2f 1 1) (v3f -1 1 -1) (gl-tex-coord2f 0 1) (v3f 1 1 -1) (gl-tex-coord2f 0 0) (v3f 1 -1 -1) ;;; Top Face (gl-tex-coord2f 0 1) (v3f -1 1 -1) (gl-tex-coord2f 0 0) (v3f -1 1 1) (gl-tex-coord2f 1 0) (v3f 1 1 1) (gl-tex-coord2f 1 1) (v3f 1 1 -1) ;;; Bottom Face (gl-tex-coord2f 1 1) (v3f -1 -1 -1) (gl-tex-coord2f 0 1) (v3f 1 -1 -1) (gl-tex-coord2f 0 0) (v3f 1 -1 1) (gl-tex-coord2f 1 0) (v3f -1 -1 1) ;;; Right face (gl-tex-coord2f 1 0) (v3f 1 -1 -1) (gl-tex-coord2f 1 1) (v3f 1 1 -1) (gl-tex-coord2f 0 1) (v3f 1 1 1) (gl-tex-coord2f 0 0) (v3f 1 -1 1) ;;; Left Face (gl-tex-coord2f 0 0) (v3f -1 -1 -1) (gl-tex-coord2f 1 0) (v3f -1 -1 1) (gl-tex-coord2f 1 1) (v3f -1 1 1) (gl-tex-coord2f 0 1) (v3f -1 1 -1) )) #+ifuwanttoseepixmap (wand-render *grace* 0 0 1 -1) (progn (gl-scalef 0.006 0.006 0.0) (gl-disable gl_lighting) (gl-translatef -250 -300 -100) (gl-enable gl_texture_2d) (loop repeat 4 do (ftgl-render *jmc-font* "Dr. John McCarthy") (gl-rotatef 90 0 0 1)) (gl-translatef 100 200 100) ) ) (Togl_SwapBuffers (togl-ptr self)) #+shhh (print-frame-rate self)) (defmethod togl-create-using-class ((self nehe06)) (gl-enable gl_texture_2d) (gl-shade-model gl_smooth) (gl-clear-color 0 0 0 1) (gl-clear-depth 1) (gl-enable gl_depth_test) (gl-depth-func gl_lequal) (gl-hint gl_perspective_correction_hint gl_nicest) (setf *skin6* (mgk:wand-ensure-typed 'wand-texture (test-image "jmcbw512" "jpg"))) (setf *grace* (mgk:wand-ensure-typed 'wand-pixels (test-image "turing" "gif")))) (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))))) (defun test-image (filename filetype) (make-pathname :directory '(:absolute "0dev" "user" "graphics" "shapers") :name (string filename) :type (string filetype))) --- /project/cello/cvsroot/cello/nehe-14x.lisp 2006/05/27 06:01:38 NONE +++ /project/cello/cvsroot/cello/nehe-14x.lisp 2006/05/27 06:01:38 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; nehe-14.lisp --- Celtk/Togl version of ;;; nehe lesson 14 spinning text string ;;; (defpackage :nehe-06 (:use :common-lisp :utils-kt :cells :celtk :kt-opengl :cl-ftgl)) (in-package :nehe-06) (defparameter g_rot 0.0f0) (defvar *frames*) (defvar *start*) (defvar *test-fonts*) (defun test-font (mode) (cdr (assoc mode *test-fonts*))) #+test (nehe-14) (defun nehe-14 () ;; ACL project manager needs a zero-argument function, in project package (setf ogl::*gl-begun* nil) (setq *test-fonts* (mapcar (lambda (mode) (cons mode (ftgl-make mode *gui-style-default-face* 48 96 18))) '(:texture :pixmap :bitmap :outline :polygon :extruded))) (test-window 'nehe-14-demo)) (defmodel nehe-14-demo (window) () (:default-initargs :title$ "NeHe's OpenGL Framework" :kids (c? (the-kids (mk-stack (:packing (c?pack-self)) (make-instance 'nehe14 :fm-parent *parent* :width 400 :height 400 :timer-interval 1 #+later (c? (let ((n$ (md-value (fm-other :vtime)))) (format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0))))) :double 1 ;; "yes" )))))) (defmodel nehe14 (togl) ((frame-count :cell nil :initform 0 :accessor frame-count) (t0 :cell nil :initform 0 :accessor t0) ; (width :initarg :wdith :initform 640 :accessor width) (height :initarg :wdith :initform 400 :accessor height))) (defmethod togl-timer-using-class ((self nehe14)) (trc nil "enter nehe-14 timer" self (togl-ptr self) (get-internal-real-time)) (Togl_PostRedisplay (togl-ptr self))) (defmethod togl-reshape-using-class ((self nehe14)) (let ((width (Togl_width (togl-ptr self))) (height (Togl_height (togl-ptr self)))) (trc "reshape" width height) (unless (or (zerop width) (zerop height)) (trc "reshape" width height) (gl-viewport 0 0 width height) (gl-matrix-mode gl_projection) (gl-load-identity) (glu-perspective 70 1 1 1000) (glu-look-at 0d0 0d0 5d0 0d0 0d0 0d0 0d0 1d0 0d0) (gl-matrix-mode gl_modelview) (gl-load-identity) (gl-clear-depth 1d0)))) (defmethod togl-display-using-class ((self nehe14)) (incf *frames*) (gl-load-identity) ;; Reset The Current Modelview Matrix (gl-clear-color 0 0 0 1) (gl-clear (+ gl_color_buffer_bit gl_depth_buffer_bit)) (gl-translatef 0.0f0 0.0f0 2.0f0) ;; Move Into The Screen ;; Pulsing Colors Based On The Rotation (gl-color3f (* 1.0f0 (cos (/ g_rot 20.0f0))) (* 1.0f0 (sin (/ g_rot 25.0f0))) (- 1.0f0 (* 0.5f0 (cos (/ g_rot 17.0f0))))) (gl-scalef 0.006 0.006 0.0) (gl-disable gl_lighting) (gl-translatef -100 -200 0) (gl-enable gl_texture_2d) (ftgl-render (test-font :texture) (format nil "texture ~d" (floor (/ *frames* (max 1 (- (now) *start*)))))) (gl-translatef 100 200 0) (gl-translatef -100 200 0) (gl-line-width 3) (ftgl-render (test-font :outline) "un-rotated outline") (gl-translatef 100 -200 0) (gl-translatef -200 100 0) (ftgl-render (test-font :polygon) "un-rotated polygon") (gl-translatef 200 -100 0) (with-matrix () (gl-polygon-mode gl_front_and_back gl_line) (gl-rotatef g_rot 1.0f0 0.5f0 0.0f0) (gl-scalef 4 4 4) (gl-translatef -70 -20 0) (ftgl-render (test-font :extruded) "NeHe") (gl-polygon-mode gl_front_and_back gl_fill) ) [103 lines skipped]

1 0

[cello-cvs] CVS cello/cl-openal
by ktilton 27 May '06

27 May '06

Update of /project/cello/cvsroot/cello/cl-openal In directory clnet:/tmp/cvs-serv7090/cl-openal Modified Files: cl-openal-config.lisp cl-openal-demo.lisp cl-openal-init.lisp cl-openal.lisp cl-openal.lpr wav-handling.lisp Log Message: --- /project/cello/cvsroot/cello/cl-openal/cl-openal-config.lisp 2006/05/17 16:14:29 1.1 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal-config.lisp 2006/05/27 06:01:38 1.2 @@ -32,10 +32,10 @@ :type "dll")) (defparameter *alut-dynamic-lib* - (make-pathname :directory '(:absolute "0dvx" "user" "dynlib") + (make-pathname :directory '(:absolute "0dev" "user" "dynlib") :name "alut" :type "dll")) (defparameter *audio-files* (make-pathname - :directory '(:absolute "cell-cultures" "user" "sounds") + :directory '(:absolute "0dev" "user" "sounds") :type "wav")) --- /project/cello/cvsroot/cello/cl-openal/cl-openal-demo.lisp 2006/05/17 20:38:14 1.2 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal-demo.lisp 2006/05/27 06:01:38 1.3 @@ -3,8 +3,8 @@ (defconstant num_buffers 7) (defparameter g-buffers (fgn-alloc 'al-uint num_buffers)) -(defun cl-openal-test () - (let ((w$ (list "/0dvx/user/sounds/jshootme.wav" ))) +(defun cl-openal-test-many () + (let ((w$ (list "/0dev/user/sounds/jshootme.wav" ))) (cl-openal-init) (apply 'wav-play-till-end (lambda (dur sources) @@ -16,6 +16,8 @@ (sleep 1) (cl-openal-shutdown)) +(defun cl-openal-test () + (wav-play-till-end nil "/0dev/user/sounds/jshootme.wav")) --- /project/cello/cvsroot/cello/cl-openal/cl-openal-init.lisp 2006/05/26 22:08:56 1.3 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal-init.lisp 2006/05/27 06:01:38 1.4 @@ -24,13 +24,8 @@ (in-package :cl-openal) - (defparameter *openal-initialized-p* nil) -(defun hex (dec) - (let ((*print-base* 16.)(*print-radix* t)) - (princ dec))) - (defun cl-openal-init () ;;(return-from cl-openal-init nil) (when *openal-initialized-p* @@ -38,10 +33,10 @@ (xoa) - (assert (cffi-uffi-compat:load-foreign-library (namestring *al-dynamic-lib*)) + (assert (use-foreign-library OpenAL) () "Failed to load OpenAL dynamic lib ~a" *al-dynamic-lib*) - (assert (cffi-uffi-compat:load-foreign-library (namestring *alut-dynamic-lib*)) + (assert (use-foreign-library ALut) () "Failed to load alut dynamic lib ~a" *alut-dynamic-lib*) (format t "~&Open AL loaded") --- /project/cello/cvsroot/cello/cl-openal/cl-openal.lisp 2006/05/17 20:38:14 1.2 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal.lisp 2006/05/27 06:01:38 1.3 @@ -26,7 +26,7 @@ (defpackage #:cl-openal (:nicknames #:oal) - (:use #:common-lisp #:cffi #:ffx) + (:use #:common-lisp #:cffi #:cffi-extender) (:export #:xoa #:al-chk @@ -41,6 +41,19 @@ (in-package :cl-openal) +(define-foreign-library OpenAL + (:darwin (:framework "OpenAL")) + (:windows (:or "/windows/system32/openal32.dll"))) + +(define-foreign-library ALut + (:darwin (:framework "ALut")) + (:windows (:or "/windows/system32/alut.dll"))) + +(defparameter *audio-files* + (make-pathname + :directory '(:absolute "0dev" "user" "sounds") + :type "wav")) + #+doit (xoa) --- /project/cello/cvsroot/cello/cl-openal/cl-openal.lpr 2006/05/26 22:08:56 1.3 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal.lpr 2006/05/27 06:01:38 1.4 @@ -5,8 +5,7 @@ (defpackage :CL-OPENAL) (define-project :name :cl-openal - :modules (list (make-instance 'module :name "cl-openal-config.lisp") - (make-instance 'module :name "cl-openal.lisp") + :modules (list (make-instance 'module :name "cl-openal.lisp") (make-instance 'module :name "altypes.lisp") (make-instance 'module :name "al.lisp") (make-instance 'module :name "alctypes.lisp") --- /project/cello/cvsroot/cello/cl-openal/wav-handling.lisp 2006/05/17 20:38:14 1.2 +++ /project/cello/cvsroot/cello/cl-openal/wav-handling.lisp 2006/05/27 06:01:38 1.3 @@ -47,6 +47,10 @@ (al-delete-sources sct sv) (fgn-free sv))) +(defun wav-play-start (wav-path) + (assert (probe-file wav-path)) + (source-wav-play-start (car (al-source-gen 1)) wav-path)) + (defun wav-play-till-end (callback &rest wav-names) (when (cl-openal-init) (let ((sources (al-source-gen (length wav-names)))) @@ -76,7 +80,8 @@ (let ((buffer (wav-to-buffer wav-path))) (source-buffer-load source buffer) (al-source-play source) - (al-chk "al-Source-Play")))) + (al-chk "al-Source-Play") + source))) (defun wav-to-buffer (wav-path) (when (cl-openal-init)

1 0

[cello-cvs] CVS cello/cl-magick
by ktilton 27 May '06

27 May '06

Update of /project/cello/cvsroot/cello/cl-magick In directory clnet:/tmp/cvs-serv7090/cl-magick Modified Files: cl-magick.lisp Log Message: --- /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2006/05/26 22:08:56 1.2 +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2006/05/27 06:01:38 1.3 @@ -25,8 +25,8 @@ (:use #:common-lisp #-(or cormanlisp ccl) #:clos - #:hello-c - #:ffx + #:cffi + #:cffi-extender #+kt-opengl #:kt-opengl ;; wands as opengl textures )

1 0

[cello-cvs] CVS cello/kt-opengl
by ktilton 27 May '06

27 May '06

Update of /project/cello/cvsroot/cello/kt-opengl In directory clnet:/tmp/cvs-serv30862/kt-opengl Log Message: Directory /project/cello/cvsroot/cello/kt-opengl added to the repository

1 0

[cello-cvs] CVS cello/hello-cffi
by ktilton 26 May '06

26 May '06

Update of /project/cello/cvsroot/cello/hello-cffi In directory clnet:/tmp/cvs-serv8567/hello-cffi Removed Files: arrays.lisp callbacks.lisp definers.lisp ffi-extender.lisp hello-cffi.asd hello-cffi.lpr my-uffi-compat.lisp Log Message: Cello Rizing. cl-opengl becomes kt-opengl, hello-cffi becomes cffi-extender, end lots more to come

1 0

[cello-cvs] CVS cello/cl-opengl
by ktilton 26 May '06

26 May '06

Update of /project/cello/cvsroot/cello/cl-opengl In directory clnet:/tmp/cvs-serv8567/cl-opengl Removed Files: build-prep.lisp cl-opengl.asd cl-opengl.lisp cl-opengl.lpr gl-constants.lisp gl-def.lisp gl-functions.lisp glu-functions.lisp ogl-macros.lisp ogl-utils.lisp Log Message: Cello Rizing. cl-opengl becomes kt-opengl, hello-cffi becomes cffi-extender, end lots more to come

1 0

[cello-cvs] CVS cello/cl-ftgl
by ktilton 26 May '06

26 May '06

Update of /project/cello/cvsroot/cello/cl-ftgl In directory clnet:/tmp/cvs-serv8567/cl-ftgl Modified Files: cl-ftgl.lisp cl-ftgl.lpr Log Message: Cello Rizing. cl-opengl becomes kt-opengl, hello-cffi becomes cffi-extender, end lots more to come --- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2006/05/17 16:14:29 1.1 +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2006/05/26 22:08:55 1.2 @@ -20,11 +20,11 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Header: /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp,v 1.1 2006/05/17 16:14:29 ktilton Exp $ +;;; $Header: /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp,v 1.2 2006/05/26 22:08:55 ktilton Exp $ (defpackage #:cl-ftgl (:nicknames #:ftgl) - (:use #:common-lisp #:cffi #:cl-opengl) + (:use #:common-lisp #:cffi #:kt-opengl) (:export #:ftgl #:ftgl-pixmap #:ftgl-texture --- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2006/05/17 20:38:13 1.3 +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2006/05/26 22:08:55 1.4 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (May 11, 2006 6:29)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- (in-package :cg-user) @@ -7,7 +7,7 @@ (define-project :name :cl-ftgl :modules (list (make-instance 'module :name "cl-ftgl.lisp")) :projects (list (make-instance 'project-module :name - "C:\\0devtools\\cffi\\cffi")) + "C:\\1-devtools\\cffi\\cffi")) :libraries nil :distributed-files nil :internally-loaded-files nil

1 0