From ktilton at common-lisp.net Sat Jun 3 12:05:54 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 3 Jun 2006 08:05:54 -0400 (EDT) Subject: [cello-cvs] CVS cello Message-ID: <20060603120554.0138E111C9@common-lisp.net> 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) , at 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)))))) From ktilton at common-lisp.net Sat Jun 3 12:05:55 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 3 Jun 2006 08:05:55 -0400 (EDT) Subject: [cello-cvs] CVS cello/cellodemo Message-ID: <20060603120555.66508111CC@common-lisp.net> 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 From ktilton at common-lisp.net Sat Jun 3 12:05:55 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 3 Jun 2006 08:05:55 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-ftgl Message-ID: <20060603120555.9B5A3111CC@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-ftgl In directory clnet:/tmp/cvs-serv8832/cl-ftgl Modified Files: cl-ftgl.lisp Log Message: Somewhat resurrected; clean compile anyway --- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2006/05/26 22:08:55 1.2 +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2006/06/03 12:05:55 1.3 @@ -20,7 +20,7 @@ ;;; 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.2 2006/05/26 22:08:55 ktilton Exp $ +;;; $Header: /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp,v 1.3 2006/06/03 12:05:55 ktilton Exp $ (defpackage #:cl-ftgl (:nicknames #:ftgl) @@ -55,6 +55,7 @@ (use-foreign-library FTGL) (defparameter *gui-style-default-face* 'sylfaen) +(defparameter *gui-style-button-face* 'sylfaen) (defparameter *ftgl-loaded-p* nil) (defparameter *ftgl-fonts-loaded* nil) From ktilton at common-lisp.net Sat Jun 3 12:06:00 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 3 Jun 2006 08:06:00 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-magick Message-ID: <20060603120600.93A581205B@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-magick In directory clnet:/tmp/cvs-serv8832/cl-magick Modified Files: magick-wand.lisp Log Message: Somewhat resurrected; clean compile anyway --- /project/cello/cvsroot/cello/cl-magick/magick-wand.lisp 2006/05/17 16:14:29 1.1 +++ /project/cello/cvsroot/cello/cl-magick/magick-wand.lisp 2006/06/03 12:05:55 1.2 @@ -319,8 +319,31 @@ "MagickWriteImages" (:void *wand :string filename :unsigned-int adjoinp) ;; 0=false ) +(dfenum storagetype + char-pixel + short-pixel + integer-pixel + long-pixel + float-pixel + double-pixel) - +(dfenum filtertypes + undefined-filter + point-filter + box-filter + triangle-filter + hermite-filter + hanning-filter + hamming-filter + blackman-filter + gaussian-filter + quadratic-filter + cubic-filter + catrom-filter + mitchell-filter + lanczos-filter + bessel-filter + sinc-filter) (ffx::defun-ffx-multi :unsigned-long "imagick" "MagickGetImageColors" (:void *wand) From ktilton at common-lisp.net Sat Jun 3 12:06:02 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 3 Jun 2006 08:06:02 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-openal Message-ID: <20060603120602.B089619002@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-openal In directory clnet:/tmp/cvs-serv8832/cl-openal Modified Files: cl-openal-init.lisp Log Message: Somewhat resurrected; clean compile anyway --- /project/cello/cvsroot/cello/cl-openal/cl-openal-init.lisp 2006/05/27 06:01:38 1.4 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal-init.lisp 2006/06/03 12:06:00 1.5 @@ -34,10 +34,10 @@ (xoa) (assert (use-foreign-library OpenAL) - () "Failed to load OpenAL dynamic lib ~a" *al-dynamic-lib*) + () "Failed to load OpenAL dynamic lib") (assert (use-foreign-library ALut) - () "Failed to load alut dynamic lib ~a" *alut-dynamic-lib*) + () "Failed to load alut dynamic lib") (format t "~&Open AL loaded") From ktilton at common-lisp.net Sat Jun 3 12:06:08 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 3 Jun 2006 08:06:08 -0400 (EDT) Subject: [cello-cvs] CVS cello/kt-opengl Message-ID: <20060603120608.BD0763C00A@common-lisp.net> Update of /project/cello/cvsroot/cello/kt-opengl In directory clnet:/tmp/cvs-serv8832/kt-opengl Modified Files: kt-opengl.lisp Log Message: Somewhat resurrected; clean compile anyway --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lisp 2006/05/27 06:01:39 1.1 +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lisp 2006/06/03 12:06:02 1.2 @@ -76,6 +76,8 @@ (in-package :kt-opengl) +(defvar *selecting*) + (defparameter *gl-dynamic-lib* (make-pathname ;;#+lispworks :host #-lispworks :device "c" From ktilton at common-lisp.net Sat Jun 3 18:53:53 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 3 Jun 2006 14:53:53 -0400 (EDT) Subject: [cello-cvs] CVS cello Message-ID: <20060603185353.8FB7D2B02A@common-lisp.net> Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv26719 Removed Files: cellocore.asd ct-scroll-bar.lisp ct-scroll-pane.lisp ix-inline.lisp menu.lisp rgb.lisp to-do.lisp window-key.lisp window-render.lisp Log Message: Remove some detritus From ktilton at common-lisp.net Sun Jun 4 00:08:53 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 3 Jun 2006 20:08:53 -0400 (EDT) Subject: [cello-cvs] CVS cello/cffi-extender Message-ID: <20060604000853.8FCCD7700E@common-lisp.net> Update of /project/cello/cvsroot/cello/cffi-extender In directory clnet:/tmp/cvs-serv1200/cffi-extender Log Message: Directory /project/cello/cvsroot/cello/cffi-extender added to the repository From ktilton at common-lisp.net Sun Jun 4 00:09:53 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 3 Jun 2006 20:09:53 -0400 (EDT) Subject: [cello-cvs] CVS cello/cffi-extender Message-ID: <20060604000953.D17A313005@common-lisp.net> Update of /project/cello/cvsroot/cello/cffi-extender In directory clnet:/tmp/cvs-serv1272/cffi-extender Added Files: arrays.lisp callbacks.lisp cffi-extender.asd cffi-extender.lisp cffi-extender.lpr definers.lisp my-uffi-compat.lisp Log Message: --- /project/cello/cvsroot/cello/cffi-extender/arrays.lisp 2006/06/04 00:09:53 NONE +++ /project/cello/cvsroot/cello/cffi-extender/arrays.lisp 2006/06/04 00:09:53 1.1 ;;; ;;; 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 :ffx) (defparameter *gl-rsrc* nil) (defparameter *fgn-mem* nil) (defun fgn-dump () (print (length *fgn-mem*)) (loop for fgn in *fgn-mem* do (print fgn) summing (fgn-amt fgn))) #+check (fgn-dump) (defun ffx-reset (&optional force) (hic-reset force)) (defun hic-reset (&optional force) (if force (progn (loop for fgn in *fgn-mem* do (print fgn) (foreign-free (fgn-ptr fgn)) finally (setf *fgn-mem* nil)) (loop for fgn in *gl-rsrc* do (print fgn) (glfree (fgn-type fgn)(fgn-ptr fgn)) finally (setf *gl-rsrc* nil)) (progn (when *fgn-mem* (loop for fgn in *fgn-mem* do (print fgn) finally (break "above fgn-mem not freed"))) (when *gl-rsrc* (loop for fgn in *gl-rsrc* do (print fgn) finally (break "above *gl-rsrc* not freed"))))))) (defstruct fgn ptr id type amt) (defmethod print-object ((fgn fgn) s) (format s "fgnmem ~a :amt ~a :type ~a" (fgn-id fgn)(fgn-amt fgn)(fgn-type fgn))) (defmacro fgn-alloc (type amt-form &rest keys) (let ((amt (gensym)) (ptr (gensym))) `(let* ((,amt ,amt-form) (,ptr (falloc ,type ,amt))) (call-fgn-alloc ,type ,amt ,ptr (list , at keys))))) (defun call-fgn-alloc (type amt ptr keys) ;;(print `(call-fgn-alloc ,type ,amt ,keys)) (fgn-ptr (car (push (make-fgn :id keys :type type :amt amt :ptr ptr) *fgn-mem*)))) (defun fgn-free (&rest fgn-ptrs) ;; (print `(fgn-free freeing , at fgn-ptrs)) (let ((start (copy-list fgn-ptrs))) (loop for fgn-ptr in start do (let ((fgn (find fgn-ptr *fgn-mem* :key 'fgn-ptr))) (if fgn (setf *fgn-mem* (delete fgn *fgn-mem*)) (format t "~&Freeing unknown FGN ~a" fgn-ptr)) (foreign-free fgn-ptr))))) (defun gllog (type resource amt &rest keys) (push (make-fgn :id keys :type type :amt amt :ptr resource) *gl-rsrc*)) (defun glfree (type resource) (let ((fgn (find (cons type resource) *gl-rsrc* :test 'equal :key (lambda (g) (cons (fgn-type g)(fgn-ptr g)))))) (if fgn (setf *gl-rsrc* (delete fgn *gl-rsrc*)) (format t "~&Freeing unknown GL resource ~a" (cons type resource))) #+nonono (ecase type (:texture (ogl:ogl-texture-delete resource))))) (defmacro make-ff-array (type &rest values) (let ((fv (gensym))(n (gensym))(vs (gensym))) `(let ((,fv (fgn-alloc ',type ,(length values) :make-ff-array)) (,vs (list , at values))) (dotimes (,n ,(length values) ,fv) (setf (ff-elt ,fv ,type ,n) (coerce (nth ,n ,vs) ',(if (keywordp type) (intern (symbol-name type)) (get type 'ffi-cast)))))))) (defmacro ff-list (array type count) (let ((a (gensym))(n (gensym))) `(loop with ,a = ,array for ,n below ,count collecting (ff-elt ,a ,type ,n)))) (defun make-floatv (&rest floats) (let* ((co (fgn-alloc :float (length floats) :make-floatv)) ) (apply 'ff-floatv-setf co floats))) (defmacro ff-floatv-ensure (place &rest values) `(if ,place (ff-floatv-setf ,place , at values) (setf ,place (make-floatv , at values)))) (defun ff-floatv-setf (array &rest floats) (loop for f in floats and n upfrom 0 do (setf (mem-aref array :float n) (* 1.0 f))) array) ;--------- with-ff-array-elements ------------------------------------------ (defmacro with-ff-array-elements ((fa type &rest refs) &body body) `(let ,(let ((refn -1)) (mapcar (lambda (ref) `(,ref (mem-aref ,fa ,type) ,(incf refn))) refs)) , at body)) ;-------- ff-elt --------------------------------------- (defmacro ff-elt-p (v n) `(mem-aref ,v :pointer ,n)) (defmacro ff-elt (v type n) `(mem-aref ,v ',type ,n)) (defun elti (v n) (ff-elt v :int n)) (defun (setf elti) (value v n) (setf (ff-elt v :int n) (coerce value 'integer))) (defun eltf (v n) (ff-elt v :float n)) (defun (setf eltf) (value v n) (setf (ff-elt v :float n) (coerce value 'float))) (defun elt$ (v n) (ff-elt v :string n)) (defun (setf elt$) (value v n) (setf (ff-elt v :string n) value)) (defun eltd (v n) (ff-elt v :double n)) (defun (setf eltd) (value v n) (setf (ff-elt v :double n) (coerce value 'double-float))) (defmacro fgn-pa (pa n) `(mem-aref ,pa :pointer ,n)) (eval-when (compile load eval) (export '(ffx-reset ff-elt ff-list eltf eltd elti fgn-pa with-ff-array-elements make-ff-array make-floatv ff-floatv-ensure hic-reset fgn-alloc fgn-free gllog glfree)))--- /project/cello/cvsroot/cello/cffi-extender/callbacks.lisp 2006/06/04 00:09:53 NONE +++ /project/cello/cvsroot/cello/cffi-extender/callbacks.lisp 2006/06/04 00:09:53 1.1 ;;; ;;; 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 :ffx) #+precffi (defun ff-register-callable (callback-name) #+allegro (ff:register-foreign-callable callback-name) #+lispworks (let ((cb (progn ;; fli:pointer-address (fli:make-pointer :symbol-name (symbol-name callback-name) ;; leak? :functionp t)))) (print (list :ff-register-callable-returns cb)) cb)) (defun ff-register-callable (callback-name) (let ((known-callback (cffi:get-callback callback-name))) (assert known-callback) known-callback)) (defmacro ff-defun-callable (call-convention result-type name args &body body) (declare (ignorable call-convention)) `(defcallback ,name ,result-type ,args , at body)) #+precffi (defmacro ff-defun-callable (call-convention result-type name args &body body) (declare (ignorable call-convention result-type)) (let ((native-args (when args ;; without this p-f-a returns '(:void) as if for declare (process-function-args args)))) #+lispworks `(fli:define-foreign-callable (,(symbol-name name) :result-type ,result-type :calling-convention ,call-convention) (, at native-args) , at body) #+allegro `(ff:defun-foreign-callable ,name ,native-args (declare (:convention ,(ecase call-convention (:cdecl :c) (:stdcall :stdcall)))) , at body))) #+(or) (ff-defun-callable :cdecl :int square ((arg-1 :int)(data :pointer)) (list data (* arg-1 arg-1))) (eval-when (compile load eval) (export '(ff-register-callable ff-defun-callable ff-pointer-address)))--- /project/cello/cvsroot/cello/cffi-extender/cffi-extender.asd 2006/06/04 00:09:53 NONE +++ /project/cello/cvsroot/cello/cffi-extender/cffi-extender.asd 2006/06/04 00:09:53 1.1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;(declaim (optimize (debug 2) (speed 1) (safety 1) (compilation-speed 1))) (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) (asdf:defsystem :cffi-extender :name "CFFI Extender" :author "Kenny Tilton " :version "1.0.0" :maintainer "Kenny Tilton " :licence "Lisp Lesser GNU Public License" :description "CFFI Add-ons" :long-description "Extensions and utilities for CFFI" :depends-on (cffi cffi-uffi-compat) :serial t :components ((:file "cffi-extender") (:file "my-uffi-compat") (:file "definers") (:file "arrays") (:file "callbacks")))--- /project/cello/cvsroot/cello/cffi-extender/cffi-extender.lisp 2006/06/04 00:09:53 NONE +++ /project/cello/cvsroot/cello/cffi-extender/cffi-extender.lisp 2006/06/04 00:09:53 1.1 (defpackage #:cffi-extender (:nicknames #:ffx) #+hunh? (:shadowing-import-from #:cffi #:with-foreign-object #:load-foreign-library #:with-foreign-string) (:use #:common-lisp #:cffi)) --- /project/cello/cvsroot/cello/cffi-extender/cffi-extender.lpr 2006/06/04 00:09:53 NONE +++ /project/cello/cvsroot/cello/cffi-extender/cffi-extender.lpr 2006/06/04 00:09:53 1.1 ;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- (in-package :cg-user) (defpackage :CFFI-EXTENDER) (define-project :name :cffi-extender :modules (list (make-instance 'module :name "cffi-extender.lisp") (make-instance 'module :name "my-uffi-compat.lisp") (make-instance 'module :name "definers.lisp") (make-instance 'module :name "arrays.lisp") (make-instance 'module :name "callbacks.lisp")) :projects (list (make-instance 'project-module :name "C:\\1-devtools\\cffi\\cffi")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :cffi-extender :main-form nil :compilation-unit t :verbose nil :runtime-modules nil :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") :include-flags '(:local-name-info) :build-flags '(:allow-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil :default-command-line-arguments "+cx +t \"Initializing\"" :additional-build-lisp-image-arguments '(:read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard :on-initialization 'default-init-function :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cello/cvsroot/cello/cffi-extender/definers.lisp 2006/06/04 00:09:53 NONE +++ /project/cello/cvsroot/cello/cffi-extender/definers.lisp 2006/06/04 00:09:53 1.1 ;;; ;;; 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 :ffx) (eval-when (compile load eval) (export '( defun-ffx defun-ffx-multi dffr dfc dft dfenum make-ff-pointer ff-pointer-address ))) (defun ff-pointer-address (ff-ptr) #-lispworks ff-ptr #+lispworks (fli:pointer-address ff-ptr)) ;;;(defun make-ff-pointer (n) ;;; #-lispworks ;;; n ;;; #+lispworks ;;; (fli:make-pointer :address n :pointer-type '(:pointer :void))) (defun make-ff-pointer (n) #+lispworks (fli:make-pointer :address n :pointer-type '(:pointer :void)) #+clisp (ffi:unsigned-foreign-address n) #-(or clisp lispworks) n ) (defmacro defun-ffx (rtn module$ name$ (&rest type-args) &body post-processing) (declare (ignore module$)) (let* ((lisp-fn (lisp-fn name$)) (lispfn (intern (string-upcase name$))) (var-types (let (args) (assert (evenp (length type-args)) () "uneven arg-list for ~a" name$) (dotimes (n (floor (length type-args) 2) (nreverse args)) (let ((type (elt type-args (* 2 n))) (var (elt type-args (1+ (* 2 n))))) (when (eql #\* (elt (symbol-name var) 0)) ;; no, good with *: (setf var (intern (subseq (symbol-name var) 1))) (setf type :pointer)) (push (list var type) args))))) (cast-vars (mapcar (lambda (var-type) (copy-symbol (car var-type))) var-types))) `(progn (cffi:defcfun (,name$ ,lispfn) ,(if (and (consp rtn) (eq '* (car rtn))) [117 lines skipped] --- /project/cello/cvsroot/cello/cffi-extender/my-uffi-compat.lisp 2006/06/04 00:09:53 NONE +++ /project/cello/cvsroot/cello/cffi-extender/my-uffi-compat.lisp 2006/06/04 00:09:53 1.1 [130 lines skipped] From ktilton at common-lisp.net Mon Jun 5 01:47:51 2006 From: ktilton at common-lisp.net (ktilton) Date: Sun, 4 Jun 2006 21:47:51 -0400 (EDT) Subject: [cello-cvs] CVS cello/kt-opengl Message-ID: <20060605014751.1E053415E@common-lisp.net> Update of /project/cello/cvsroot/cello/kt-opengl In directory clnet:/tmp/cvs-serv15587/kt-opengl Modified Files: kt-opengl.lisp ogl-utils.lisp Log Message: Beginnings only of merge with Celtk --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lisp 2006/06/03 12:06:02 1.2 +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lisp 2006/06/05 01:47:50 1.3 @@ -55,7 +55,7 @@ #:ncalc-normalf #:ncalc-normalfv #:ogl-get-int #:ogl-get-boolean #:v3f #:make-v3f #:v3f-x #:v3f-y #:v3f-z #:with-gl-param #:xlin #:xlout - #:ups #:ups-most #:ups-more #:downs #:downs-most #:downs-more #:farther #:nearer + #:farther #:nearer #:ogl-texture-delete #:ogl-texture-gen #:ogl-tex-gen-setup #:ogl-bounds #:ogl-scissor-box #:ogl-raster-pos-get #:ogl-pen-move #:with-bitmap-shifted --- /project/cello/cvsroot/cello/kt-opengl/ogl-utils.lisp 2006/05/27 06:01:39 1.1 +++ /project/cello/cvsroot/cello/kt-opengl/ogl-utils.lisp 2006/06/05 01:47:50 1.2 @@ -85,24 +85,6 @@ (loop for n below 4 collecting (eltgli ff-box n))) -(defun ups (&rest values) - (apply '+ values)) - -(defun ups-more (&rest values) - (apply '> values)) - -(defun ups-most (&rest values) - (apply 'max values)) - -(defun downs (&rest values) - (apply '- values)) - -(defun downs-most (&rest values) - (apply 'min values)) - -(defun downs-more (&rest values) - (apply '< values)) - (defun farther (&rest values) (apply '- values)) (defun xlin (&rest values) ;; yep. moves matrix, not object From ktilton at common-lisp.net Sun Jun 11 13:32:24 2006 From: ktilton at common-lisp.net (ktilton) Date: Sun, 11 Jun 2006 09:32:24 -0400 (EDT) Subject: [cello-cvs] CVS cello Message-ID: <20060611133224.BF5D77502A@common-lisp.net> Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv31340 Modified Files: cello-ftgl.lisp cello.lpr image.lisp ix-layer-expand.lisp ix-render.lisp ix-text.lisp lighting.lisp mouse-click.lisp nehe-06.lisp window-callbacks.lisp window-utilities.lisp Log Message: --- /project/cello/cvsroot/cello/cello-ftgl.lisp 2006/06/05 01:47:49 1.4 +++ /project/cello/cvsroot/cello/cello-ftgl.lisp 2006/06/11 13:32:24 1.5 @@ -67,7 +67,7 @@ (font-ftgl-ensure (mode style) (face style) (gui-style-size style))) (defun ftgl-debug () - (let (*w*) + (let (*tkw*) (with-styles ( (make-instance 'gui-style-ftgl :id :button --- /project/cello/cvsroot/cello/cello.lpr 2006/06/05 01:47:49 1.5 +++ /project/cello/cvsroot/cello/cello.lpr 2006/06/11 13:32:24 1.6 @@ -74,7 +74,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'nehe-06::nehe-06 + :on-initialization 'cello::nehe-06 :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cello/cvsroot/cello/image.lisp 2006/06/05 01:47:49 1.4 +++ /project/cello/cvsroot/cello/image.lisp 2006/06/11 13:32:24 1.5 @@ -16,8 +16,6 @@ (in-package :cello) -(defparameter *w* nil) - ; ------------------------------------------------------ --- /project/cello/cvsroot/cello/ix-layer-expand.lisp 2006/06/05 01:47:49 1.4 +++ /project/cello/cvsroot/cello/ix-layer-expand.lisp 2006/06/11 13:32:24 1.5 @@ -56,7 +56,9 @@ (gl-disable gl_blend) (gl-disable gl_texture_2d) (gl-normal3i 0 0 1) - (gl-rectf (r-left l-box)(r-bottom l-box)(r-right l-box)(r-top l-box))) + + (gl-rectf (r-left l-box) (r-top l-box) (r-right l-box)(r-bottom l-box)) + ) (defmethod ix-layer-expand ((key (eql :normal-out)) &rest args) (declare (ignore args)) --- /project/cello/cvsroot/cello/ix-render.lisp 2006/06/05 01:47:49 1.3 +++ /project/cello/cvsroot/cello/ix-render.lisp 2006/06/11 13:32:24 1.4 @@ -17,32 +17,6 @@ (in-package :cello) -(defmethod ix-paint :before ((self ix-lit-scene)) - (gl-enable gl_color_material) - (when (eql :on (lighting self)) - (trc nil "lighting on!" self) - (gl-enable gl_lighting)) - - (dolist (lm (light-model self)) - ;(trc "lighting model!" self lm) - (gl-light-modelfv (car lm)(cdr lm))) - - (gl-enable gl_auto_normal) - (gl-enable gl_normalize) - - (let (lights) - ;; /// next bit should not descend into a nested lit scene - (fm-traverse self (lambda (self) - (when (typep self 'ix-light) - (setf lights (or lights (^enabled))) - (ix-render-light self)))) - (loop for light in (fixed-lighting self) - do (ix-render-light light)) - (when (and (not lights) (emergency-lighting self)) - (trc nil "emergency lighting" self) - (dolist (e-light (emergency-lighting self)) - (ix-render-light e-light))))) - (defmethod ix-paint :after ((self family)) (dolist (k (kids self)) (trc nil "ixr geo" k (list (px k)(py k)) (list (ll k)(lt k)(lr k)(lb k))) @@ -66,7 +40,7 @@ (defmethod ix-paint (self) (declare (ignorable self)) - (trc nil "ix-render fell through" self (class-of self))) + (trc "ix-render fell through" self (class-of self))) (defmacro with-ogl-isolation (&body body) `(with-attrib (gl_lighting_bit gl_texture_bit gl_enable_bit gl_hint_bit gl_line_bit gl_color_buffer_bit) @@ -74,13 +48,13 @@ (let ((ixr-box (mkr 0 0 0 0))) (defmethod ix-paint :around ((self image) &aux (n (gl-name self))) - (trc nil "painting" self (^px)(^py)(^lr)) + (trc "painting, shifting bitmap" self n (^px)(^py)) (with-bitmap-shifted ((px self)(py self)) (gl-translatef (px self) (py self) 0) (when n - (trc nil "gl-name" self n) + (trc "pushing gl-name" self n) (gl-push-name n)) (rpchk 'ix-paint t nil self) @@ -89,13 +63,13 @@ (ix-selectable self)) (visible self) (not (collapsed self))) - (with-clipping (self) + (progn ;;with-clipping (self) (progn ;; with-attrib (gl_lighting_bit gl_texture_bit gl_enable_bit gl_hint_bit gl_line_bit gl_color_buffer_bit) (count-it :ix-render) #+(or) (count-it :ix-render (type-of self)) #+(or) (unless (kids self) (count-it :ix-render-atom)) - (trc nil "ix painting" self) + (trc "ix painting" self (lighting self)) (with-matrix () (with-ogl-isolation (case (lighting self) ;; default is "same as parent" --- /project/cello/cvsroot/cello/ix-text.lisp 2006/06/05 01:47:49 1.4 +++ /project/cello/cvsroot/cello/ix-text.lisp 2006/06/11 13:32:24 1.5 @@ -18,6 +18,9 @@ ;=========================================================== +(eval-when (compile load eval) + (export '(ix-paint))) + (defmodel ix-text (ix-styled image) ( (text$ :initform nil :initarg :text$ :accessor text$) --- /project/cello/cvsroot/cello/lighting.lisp 2006/06/05 01:47:49 1.3 +++ /project/cello/cvsroot/cello/lighting.lisp 2006/06/11 13:32:24 1.4 @@ -41,19 +41,13 @@ ;;---------------------------------------------- -(defun make-lighting (md-name id pos) - (make-instance 'ix-light - :md-name md-name - :id id - :initial-pos pos)) - -(defmodel ix-lit-scene (ix-family) +(defmodel ix-lit-scene () ;; mix in with ix-family ( (clear-rgba :cell nil :initarg :clear-rgba :initform nil :accessor clear-rgba) (light-model :initarg :light-model :initform (list (cons gl_light_model_ambient *dim*)) :accessor light-model) (lights :initarg :lights :accessor lights - :initform (c? (without-c-dependency + :initform nil #+refactor (c? (without-c-dependency (let (lights) (fm-traverse self (lambda (self) (when (typep self 'ix-light) @@ -76,7 +70,32 @@ :diffuse *average* :specular *bright*))))) - +(defmethod ix-paint :before ((self ix-lit-scene)) + (gl-enable gl_color_material) + (when (eql :on (lighting self)) + (trc nil "lighting on!" self) + (gl-enable gl_lighting)) + + (dolist (lm (light-model self)) + ;(trc "lighting model!" self lm) + (gl-light-modelfv (car lm)(cdr lm))) + + (gl-enable gl_auto_normal) + (gl-enable gl_normalize) + + (let (lights) + ;; /// next bit should not descend into a nested lit scene + #+refactorifneeded + (fm-traverse self (lambda (self) + (when (typep self 'ix-light) + (setf lights (or lights (^enabled))) + (ix-render-light self)))) + (loop for light in (fixed-lighting self) + do (ix-render-light light)) + (when (and (not lights) (emergency-lighting self)) + (trc nil "emergency lighting" self) + (dolist (e-light (emergency-lighting self)) + (ix-render-light e-light))))) (defun pct-xlate (pct v1 v2 expansion) (let* ((dv (round (- v2 v1) 2)) --- /project/cello/cvsroot/cello/mouse-click.lisp 2006/06/05 01:47:49 1.4 +++ /project/cello/cvsroot/cello/mouse-click.lisp 2006/06/11 13:32:24 1.5 @@ -77,11 +77,12 @@ (when (or (null new-click) (if (typep self 'window) (ctl-notify-mouse-click self self new-click) - (ctl-notify-mouse-click (fm-parent self) self new-click))) + (ctl-notify-mouse-click (fm-parent self) self new-click))) (call-next-method))) (defmethod ctl-notify-mouse-click (self clickee click) - (ctl-notify-mouse-click (fm-parent self) clickee click)) + (when (fm-parent self) + (ctl-notify-mouse-click (fm-parent self) clickee click))) ; -------------------------------------------------------- --- /project/cello/cvsroot/cello/nehe-06.lisp 2006/06/05 01:47:49 1.3 +++ /project/cello/cvsroot/cello/nehe-06.lisp 2006/06/11 13:32:24 1.4 @@ -3,10 +3,7 @@ ;;; nehe lesson 06 spinning cube with texture ;;; -(defpackage :nehe-06 - (:use :common-lisp :utils-kt :cells :celtk :kt-opengl :cl-magick :cl-ftgl)) - -(in-package :nehe-06) +(in-package :cello) (defvar *startx*) (defvar *starty*) --- /project/cello/cvsroot/cello/window-callbacks.lisp 2006/06/05 01:47:49 1.4 +++ /project/cello/cvsroot/cello/window-callbacks.lisp 2006/06/11 13:32:24 1.5 @@ -24,8 +24,7 @@ (progn (trc nil "window using disp list") (gl-call-list (dsp-list self))) - (ix-paint self))) - (incf (frame-ct self)))) + (ix-paint self))))) (defmethod ctk::togl-timer-using-class ((self ix-togl)) (unless (or *ogl-listing-p* ;; re-entrance happens if a DLL puts up a MessageBox --- /project/cello/cvsroot/cello/window-utilities.lisp 2006/06/05 01:47:49 1.4 +++ /project/cello/cvsroot/cello/window-utilities.lisp 2006/06/11 13:32:24 1.5 @@ -70,8 +70,7 @@ ; --------------- geometry ------------------------------- -(defmethod g-offset ((self cello-window) &optional (accum-h 0) (accum-v 0)) - (mkv2 accum-h accum-v)) + (defun point-in-box (pt box) (and (<= (r-left box) (v2-h pt) (r-right box)) From ktilton at common-lisp.net Sun Jun 11 13:32:24 2006 From: ktilton at common-lisp.net (ktilton) Date: Sun, 11 Jun 2006 09:32:24 -0400 (EDT) Subject: [cello-cvs] CVS cello/cellodemo Message-ID: <20060611133224.0175F75056@common-lisp.net> Update of /project/cello/cvsroot/cello/cellodemo In directory clnet:/tmp/cvs-serv31340/cellodemo Modified Files: demo-window.lisp light-panel.lisp Log Message: --- /project/cello/cvsroot/cello/cellodemo/demo-window.lisp 2006/06/03 12:05:55 1.3 +++ /project/cello/cvsroot/cello/cellodemo/demo-window.lisp 2006/06/11 13:32:24 1.4 @@ -34,8 +34,7 @@ 'tu-geo :skin (c? (wand-ensure-typed 'wand-texture (car (md-value (fm-other :texture-picker))))) - :focus (c-in nil) - :display-continuous (c-in t) + :display-continuous (c-in t) :clear-rgba (list 0 0 0 1) :lb (c-in (downs 1000))))) --- /project/cello/cvsroot/cello/cellodemo/light-panel.lisp 2006/06/03 12:05:55 1.3 +++ /project/cello/cvsroot/cello/cellodemo/light-panel.lisp 2006/06/11 13:32:24 1.4 @@ -119,6 +119,11 @@ (starter-hedron))) +(defun make-lighting (md-name id pos) + (make-instance 'ix-light + :md-name md-name + :id id + :initial-pos pos)) (defun starter-hedron () (a-row (:outset (u8ths 1) :spacing (u8ths 1) From ktilton at common-lisp.net Sun Jun 11 13:32:25 2006 From: ktilton at common-lisp.net (ktilton) Date: Sun, 11 Jun 2006 09:32:25 -0400 (EDT) Subject: [cello-cvs] CVS cello/kt-opengl Message-ID: <20060611133225.37C8D7502A@common-lisp.net> Update of /project/cello/cvsroot/cello/kt-opengl In directory clnet:/tmp/cvs-serv31340/kt-opengl Modified Files: ogl-macros.lisp Log Message: --- /project/cello/cvsroot/cello/kt-opengl/ogl-macros.lisp 2006/05/27 06:01:39 1.1 +++ /project/cello/cvsroot/cello/kt-opengl/ogl-macros.lisp 2006/06/11 13:32:25 1.2 @@ -104,7 +104,7 @@ (defvar *gl-stop*) (defmacro with-gl-begun ((what) &body body) `(progn - (when *gl-begun* + (when (boundp '*gl-begun*) (setf *gl-stop* t) (break ":nestedbegin")) (let ((*gl-begun* t)) From ktilton at common-lisp.net Sun Jun 11 17:52:06 2006 From: ktilton at common-lisp.net (ktilton) Date: Sun, 11 Jun 2006 13:52:06 -0400 (EDT) Subject: [cello-cvs] CVS cello Message-ID: <20060611175206.4DCFD232B4@common-lisp.net> Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv31533 Modified Files: image.lisp Removed Files: datetime.lisp ix-geometry.lisp mg-geometry.lisp Log Message: --- /project/cello/cvsroot/cello/image.lisp 2006/06/11 13:32:24 1.5 +++ /project/cello/cvsroot/cello/image.lisp 2006/06/11 17:52:06 1.6 @@ -31,7 +31,7 @@ ; --------------------------------------------- -(defmodel image (geometer) +(defmodel image (geometer model) (; ; visibility ; From ktilton at common-lisp.net Mon Jun 26 17:05:20 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 26 Jun 2006 13:05:20 -0400 (EDT) Subject: [cello-cvs] CVS cello Message-ID: <20060626170520.CB32214007@common-lisp.net> Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv15578 Modified Files: cello-magick.lisp cello-openal.lisp cello.lisp cello.lpr ctl-drag.lisp ctl-markbox.lisp focus-utilities.lisp focus.lisp image.lisp ix-polygon.lisp ix-styled.lisp ix-text.lisp lighting.lisp nehe-06.lisp slider.lisp window-callbacks.lisp window-utilities.lisp Added Files: cello-window.lisp ix-opengl.lisp ix-paint.lisp ix-togl.lisp Removed Files: ix-render.lisp Log Message: Ongoing merge with Celtk --- /project/cello/cvsroot/cello/cello-magick.lisp 2006/06/05 01:47:49 1.3 +++ /project/cello/cvsroot/cello/cello-magick.lisp 2006/06/26 17:05:20 1.4 @@ -55,7 +55,7 @@ (ogl::glec :snapshot) (record-frame recording pixels columns rows)))) -(defmodel ix-wander (image) +(defmodel ix-wander (ix-view) ((wander :initarg :wander :accessor wander :initform nil)) ;;///just use skin? (:default-initargs :pre-layer (c? (with-layers (:wand (^wander)))))) @@ -80,12 +80,6 @@ (apply 'wand-render wand (r-bounds l-box)) (trc nil "ix-render-wand sees no wand" l-box))) -;;;(defun wand-centered-bounds (wand size) -;;; (let* ((raw-w (magick-get-image-width (^mgk-wand))) -;;; (over-w (- raw-w (v2-w size))) -;;; (raw-h (magick-get-image-height (^mgk-wand))) -;;; (over-h (- raw-h (v2-h size)))) -;;; (when (or (plusp over-w)(plusp over-h)) -;;; (list (max 0 ( + --- /project/cello/cvsroot/cello/cello-openal.lisp 2006/06/05 01:47:49 1.2 +++ /project/cello/cvsroot/cello/cello-openal.lisp 2006/06/26 17:05:20 1.3 @@ -75,7 +75,7 @@ oal::*audio-files*)))))) (defun ix-sound-spec-find (self key) - (when (typep self 'image) + (when (typep self 'ix-view) (or (cdr (assoc key (sound self))) (ix-sound-spec-find .parent key)))) --- /project/cello/cvsroot/cello/cello.lisp 2006/06/05 01:47:49 1.5 +++ /project/cello/cvsroot/cello/cello.lisp 2006/06/26 17:05:20 1.6 @@ -27,7 +27,8 @@ #:kt-opengl #:cl-openal #:cl-ftgl - #:cl-magick)) + #:cl-magick) + (:export #:cello-window-event-handler #:with-layers #:visible #:ix-togl)) ;;; in step one we will just have Celtk playing the part of Freeglut ;;; --- /project/cello/cvsroot/cello/cello.lpr 2006/06/11 13:32:24 1.6 +++ /project/cello/cvsroot/cello/cello.lpr 2006/06/26 17:05:20 1.7 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jun 21, 2006 9:54)"; cg: "1.81"; -*- (in-package :cg-user) @@ -37,7 +37,7 @@ (make-instance 'module :name "window-utilities.lisp") (make-instance 'module :name "wm-mouse.lisp") (make-instance 'module :name "pick.lisp") - (make-instance 'module :name "ix-render.lisp") + (make-instance 'module :name "ix-paint.lisp") (make-instance 'module :name "ix-polygon.lisp") (make-instance 'module :name "cello-ftgl.lisp") (make-instance 'module :name "cello-magick.lisp") @@ -46,6 +46,8 @@ :projects (list (make-instance 'project-module :name "..\\Celtk\\CELTK") (make-instance 'project-module :name + "..\\Cells\\gui-geometry\\gui-geometry") + (make-instance 'project-module :name "cffi-extender\\cffi-extender") (make-instance 'project-module :name "kt-opengl\\kt-opengl") @@ -54,7 +56,9 @@ (make-instance 'project-module :name "cl-ftgl\\cl-ftgl") (make-instance 'project-module :name - "cl-openal\\cl-openal")) + "cl-openal\\cl-openal") + (make-instance 'project-module :name + "cl-freetype\\cl-freetype")) :libraries nil :distributed-files nil :internally-loaded-files nil --- /project/cello/cvsroot/cello/ctl-drag.lisp 2006/06/05 01:47:49 1.4 +++ /project/cello/cvsroot/cello/ctl-drag.lisp 2006/06/26 17:05:20 1.5 @@ -16,7 +16,7 @@ (in-package :cello) -(defmodel ct-drag (control image) +(defmodel ct-drag (control ix-view) ((drag-pct :initarg :drag-pct :accessor drag-pct :unchanged-if 'v2= :initform (c-in (mkv2 0 0))) --- /project/cello/cvsroot/cello/ctl-markbox.lisp 2006/06/05 01:47:49 1.4 +++ /project/cello/cvsroot/cello/ctl-markbox.lisp 2006/06/26 17:05:20 1.5 @@ -22,7 +22,7 @@ (defmethod ix-layer-expand ((self (eql :x-mark)) &rest args) `(ix-render-x-mark ,(car args) l-box))) -(defmodel ct-mark-box (ct-toggle image) +(defmodel ct-mark-box (ct-toggle ix-view) ((kb-selector :cell nil :initarg :kb-selector :initform nil :reader kb-selector) ) (:default-initargs --- /project/cello/cvsroot/cello/focus-utilities.lisp 2006/06/05 01:47:49 1.3 +++ /project/cello/cvsroot/cello/focus-utilities.lisp 2006/06/26 17:05:20 1.4 @@ -65,7 +65,7 @@ ; 990329 /// kt Resurrect eventually ; (defmethod focus-scroll-into-view ((focus focus)) - ;; temp to get going (image-scroll-into-view focus) + ;; temp to get going (view-scroll-into-view focus) ) (defmethod focus-scroll-into-view (other) --- /project/cello/cvsroot/cello/focus.lisp 2006/06/05 01:47:49 1.2 +++ /project/cello/cvsroot/cello/focus.lisp 2006/06/26 17:05:20 1.3 @@ -34,6 +34,8 @@ it without it being a kid there |# +(eval-when (compile load eval) + (export '(^focus focus))) (defmodel focuser (ix-canvas) ( --- /project/cello/cvsroot/cello/image.lisp 2006/06/11 17:52:06 1.6 +++ /project/cello/cvsroot/cello/image.lisp 2006/06/26 17:05:20 1.7 @@ -16,22 +16,16 @@ (in-package :cello) +(eval-when (compile load eval) + (export '(ix-view))) ; ------------------------------------------------------ - -;;;(defmethod ix-render-prep (self) -;;; (declare (ignore self))) -;;; -;;;(defmethod ix-render-prep :after ((self family)) -;;; (dolist (k (^kids)) -;;; (ix-render-prep k))) - (defmodel ogl-quadric-based (ogl-node) ((quadric :initform nil :initarg :quadric :reader quadric))) ; --------------------------------------------- -(defmodel image (geometer model) +(defmodel ix-view (ogl-node geometer model) (; ; visibility ; @@ -74,7 +68,7 @@ ;;------- IXFamily ----------------------------- ;; -(defmodel ix-family (image family) +(defmodel ix-family (ix-view family) ( (styles :initform nil :reader styles :initarg :styles) @@ -89,18 +83,30 @@ :reader kids-ever-shown) )) -(defmodel ix-inline (geo-inline image)()) +(defmodel ix-inline (geo-inline ix-view)()) (defmodel ix-stack (ix-inline) () (:default-initargs :orientation :vertical)) -(defmodel ix-row (geo-row ix-inline) +(defmodel ix-row (ix-inline) () (:default-initargs :orientation :horizontal)) +(defmacro a-stack ((&rest stack-args) &body dd-kids) + `(mk-part ,(copy-symbol 'stk) (ix-stack) + , at stack-args + :fm-parent *parent* + :kids (c? (the-kids , at dd-kids)))) + +(defmacro a-row ((&rest stack-args) &body dd-kids) + `(mk-part ,(copy-symbol 'row) (ix-row) + , at stack-args + :fm-parent *parent* + :kids (c? (the-kids , at dd-kids)))) + (defmethod focus-starting ((self ix-family)) (some #'focus-find-first (kids self))) @@ -109,7 +115,7 @@ `(let* ((,kid ,self)) (find-prior ,kid (kids (fm-parent ,kid)))))) -(defmethod md-awaken :after ((self image)) +(defmethod md-awaken :after ((self ix-view)) (assert (px self)) (assert (py self)) (assert (ll self)) @@ -117,16 +123,16 @@ (assert (lr self)) (assert (lb self))) -(defmethod ogl-shared-resource-tender ((self image)) +(defmethod ogl-shared-resource-tender ((self ix-view)) .w.) -(defmethod ogl-node-window ((self image)) +(defmethod ogl-node-window ((self ix-view)) .w.) -(defmethod path ((self image)) +(defmethod path ((self ix-view)) (path (fm-parent self))) -(defmethod ogl-dsp-list-prep progn ((self image)) +(defmethod ogl-dsp-list-prep progn ((self ix-view)) (ogl-dsp-list-prep (skin self))) (defmethod ogl-dsp-list-prep progn ((self wand-texture)) @@ -134,7 +140,7 @@ (defmacro uskin () `(labels ((usk (self) - (when (typep self 'image) + (when (typep self 'ix-view) (or (skin self) (usk .parent))))) (usk self))) @@ -142,13 +148,13 @@ ;------------------------------ (defobserver mouse-over-p () (bwhen (p .parent) - (when (typep p 'image) + (when (typep p 'ix-view) (with-integrity(:change) (setf (mouse-over-p p) new-value))))) -(defmethod ix-selectable ((self image)) nil) +(defmethod ix-selectable ((self ix-view)) nil) -(defmethod ix-click-transparent ((self image)) +(defmethod ix-click-transparent ((self ix-view)) nil) @@ -156,13 +162,13 @@ (etypecase v (number v) (v2 (v2-h v)) - (image (inset-h (inset v))))) + (ix-view (inset-h (inset v))))) (defun inset-v (v) (etypecase v (number v) (v2 (v2-v v)) - (image (inset-h (inset v))))) + (ix-view (inset-h (inset v))))) (defmethod call-^fillright (self filled padding) (- (inset-lr filled) @@ -173,7 +179,7 @@ (setf (px self) (v2-h new-offset)) (setf (py self) (v2-v new-offset))) -(defmethod g-offset ((self image) &optional (accum-h 0) (accum-v 0)) +(defmethod g-offset ((self ix-view) &optional (accum-h 0) (accum-v 0)) (trc nil "goffset self" self 'px (px self) 'py (py self) 'fm-parent (fm-parent self)) (let ( (oh (+ accum-h (or (px self) 0))) @@ -194,7 +200,7 @@ (defmethod gunscaled (self value) (gunscaled (fm-parent self) value)) -(defmethod visible-fully ((self image)) ;; this used to be an :around on visible, but then focus-first +(defmethod visible-fully ((self ix-view)) ;; this used to be an :around on visible, but then focus-first (and (visible self) ;; could not find focus on page it was /going to/ (not yet visi) (or (null (fm-parent self)) ;; ...not sure who need visible to go up all the way (visible (fm-parent self))))) @@ -206,7 +212,7 @@ (defmethod visible ((other null)) (c-break "visible called on NIL")) -(defmethod dbg-awake ((ap image)) +(defmethod dbg-awake ((ap ix-view)) (and (dbg-awake-num ap 'px) (dbg-awake-num ap 'py) (dbg-awake-num ap 'll) @@ -230,11 +236,11 @@ ; ------------------- right-click ------------------------- -(defmethod make-menu-right-items ((self image)) +(defmethod make-menu-right-items ((self ix-view)) (bwhen (f (menu-right-items-factory self)) (funcall f self))) -(defmethod menu-right-select ((self image) item) +(defmethod menu-right-select ((self ix-view) item) (when item (bwhen (h (menu-select-handler self)) (funcall h self item)))) --- /project/cello/cvsroot/cello/ix-polygon.lisp 2006/06/05 01:47:49 1.2 +++ /project/cello/cvsroot/cello/ix-polygon.lisp 2006/06/26 17:05:20 1.3 @@ -17,7 +17,7 @@ (in-package :cello) ;------------------------------------------------------------ -(defmodel ix-polygon (image) +(defmodel ix-polygon (ix-view) ((fore-color :initarg :fore-color :initform +black+ :accessor fore-color) (poly-style :initarg :poly-style :initform nil :accessor poly-style) (poly-thickness :initarg :poly-thickness :initform (u96ths 1) :accessor poly-thickness) --- /project/cello/cvsroot/cello/ix-styled.lisp 2006/06/05 01:47:49 1.4 +++ /project/cello/cvsroot/cello/ix-styled.lisp 2006/06/26 17:05:20 1.5 @@ -88,7 +88,7 @@ (with-layers (:rgba (^text-color))))))) -(defmethod ix-find-style ((self image) style-id) +(defmethod ix-find-style ((self ix-view) style-id) (or (find style-id (^gui-styles) :key 'id) (ix-find-style .parent style-id))) @@ -104,7 +104,7 @@ (unless (ftgl::ftgl-disp-ready-p font) (setf (ftgl::ftgl-disp-ready-p font) t) (ftgl::fgc-set-face-size (ftgl::ftgl-get-metrics-font font) - (ftgl::ftgl-size font) (ftgl::ftgl-target-res font))) + (round (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/06/11 13:32:24 1.5 +++ /project/cello/cvsroot/cello/ix-text.lisp 2006/06/26 17:05:20 1.6 @@ -21,7 +21,7 @@ (eval-when (compile load eval) (export '(ix-paint))) -(defmodel ix-text (ix-styled image) +(defmodel ix-text (ix-styled ix-view) ( (text$ :initform nil :initarg :text$ :accessor text$) @@ -73,7 +73,7 @@ (unless (ftgl::ftgl-disp-ready-p font) (setf (ftgl::ftgl-disp-ready-p font) t) (ftgl::fgc-set-face-size (ftgl::ftgl-get-metrics-font font) - (ftgl::ftgl-size font) (ftgl::ftgl-target-res font))) + (round (ftgl::ftgl-size font)) (ftgl::ftgl-target-res font))) (ix-string-width self (^display-text$))))) (defmacro alabel (text &rest key-arg-pairs) @@ -109,37 +109,6 @@ 0))) -(defmodel frame-rate-text (ix-text) - ((frame-rate :initarg :frame-rate :accessor frame-rate - :initform (c? (cons (now)(frame-ct .w.))))) - (:default-initargs - :style-id :button - :style (make-instance 'gui-style-ftgl - :id :button - :face *gui-style-button-face* - :sizes '(16 16 16 16 16) - :text-color +white+) - :inset (mkv2 (upts 2)(upts 0)) - ;;:lt 15 :lb -5 - :char-mask "999" - :text$ (let (last) - (c? (let ((this (^frame-rate))) - (prog1 - (cond - ((null last) - (setf last this) - "not yet") - ((> .5 (- (car this)(car last))) - .cache) - (t - (prog1 - (format nil "~3,1f" - (/ (- (cdr this) (cdr last)) - (- (car this) (car last)))) - (setf last this))) - ))))) - :lighting :off - :pre-layer (with-layers :off +red+ :on))) #+(or) (format nil "~3,1f" pi) --- /project/cello/cvsroot/cello/lighting.lisp 2006/06/11 13:32:24 1.4 +++ /project/cello/cvsroot/cello/lighting.lisp 2006/06/26 17:05:20 1.5 @@ -41,7 +41,7 @@ ;;---------------------------------------------- -(defmodel ix-lit-scene () ;; mix in with ix-family +(defmodel ogl-lit-scene () ;; mix in with ix-family ( (clear-rgba :cell nil :initarg :clear-rgba :initform nil :accessor clear-rgba) (light-model :initarg :light-model :initform (list (cons gl_light_model_ambient *dim*)) @@ -70,7 +70,7 @@ :diffuse *average* :specular *bright*))))) -(defmethod ix-paint :before ((self ix-lit-scene)) +(defmethod ix-paint :before ((self ogl-lit-scene)) (gl-enable gl_color_material) (when (eql :on (lighting self)) (trc nil "lighting on!" self) --- /project/cello/cvsroot/cello/nehe-06.lisp 2006/06/11 13:32:24 1.4 +++ /project/cello/cvsroot/cello/nehe-06.lisp 2006/06/26 17:05:20 1.5 @@ -24,7 +24,6 @@ (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) @@ -35,7 +34,7 @@ (mk-stack (:packing (c?pack-self)) (make-instance 'nehe06 :fm-parent *parent* - :width 400 :height 400 + :width 700 :height 500 :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" --- /project/cello/cvsroot/cello/slider.lisp 2006/06/05 01:47:49 1.3 +++ /project/cello/cvsroot/cello/slider.lisp 2006/06/26 17:05:20 1.4 @@ -16,7 +16,7 @@ (in-package :cello) -(defmodel ct-jumper (control image)()) +(defmodel ct-jumper (control ix-view)()) (defun ix-slider-jumper-action (self e) (slider-set .parent --- /project/cello/cvsroot/cello/window-callbacks.lisp 2006/06/11 13:32:24 1.5 +++ /project/cello/cvsroot/cello/window-callbacks.lisp 2006/06/26 17:05:20 1.6 @@ -16,37 +16,5 @@ (in-package :cello) -(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))))) -(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)) - (with-metrics (nil nil "ctk::togl-display-using-class") - (when (display-continuous self) - (trc nil "window-display > continuous specified so posting redisplay" self) - (ctk:togl-post-redisplay (ctk:togl-ptr self)))))) - -(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 (keyboard-modifiers ctk::.tkw) (mkv2 0 0)))) - -(defmethod do-cello-keydown (self k event) - (declare (ignorable self k event))) - -(defmethod do-cello-special-keydown :around (self k event) - (when self - (unless (call-next-method) - (do-cello-special-keydown .parent k event)))) - -(defmethod do-cello-special-keydown (self k event) - (declare (ignorable self k event))) --- /project/cello/cvsroot/cello/window-utilities.lisp 2006/06/11 13:32:24 1.5 +++ /project/cello/cvsroot/cello/window-utilities.lisp 2006/06/26 17:05:20 1.6 @@ -25,13 +25,13 @@ (defmethod do-double-click (self os-event &key) (declare (ignorable self os-event)) - ;;(trc "*** No special do-double-click for image, event:" self osEvent) + ;;(trc "*** No special do-double-click for ix-view, event:" self osEvent) nil) ; ------------------- right button -------------------------------------- (defun geo-dump (i) - (when (typep i 'image) + (when (typep i 'ix-view) (print (list :pxy (cons (px i)(py i)) :lt (lt i) :lb (lb i))) (geo-dump (fm-parent i)))) @@ -46,14 +46,14 @@ ;;(c-stop :inspecting) (inspect i)))))) -(defmethod do-right-button :around (image buttons wxwy) +(defmethod do-right-button :around (self buttons wxwy) (declare (ignorable buttons wxwy)) - (when image + (when self (or (call-next-method) - (do-right-button (fm-parent image) buttons wxwy)))) + (do-right-button (fm-parent self) buttons wxwy)))) -(defmethod do-right-button (image buttons wxwy) - (declare (ignorable image buttons wxwy))) +(defmethod do-right-button (self buttons wxwy) + (declare (ignorable self buttons wxwy))) (defmethod do-menu-right (self buttons wxwy) (declare (ignorable buttons self wxwy))) @@ -82,8 +82,8 @@ ; ---------------------- finding parts ------------------------------ -(defun mouseimage-control (w) - (fm-ascendant-if (mouse-image w) +(defun mouseview-control (w) + (fm-ascendant-if (mouse-view w) (lambda (node) (and (typep node 'control) (fully-enabled node))))) --- /project/cello/cvsroot/cello/cello-window.lisp 2006/06/26 17:05:20 NONE +++ /project/cello/cvsroot/cello/cello-window.lisp 2006/06/26 17:05:20 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*- #| Copyright (C) 2004 by Kenneth William Tilton This library is free software; you can redistribute it and/or modify it under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), known as the LLGPL. This library is distributed WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Lisp Lesser GNU Public License for more details. |# (in-package :cello) ;------------- Window --------------- ; (defmodel cello-window (celtk:window focuser) ;; control ogl-shared-resource-tender) ( ;;; (mouse-pos :initarg :mouse-pos :initform (c-in nil) :accessor mouse-pos) ;logical coords. Try to maintain for now. ;;; ;;; (mouse-view :initarg :mouse-view :accessor mouse-view ;;; :initform (c? (let ((mp (^mouse-pos))) ;;; (trc nil "mouseview sees pos" .w. mp) ;;; (when mp ;;; (eko (nil "mouseview >" self) ;;; (without-c-dependency ;;; (find-ix-under self mp))))))) ;;; ;;; (mouse-control :initarg :mouse-control :accessor mouse-control ;;; :initform (c? (bwhen (node (^mouse-view)) ;;; (eko (nil "possible mousecontrol" node) ;;; (fm-ascendant-if node #'fully-enabled))))) ;;; ;;; (mouse-cursor :initarg :mouse-cursor :initform nil :accessor mouse-cursor) ;;; ;;; (mouse-up-evt :cell :ephemeral :initarg :mouse-up-evt :initform (c-in nil) :accessor mouse-up-evt) ;;; (mouse-down-evt :cell :ephemeral :initarg :mouse-down-evt :initform (c-in nil) :accessor mouse-down-evt) ;;; (double-click? :initform (c-in nil) :accessor double-click?) ;;; ;;; (tick-count :initarg :tick-count :initform (c-in nil) :accessor tick-count) ;;; (tick-fine :initarg :tick-fine :initform (c-in nil) :accessor tick-fine) (gl-name-highest :cell nil :initarg :gl-name-highest :initform 0 :accessor gl-name-highest)) (:default-initargs :px 0 :py 0 ;;:gl-name (c-in nil) ;;:focus (c-in nil) :ll 0 :lt 0 :lr (c-in (scr2log 1100)) :lb (c-in (scr2log -800)) ;; :tick-count (c-in (os-tickcount)) :event-handler 'cello-window-event-handler )) (defmethod path ((self cello-window)) ".") (defmethod parent-path ((self cello-window)) "") (defmethod cello-window-event-handler (self xe) (declare (ignorable self)) (TRC nil "cello-window-event-handler" self (ctk::tk-event-type (ctk::xsv type xe)) ) ; ; this next bit is actually offered as a template. suggest users subclass cello-window, ; specialize cello-window-event-handler on that subclass, handle what you want else ; call-next-method. eventually some generic stuff will be landing in here. ; (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))) (defmethod context-cursor (other kbd-modifiers) (if (and other (fm-parent other)) (context-cursor (fm-parent other) kbd-modifiers) (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)))) ;------------------------------------------ (defmethod ix-selectable ((self cello-window)) t) --- /project/cello/cvsroot/cello/ix-opengl.lisp 2006/06/26 17:05:20 NONE +++ /project/cello/cvsroot/cello/ix-opengl.lisp 2006/06/26 17:05:20 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*- #| Copyright (C) 2004 by Kenneth William Tilton This library is free software; you can redistribute it and/or modify it under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), known as the LLGPL. This library is distributed WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Lisp Lesser GNU Public License for more details. |# (in-package :cello) (defgeneric ogl-dsp-list-prep (self) (:method-combination progn) (:documentation "Do stuff needed before render but not needed/wanted in display list")) (defmethod ogl-dsp-list-prep progn (self) (declare (ignore self)) (assert (not *ogl-listing-p*))) (defvar *ogl-shared-resource-tender*) (defclass ogl-shared-resource-tender () ((display-lists :initform nil :accessor display-lists) (quadrics :initform nil :accessor quadrics) (textures :initform nil :accessor textures))) (defmethod not-to-be :before ((self ogl-shared-resource-tender)) (loop for (nil . dl) in (display-lists self) do (gl-delete-lists dl 1) finally (setf (display-lists self) nil)) (loop for (nil . q) in (quadrics self) do (glu-delete-quadric q))) (defmethod ogl-shared-resource-tender ((self ogl-shared-resource-tender)) self) (defmethod ogl-shared-resource-tender (other) (c-break "ogl-shared-resource-tender undefined for ~a" other)) (defmethod ogl-node-window (other) (c-break "ogl-node-window undefined for ~a" other)) (define-symbol-macro .og. (or (ogl-context self) (setf (ogl-context self) (upper self ctk::togl)))) (defmodel ogl-node () ((ogl-context :cell nil :initform nil :accessor ogl-context) (dsp-list :initarg :dsp-list :accessor dsp-list :initform (c-formula (:lazy :until-asked) (assert (not *ogl-listing-p*)) (progn (ogl-dsp-list-prep self) (when (without-c-dependency (every 'dsp-list (kids self))) (let ((display-list-name (or .cache (gl-gen-lists 1))) (*ogl-shared-resource-tender* (ogl-shared-resource-tender self))) (gl-new-list display-list-name gl_compile) (trc nil "starting display list" display-list-name self) (let ((*ogl-listing-p* self) *selecting* *render-clip-l* *render-clip-r* *render-clip-t* *render-clip-b*) (with-metrics (nil nil "ix-paint" self) (ix-paint self))) (trc nil "finished display list" display-list-name self) (gl-end-list) (setf (redisplayp .og.) t) display-list-name))))) (gl-name :initarg :gl-name :initform nil :accessor gl-name))) (defun render (self) (let (*selecting* *render-clip-l* *render-clip-r* *render-clip-t* *render-clip-b*) (with-metrics (nil nil "ix-paint" self) (trc nil "render" self (^height)) (ix-paint self)))) (defmodel ogl-family () () (:default-initargs :gl-name (c? (incf (gl-name-highest .w.))) :clipped nil)) (defobserver dsp-list () (when old-value (gl-delete-lists old-value 1))) (defmethod not-to-be :after ((self ogl-node)) (bwhen (dl (slot-value self 'dsp-list)) ;; don't trigger lazy cell (gl-delete-lists dl 1))) --- /project/cello/cvsroot/cello/ix-paint.lisp 2006/06/26 17:05:20 NONE +++ /project/cello/cvsroot/cello/ix-paint.lisp 2006/06/26 17:05:20 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*- #| Copyright (C) 2004 by Kenneth William Tilton This library is free software; you can redistribute it and/or modify it under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), known as the LLGPL. This library is distributed WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Lisp Lesser GNU Public License for more details. |# (in-package :cello) (defmethod ix-paint :after ((self family)) (dolist (k (kids self)) (trc nil "ixr geo" k (list (px k)(py k)) (list (ll k)(lt k)(lr k)(lb k))) (trc nil "render kid pxy" k (px k)(py k) :rpos-before (ogl-get-boolean gl_current_raster_position_valid) (ogl-raster-pos-get)) (c-assert (px k) () "pX is null in ~a" k) (c-assert (py k) () "pY is null in ~a" k) (count-it :call-list) (if (dsp-list k) (progn (trc nil "ix-paint calling list" (dsp-list k)) (gl-call-list (dsp-list k))) (ix-paint k)))) (defun rpchk (id pfail psucc &optional self) (declare (ignorable pfail)) (if (not (ogl-get-boolean gl_current_raster_position_valid)) (trc nil "rasterpos INVALID" id :self self :rpos (ogl-raster-pos-get)) (trc psucc "rasterpos OK" id :self self (ogl-raster-pos-get)))) (defmethod ix-paint (self) (declare (ignorable self)) (trc nil "ix-paint fell through" self (class-of self))) (defmacro with-ogl-isolation (&body body) `(with-attrib (gl_lighting_bit gl_texture_bit gl_enable_bit gl_hint_bit gl_line_bit gl_color_buffer_bit) , at body)) (let ((ixr-box (mkr 0 0 0 0))) (defmethod ix-paint :around ((self ix-view) &aux (n (gl-name self))) (trc nil "painting, shifting bitmap" self n (^px)(^py) (pre-layer self)) (with-bitmap-shifted ((px self)(py self)) (gl-translatef (px self) (py self) 0) (when n (trc "pushing gl-name" self n) (gl-push-name n)) (rpchk 'ix-paint t nil self) (when (and (not (c-stopped)) (or (not *selecting*) (ix-selectable self)) (visible self) (not (collapsed self))) (progn ;;with-clipping (self) (progn ;; with-attrib (gl_lighting_bit gl_texture_bit gl_enable_bit gl_hint_bit gl_line_bit gl_color_buffer_bit) (count-it :ix-render) #+(or) (count-it :ix-paint (type-of self)) #+(or) (unless (kids self) (count-it :ix-render-atom)) (trc nil "ix painting" self (lighting self)) (with-matrix () (with-ogl-isolation (case (lighting self) ;; default is "same as parent" (:on (gl-enable gl_lighting)) (:off (gl-disable gl_lighting))) (gl-enable gl_color_material) (bif (pre-layer (pre-layer self)) (progn (assert (functionp pre-layer)) (count-it :pre-layer) (nr-make ixr-box (ll self) (lt self) (lr self) (lb self)) (funcall pre-layer self ixr-box :before) (call-next-method self) (funcall pre-layer self ixr-box :after)) (call-next-method self))))))) (gl-translatef (- (px self)) (- (py self)) 0)) (when n (gl-pop-name)))) (defmethod ix-render-layer ((nada null) g-box) (break "NIL layer detected" g-box)) (defmethod ix-render-layer :around (key g-box) (declare (ignore g-box)) (count-it :render-layer) (count-it :render-layer (type-of key)) (call-next-method)) ;------------------- --- /project/cello/cvsroot/cello/ix-togl.lisp 2006/06/26 17:05:20 NONE +++ /project/cello/cvsroot/cello/ix-togl.lisp 2006/06/26 17:05:20 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*- #| Copyright (C) 2004 by Kenneth William Tilton This library is free software; you can redistribute it and/or modify it under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), known as the LLGPL. This library is distributed WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Lisp Lesser GNU Public License for more details. |# (in-package :cello) (eval-when (compile load eval) (export '(ix-togl-event-handler))) ;------------- Window --------------- ; (defmodel ix-togl ( #+not focuser ogl-lit-scene control ogl-shared-resource-tender togl ix-view) ( (redisplayp :cell nil :initarg :redisplayp :initform nil :accessor redisplayp) (display-continuous :initarg :display-continuous :initform nil :accessor display-continuous) (activep :initarg :activep :initform nil :accessor activep) (mouse-pos :initarg :mouse-pos :initform (c-in nil) :accessor mouse-pos) ;logical coords. Try to maintain for now. (mouse-view :initarg :mouse-view :accessor mouse-view :initform (c? (let ((mp (^mouse-pos))) (trc nil "mouseview sees pos" .w. mp) (when mp (eko (nil "mouseview >" self) (without-c-dependency (find-ix-under self mp))))))) (mouse-control :initarg :mouse-control :accessor mouse-control :initform (c? (bwhen (node (^mouse-view)) (eko (nil "possible mousecontrol" node) (fm-ascendant-if node #'fully-enabled))))) (mouse-up-evt :cell :ephemeral :initarg :mouse-up-evt :initform (c-in nil) :accessor mouse-up-evt) (mouse-down-evt :cell :ephemeral :initarg :mouse-down-evt :initform (c-in nil) :accessor mouse-down-evt) (double-click? :initform (c-in nil) :accessor double-click?) (tick-count :initarg :tick-count :initform (c-in nil) :accessor tick-count) (tick-fine :initarg :tick-fine :initform (c-in nil) :accessor tick-fine) ) (:default-initargs :px 0 :py 0 :gl-name (c-in nil) :activep (c-in nil) :clear-rgba (list 0 0 0 1) :ll 0 :lt 0 :lr (c-in (scr2log 1100)) [257 lines skipped] From ktilton at common-lisp.net Mon Jun 26 17:05:21 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 26 Jun 2006 13:05:21 -0400 (EDT) Subject: [cello-cvs] CVS cello/cellodemo Message-ID: <20060626170521.4F9E617034@common-lisp.net> Update of /project/cello/cvsroot/cello/cellodemo In directory clnet:/tmp/cvs-serv15578/cellodemo Modified Files: demo-window.lisp light-panel.lisp tutor-geometry.lisp Log Message: Ongoing merge with Celtk --- /project/cello/cvsroot/cello/cellodemo/demo-window.lisp 2006/06/11 13:32:24 1.4 +++ /project/cello/cvsroot/cello/cellodemo/demo-window.lisp 2006/06/26 17:05:20 1.5 @@ -173,7 +173,7 @@ :lb (c? (downs (l-height .parent))) :kids (c? (the-kids (demo-window-beef) - (mk-part :cursor (image) + (mk-part :cursor (ix-view) :px (c? (bif (mpos (mouse-pos .w.)) (v2-h mpos) 100)) :py (c? (bif (mpos (mouse-pos .w.)) @@ -363,23 +363,23 @@ (defun starter-flag () (a-row (:lighting :off) - (mk-part :one (image) + (mk-part :one (ix-view) :ll (u8ths -2) :lt 0 :lr (u8ths 2) :lb (downs (u8ths 2)) :lighting nil :pre-layer (with-layers +red+ (:x-mark t))) (mk-part :canvasflag (ix-canvas-kid-sized) :target-res 96 :kids (the-kids - (mk-part :two (image) + (mk-part :two (ix-view) :px 0 :py 0 :ll (u8ths -2) :lt 0 :lr (u8ths 2) :lb (downs (u8ths 2)) - :bkg-color (c? (trc nil "s mi" self (mouse-image .w.) + :bkg-color (c? (trc nil "s mi" self (mouse-view .w.) (^mouse-over-p)) (if (^mouse-over-p) +black+ +blue+)) :pre-layer (with-layers (:rgba (^bkg-color)) :fill))) :pre-layer (with-layers +black+)) - (mk-part :tree (image) + (mk-part :tree (ix-view) :ll (u8ths -2) :lt 0 :lr (u8ths 2) :lb (downs (u8ths 2)) :pre-layer (with-layers +green+ :fill)) )) --- /project/cello/cvsroot/cello/cellodemo/light-panel.lisp 2006/06/11 13:32:24 1.4 +++ /project/cello/cvsroot/cello/cellodemo/light-panel.lisp 2006/06/26 17:05:20 1.5 @@ -27,7 +27,7 @@ (when old-value (fgn-free (rgba-fo old-value)))) -(defmodel hedron (ix-styled image) +(defmodel hedron (ix-styled ix-view) ((quadric :initform (c? (glu-new-quadric)) :reader quadric) (nurb :reader nurb :initform (c? (let ((nurb (glu-new-nurbs-renderer))) (assert (not (zerop nurb))) --- /project/cello/cvsroot/cello/cellodemo/tutor-geometry.lisp 2006/06/03 12:05:55 1.2 +++ /project/cello/cvsroot/cello/cellodemo/tutor-geometry.lisp 2006/06/26 17:05:20 1.3 @@ -30,7 +30,7 @@ (make-instance 'ix-zero-tl :md-name 'tu-geo :kids (c? (flet ((tu-box (name &rest deets) - (apply 'make-instance 'image + (apply 'make-instance 'ix-view :md-name name :lr (c? (^lr-width 125)) :lb (c? (^lb-height (downs 125))) From ktilton at common-lisp.net Mon Jun 26 17:05:21 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 26 Jun 2006 13:05:21 -0400 (EDT) Subject: [cello-cvs] CVS cello/cffi-extender Message-ID: <20060626170521.C20F518008@common-lisp.net> Update of /project/cello/cvsroot/cello/cffi-extender In directory clnet:/tmp/cvs-serv15578/cffi-extender Modified Files: cffi-extender.lpr Log Message: Ongoing merge with Celtk --- /project/cello/cvsroot/cello/cffi-extender/cffi-extender.lpr 2006/06/04 00:09:53 1.1 +++ /project/cello/cvsroot/cello/cffi-extender/cffi-extender.lpr 2006/06/26 17:05:21 1.2 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jun 21, 2006 9:54)"; cg: "1.81"; -*- (in-package :cg-user) From ktilton at common-lisp.net Mon Jun 26 17:05:22 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 26 Jun 2006 13:05:22 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-ftgl Message-ID: <20060626170522.6A9BC1B008@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-ftgl In directory clnet:/tmp/cvs-serv15578/cl-ftgl Modified Files: cl-ftgl.lisp cl-ftgl.lpr Log Message: Ongoing merge with Celtk --- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2006/06/03 12:05:55 1.3 +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2006/06/26 17:05:21 1.4 @@ -20,7 +20,7 @@ ;;; 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.3 2006/06/03 12:05:55 ktilton Exp $ +;;; $Header: /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp,v 1.4 2006/06/26 17:05:21 ktilton Exp $ (defpackage #:cl-ftgl (:nicknames #:ftgl) @@ -33,8 +33,10 @@ #:ftgl-extruded #:ftgl-outline #:ftgl-string-length + #:ftgl-char-width #:ftgl-get-ascender #:ftgl-get-descender + #:ftgl-height #:ftgl-make #:cl-ftgl-init #:cl-ftgl-reset @@ -160,17 +162,25 @@ (:polygon 'make-ftgl-polygon) (:extruded 'make-ftgl-extruded)) :face face - :size size + :size (floor size) :target-res target-res :depth depth)) + ;; --------- ftgl structure ----------------- (defstruct ftgl face size target-res depth - descender ascender bboxes + descender ascender + (widths (make-array 256)) + ft-metrics ifont) +(defun ftgl-char-width (f c) + (or (aref (ftgl-widths f) (char-code c)) + (setf (aref (ftgl-widths f) (char-code c)) + (ftgl-string-length f (string c))))) + (defstruct (ftgl-disp (:include ftgl)) ready-p) @@ -204,6 +214,9 @@ (ff:unload-foreign-library dll) (cl-ftgl-reset)))) +#+doit +(xftgl) + (defun ftgl-get-ascender (font) (or (ftgl-ascender font) (setf (ftgl-ascender font) @@ -214,6 +227,10 @@ (setf (ftgl-descender font) (fgc-descender (ftgl-get-metrics-font font))))) +(defun ftgl-height (f) + (+ (ftgl-get-ascender f) + (ftgl-get-descender f))) + (defun ftgl-get-display-font (font) (let ((cf (ftgl-get-metrics-font font))) (assert cf) @@ -297,9 +314,6 @@ (defun ftgl-string-length (font cs) (fgc-string-advance (ftgl-get-metrics-font font) cs)) -(defmethod font-bearing-x ((font ftgl) &optional (text "m")) - (fgc-string-x (ftgl-get-metrics-font font) text)) - (defmethod font-bearing-x (font &optional text) (declare (ignorable font text)) 0) --- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2006/05/26 22:08:55 1.4 +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2006/06/26 17:05:21 1.5 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jun 21, 2006 9:54)"; cg: "1.81"; -*- (in-package :cg-user) @@ -7,7 +7,9 @@ (define-project :name :cl-ftgl :modules (list (make-instance 'module :name "cl-ftgl.lisp")) :projects (list (make-instance 'project-module :name - "C:\\1-devtools\\cffi\\cffi")) + "C:\\1-devtools\\cffi\\cffi") + (make-instance 'project-module :name + "..\\cl-freetype\\cl-freetype")) :libraries nil :distributed-files nil :internally-loaded-files nil From ktilton at common-lisp.net Mon Jun 26 17:05:32 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 26 Jun 2006 13:05:32 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-magick Message-ID: <20060626170532.E71671D0F7@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-magick In directory clnet:/tmp/cvs-serv15578/cl-magick Modified Files: cl-magick.lisp cl-magick.lpr wand-texture.lisp Log Message: Ongoing merge with Celtk --- /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2006/05/27 06:01:38 1.3 +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2006/06/26 17:05:22 1.4 @@ -24,6 +24,7 @@ (:nicknames :mgk) (:use #:common-lisp + #:gui-geometry #-(or cormanlisp ccl) #:clos #:cffi #:cffi-extender --- /project/cello/cvsroot/cello/cl-magick/cl-magick.lpr 2006/05/26 22:08:56 1.2 +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lpr 2006/06/26 17:05:22 1.3 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jun 21, 2006 9:54)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cello/cvsroot/cello/cl-magick/wand-texture.lisp 2006/05/26 22:08:56 1.2 +++ /project/cello/cvsroot/cello/cl-magick/wand-texture.lisp 2006/06/26 17:05:22 1.3 @@ -92,7 +92,7 @@ ;;(print `(wand-image-to-texture loaded texture sized ,(image-size self))) (fgn-free pixels) - tx)) + tx)) (defmethod wand-render ((self wand-texture) left top right bottom &aux (sz (image-size self))) From ktilton at common-lisp.net Mon Jun 26 17:05:33 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 26 Jun 2006 13:05:33 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-openal Message-ID: <20060626170533.9C7DC1E00B@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-openal In directory clnet:/tmp/cvs-serv15578/cl-openal Modified Files: cl-openal.lpr Log Message: Ongoing merge with Celtk --- /project/cello/cvsroot/cello/cl-openal/cl-openal.lpr 2006/05/27 06:01:38 1.4 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal.lpr 2006/06/26 17:05:33 1.5 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jun 21, 2006 9:54)"; cg: "1.81"; -*- (in-package :cg-user) From ktilton at common-lisp.net Mon Jun 26 17:05:34 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 26 Jun 2006 13:05:34 -0400 (EDT) Subject: [cello-cvs] CVS cello/kt-opengl Message-ID: <20060626170534.1BB9D2001E@common-lisp.net> Update of /project/cello/cvsroot/cello/kt-opengl In directory clnet:/tmp/cvs-serv15578/kt-opengl Modified Files: kt-opengl.lpr ogl-macros.lisp Log Message: Ongoing merge with Celtk --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lpr 2006/05/27 06:01:39 1.1 +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lpr 2006/06/26 17:05:33 1.2 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jun 21, 2006 9:54)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cello/cvsroot/cello/kt-opengl/ogl-macros.lisp 2006/06/11 13:32:25 1.2 +++ /project/cello/cvsroot/cello/kt-opengl/ogl-macros.lisp 2006/06/26 17:05:33 1.3 @@ -113,6 +113,19 @@ (gl-end) (glec :with-gl-begun)))) +(defmacro with-gensyms ((&rest syms) &body body) + `(let ,(loop for sym in syms + collecting `(,sym (gensym))) + , at body)) + +(defmacro with-gl-translation ((dxf dyf &optional (dzf 0)) &body body) + (with-gensyms (dx dy dz) + `(let ((,dx ,dxf)(,dy ,dyf)(,dz ,dzf)) + (gl-translatef ,dx ,dy ,dz) + (prog1 + , at body + (gl-translatef (- ,dx)(- ,dy)(- ,dz)))))) + (defun kt-opengl-init () (declare (ignorable load-oglfont-p)) (unless *opengl-dll* From ktilton at common-lisp.net Mon Jun 26 17:10:29 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 26 Jun 2006 13:10:29 -0400 (EDT) Subject: [cello-cvs] CVS cello Message-ID: <20060626171029.24D4C1005@common-lisp.net> Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv16113 Removed Files: window-callbacks.lisp Log Message: From ktilton at common-lisp.net Thu Jun 29 09:55:59 2006 From: ktilton at common-lisp.net (ktilton) Date: Thu, 29 Jun 2006 05:55:59 -0400 (EDT) Subject: [cello-cvs] CVS hello-cffi Message-ID: <20060629095559.11B3064101@common-lisp.net> Update of /project/cello/cvsroot/hello-cffi In directory clnet:/tmp/cvs-serv28528 Modified Files: callbacks.lisp hello-cffi.lpr Log Message: --- /project/cello/cvsroot/hello-cffi/callbacks.lisp 2006/05/17 04:29:42 1.1 +++ /project/cello/cvsroot/hello-cffi/callbacks.lisp 2006/06/29 09:55:58 1.2 @@ -23,18 +23,6 @@ (in-package :ffx) - -#+precffi -(defun ff-register-callable (callback-name) - #+allegro - (ff:register-foreign-callable callback-name) - #+lispworks - (let ((cb (progn ;; fli:pointer-address - (fli:make-pointer :symbol-name (symbol-name callback-name) ;; leak? - :functionp t)))) - (print (list :ff-register-callable-returns cb)) - cb)) - (defun ff-register-callable (callback-name) (let ((known-callback (cffi:get-callback callback-name))) (assert known-callback) --- /project/cello/cvsroot/hello-cffi/hello-cffi.lpr 2006/05/17 04:29:42 1.1 +++ /project/cello/cvsroot/hello-cffi/hello-cffi.lpr 2006/06/29 09:55:59 1.2 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (May 5, 2006 15:39)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (May 11, 2006 6:29)"; cg: "1.81"; -*- (in-package :cg-user) @@ -11,7 +11,7 @@ (make-instance 'module :name "arrays.lisp") (make-instance 'module :name "callbacks.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