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

[cello-cvs] CVS cello
by ktilton 28 Oct '06

28 Oct '06

Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv3711 Modified Files: cello.asd control.lisp ctl-markbox.lisp ctl-toggle.lisp ix-layer-expand.lisp ix-polygon.lisp ix-togl.lisp Log Message: Cello rizing. --- /project/cello/cvsroot/cello/cello.asd 2006/08/26 16:04:46 1.5 +++ /project/cello/cvsroot/cello/cello.asd 2006/10/28 18:22:43 1.6 @@ -30,7 +30,6 @@ (:file "image") (:file "ix-opengl") (:file "ix-canvas") - (:file "ix-family") (:file "font") (:file "ix-grid") (:file "mouse-click") --- /project/cello/cvsroot/cello/control.lisp 2006/10/13 05:57:27 1.6 +++ /project/cello/cvsroot/cello/control.lisp 2006/10/28 18:22:43 1.7 @@ -15,7 +15,7 @@ |# (in-package :cello) - +(export! control enabled ^enabled) (defmd control () (title$ (c? (format nil "~:(~a~)" ;; this is just a poor default-- really s.b. supplied by form author (string-downcase (substitute #\space #\- (string (md-name self))))))) --- /project/cello/cvsroot/cello/ctl-markbox.lisp 2006/10/17 21:30:08 1.8 +++ /project/cello/cvsroot/cello/ctl-markbox.lisp 2006/10/28 18:22:43 1.9 @@ -20,7 +20,7 @@ (eval-now! (defmethod ix-layer-expand ((self (eql :x-mark)) &rest args) - `(ix-render-x-mark ,(car args) l-box))) + `(ix-render-x-mark ,(car args) l-box ,(cadr args)))) (defmodel ct-mark-box (ct-toggle ix-view) ((kb-selector :cell nil :initarg :kb-selector :initform nil :reader kb-selector) @@ -35,23 +35,22 @@ (:in 4) +light-gray+ ;;;(if (^enabled) +white+ +gray+) :off - (:frame-3d :edge-sunken - :thickness 4) + (:frame-3d :edge-sunken :thickness 4) :off +dark-gray+ (:out 4) (:x-mark (^md-value))))) -(defun ix-render-x-mark (do-p lbox) +(defun ix-render-x-mark (do-p lbox &optional thickness &aux (thick (or thickness (/ (r-width lbox) 4)))) (when do-p - (let* ((thick (/ (r-width lbox) 4)) + (let* ( (br (- (r-right lbox) thick)) ;; /// bogus use of thick to inset "x" (bl (+ (r-left lbox) thick)) (bt (+ (r-top lbox) (downs thick))) (bb (+ (r-bottom lbox) (ups thick))) ) (with-matrix () - (gl-line-width (max 2 (log2scr thick))) + (gl-line-width (log2scr thick)) (gl-disable gl_texture_2d) (with-gl-begun (gl_lines) (gl-vertex3f bl bt 0)(gl-vertex3f br bb 0) @@ -68,8 +67,8 @@ :enabled t :md-value (c? (find (associated-value self) (md-value (^radio)))) :ct-action (lambda (self event) - (radio-item-to-md-value self event (^radio))))) - + (with-c-change :ct-radio-item + (radio-item-to-md-value self event (^radio)))))) (defun radio-item-to-md-value (self event radio) @@ -87,10 +86,14 @@ (defmodel ct-radio-button (ct-mark-box ct-radio-item) ()) (defmodel ct-text-radio-item ( ct-radio-item ct-text)()) -(defmodel ct-radio (ix-inline) - () - (:default-initargs - :md-value (c-in nil))) +(defmd ct-radio (ix-inline) + on-change + :md-value (c-in nil)) + +(defobserver .md-value ((self ct-radio)) ;; /// should every control have this? + (when (^on-change) + (trcx nil radio-value-observer self new-value old-value old-value-boundp) + (funcall (^on-change) self new-value old-value old-value-boundp))) (defmodel ct-radio-row (ct-radio) () --- /project/cello/cvsroot/cello/ctl-toggle.lisp 2006/10/17 21:30:08 1.6 +++ /project/cello/cvsroot/cello/ctl-toggle.lisp 2006/10/28 18:22:43 1.7 @@ -138,6 +138,7 @@ :md-value (c-in nil) ;;; closed by default :poly-style :fill :pre-layer (c? (with-layers + (:poly-mode gl_front_and_back gl_fill) (:rgba (if (^hilited) +green+ +black+)))) :vertices (c? (if (md-value self) @@ -145,6 +146,27 @@ '((4 . -2) (9 . -7) (4 . -12)))) :ll 0 :lt 0 :lr (u96ths 15) :lb (downs (u96ths 15)))) +(export! a-twister) + +(defmacro a-twister ((label component-args initial-open &rest twister-args) twisted-widget) + `(a-stack (,@component-args) + (a-row () + (make-kid 'ct-twister + :md-name :show-contents + :md-value (c-in ,initial-open) + :visible (c? (^enabled)) + ,@twister-args) + ,(if (stringp label) + `(make-kid 'ix-text + :text$ ,label + :style-id :button) + label)) ;; actually should be a form to build a widget + (a-stack (:collapsed (c? (let ((tw (fm^ :show-contents))) + (assert (eq .parent (fm-parent (fm-parent tw)))) + (not (md-value tw))))) + ,twisted-widget))) + +#| vestigial? (defmacro mk-twisted (twisted-name (label-class &rest label-args) (twisted-class &rest twisted-args)) @@ -193,3 +215,4 @@ ,twisted-part )))) +|# \ No newline at end of file --- /project/cello/cvsroot/cello/ix-layer-expand.lisp 2006/10/17 21:30:08 1.8 +++ /project/cello/cvsroot/cello/ix-layer-expand.lisp 2006/10/28 18:22:43 1.9 @@ -113,7 +113,7 @@ `(gl-disable ,gl)))) (defmethod ix-layer-expand ((self (eql :poly-mode)) &rest args) - `(gl-polygon-mode ,(car args),(cadr args))) + `(gl-polygon-mode ,(car args) ,(cadr args))) (defmethod ix-layer-expand ((self (eql :nice-lines)) &rest args) `(progn @@ -123,7 +123,7 @@ (gl-enable gl_blend) (gl-blend-func gl_src_alpha gl_one_minus_src_alpha) ,(when args - `(gl-line-width ,(car args))))) + `(gl-line-width ,(or (car args) 1))))) --- /project/cello/cvsroot/cello/ix-polygon.lisp 2006/10/13 05:57:27 1.4 +++ /project/cello/cvsroot/cello/ix-polygon.lisp 2006/10/28 18:22:43 1.5 @@ -35,7 +35,8 @@ (with-matrix (nil) (gl-line-width (poly-thickness self)) - (with-gl-begun (gl_line_loop) + (gl-polygon-mode gl_front_and_back gl_fill) + (with-gl-begun (gl_triangles) (dolist (v vs) (gl-vertex3f (v2-h v) (v2-v v) 0))) (ogl::glec :f3d)))))) --- /project/cello/cvsroot/cello/ix-togl.lisp 2006/10/17 21:30:08 1.13 +++ /project/cello/cvsroot/cello/ix-togl.lisp 2006/10/28 18:22:43 1.14 @@ -99,7 +99,7 @@ (:ButtonPress (setf (mouse-pos self) (mkv2 (ctk::xbe-x xe) (- (ctk::xbe-y xe)))) ; trigger mouseview recalc - (setf (mouse-down-evt self) (eko ("mousedown!!!" (ctk::xbe button xe)) + (setf (mouse-down-evt self) (eko (nil "mousedown!!!" (ctk::xbe button xe)) (make-os-event :modifiers (keyboard-modifiers .tkw) :where (mouse-pos self)

1 0

[cello-cvs] CVS cello/cffi-extender
by ktilton 28 Oct '06

28 Oct '06

Update of /project/cello/cvsroot/cello/cffi-extender In directory clnet:/tmp/cvs-serv3711/cffi-extender Modified Files: cffi-extender.lpr Log Message: Cello rizing. --- /project/cello/cvsroot/cello/cffi-extender/cffi-extender.lpr 2006/08/31 17:34:47 1.5 +++ /project/cello/cvsroot/cello/cffi-extender/cffi-extender.lpr 2006/10/28 18:22:43 1.6 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- (in-package :cg-user)

1 0

[cello-cvs] CVS cello/kt-opengl
by ktilton 17 Oct '06

17 Oct '06

Update of /project/cello/cvsroot/cello/kt-opengl In directory clnet:/tmp/cvs-serv6473/kt-opengl Modified Files: colors.lisp Log Message: --- /project/cello/cvsroot/cello/kt-opengl/colors.lisp 2006/10/02 03:55:23 1.5 +++ /project/cello/cvsroot/cello/kt-opengl/colors.lisp 2006/10/17 21:30:08 1.6 @@ -20,7 +20,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; -;;; $Id: colors.lisp,v 1.5 2006/10/02 03:55:23 ktilton Exp $ +;;; $Id: colors.lisp,v 1.6 2006/10/17 21:30:08 ktilton Exp $ (in-package #:kt-opengl) @@ -234,13 +234,11 @@ (define-ogl-rgba-color +DARK-GREEN+ 0 128 0 255) (define-ogl-rgba-color +DARK-BLUE+ 0 0 64 50) (define-ogl-rgba-color +DARK-GRAY+ 64 64 64 255) -(define-ogl-rgba-color +DK-GRAY+ 64 64 64 255) (define-ogl-rgba-color +LIGHT-BLUE+ 127 127 255 255) (define-ogl-rgba-color +YELLOW+ 255 255 127 255) (define-ogl-rgba-color +LIGHT-YELLOW+ 255 255 127 255) (define-ogl-rgba-color +LIGHT-GRAY+ 192 192 192 255) -(define-ogl-rgba-color +LT-GRAY+ 192 192 192 255) ;;; PANTONE colors as defined by graphics design s/w Art Director's Toolkit V.5

1 0

[cello-cvs] CVS cello
by ktilton 17 Oct '06

17 Oct '06

Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv6473 Modified Files: cello-window.lisp cello.lisp cello.lpr ctl-markbox.lisp ctl-toggle.lisp frame.lisp image.lisp ix-canvas.lisp ix-layer-expand.lisp ix-opengl.lisp ix-styled.lisp ix-text.lisp ix-togl.lisp slider.lisp window-utilities.lisp wm-mouse.lisp Removed Files: ix-family.lisp Log Message: --- /project/cello/cvsroot/cello/cello-window.lisp 2006/08/26 21:43:36 1.5 +++ /project/cello/cvsroot/cello/cello-window.lisp 2006/10/17 21:30:08 1.6 @@ -38,8 +38,8 @@ (defmethod path ((self cello-window)) ".") (defmethod parent-path ((self cello-window)) "") -(defmethod g-offset ((self cello-window) &optional (accum-h 0) (accum-v 0)) - (declare (ignorable self)) +(defmethod g-offset ((self cello-window) &optional (accum-h 0) (accum-v 0) within) + (declare (ignorable self within)) (mkv2 accum-h accum-v)) (defmethod cello-window-event-handler (self xe) --- /project/cello/cvsroot/cello/cello.lisp 2006/10/01 20:41:53 1.13 +++ /project/cello/cvsroot/cello/cello.lisp 2006/10/17 21:30:08 1.14 @@ -15,7 +15,7 @@ |# -;;; $Id: cello.lisp,v 1.13 2006/10/01 20:41:53 fgoenninger Exp $ +;;; $Id: cello.lisp,v 1.14 2006/10/17 21:30:08 ktilton Exp $ ;;; ============================================================================ @@ -67,11 +67,25 @@ #:ix-togl)) +(in-package :cello) + +;;; --- macros ----------------------------------------- +(export! .togl .og. .ogc. .retog.) + +(define-symbol-macro .togl (nearest self ix-togl)) + +(define-symbol-macro .og. + (or (ogl-context self) + (setf (ogl-context self) (nearest self ctk::togl)))) + +(define-symbol-macro .ogc. (togl-ptr .og.)) +(define-symbol-macro .retog. (when .ogc. (togl-post-redisplay .ogc.))) + ;;; ============================================================================ ;;; MISC ;;; ============================================================================ -(in-package :cello) + (defmodel c-button (geometer ctk:button) () --- /project/cello/cvsroot/cello/cello.lpr 2006/09/05 18:43:56 1.13 +++ /project/cello/cvsroot/cello/cello.lpr 2006/10/17 21:30:08 1.14 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- (in-package :cg-user) @@ -13,9 +13,9 @@ (make-instance 'module :name "frame.lisp") (make-instance 'module :name "application.lisp") (make-instance 'module :name "image.lisp") + (make-instance 'module :name "ix-togl.lisp") (make-instance 'module :name "ix-opengl.lisp") (make-instance 'module :name "ix-canvas.lisp") - (make-instance 'module :name "ix-family.lisp") (make-instance 'module :name "font.lisp") (make-instance 'module :name "ix-grid.lisp") (make-instance 'module :name "mouse-click.lisp") @@ -25,7 +25,6 @@ (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 "ix-togl.lisp") (make-instance 'module :name "lighting.lisp") (make-instance 'module :name "ctl-toggle.lisp") (make-instance 'module :name "ctl-markbox.lisp") --- /project/cello/cvsroot/cello/ctl-markbox.lisp 2006/10/02 02:59:18 1.7 +++ /project/cello/cvsroot/cello/ctl-markbox.lisp 2006/10/17 21:30:08 1.8 @@ -33,12 +33,12 @@ :skin nil ;;(c? (skin .w.)) :pre-layer (with-layers (:in 4) - +lt-gray+ ;;;(if (^enabled) +white+ +gray+) + +light-gray+ ;;;(if (^enabled) +white+ +gray+) :off (:frame-3d :edge-sunken :thickness 4) :off - +dk-gray+ + +dark-gray+ (:out 4) (:x-mark (^md-value))))) --- /project/cello/cvsroot/cello/ctl-toggle.lisp 2006/10/13 05:57:27 1.5 +++ /project/cello/cvsroot/cello/ctl-toggle.lisp 2006/10/17 21:30:08 1.6 @@ -28,7 +28,7 @@ :text-color (c? (if (^enabled) (if (^mouse-over-p) +green+ +black+) - +lt-gray+)) + +light-gray+)) :pre-layer (with-layers :off +white+ :fill (:rgba (^text-color))))) @@ -51,7 +51,7 @@ :skin (c? (skin .w.)) :text-color (c? (cond ((not (^enabled)) +red+) - ((^depressed) +dk-gray+) + ((^depressed) +dark-gray+) (t +white+))) :pre-layer (c? (let* ((thick (min (u96ths 4) (* 0.08 (l-width self)))) (defl (if (clo::^depressed) (downs (/ thick 3)) 0)) @@ -77,7 +77,7 @@ (with-layers (:v3f (/ defl 2) defl push-in) - +lt-gray+ + +light-gray+ :on (:frame-3d :edge-raised :thickness thick) --- /project/cello/cvsroot/cello/frame.lisp 2006/10/02 02:59:18 1.4 +++ /project/cello/cvsroot/cello/frame.lisp 2006/10/17 21:30:08 1.5 @@ -121,6 +121,7 @@ (gl-vertex3f inr inb inz))) (flet ((render () (gl-translatef 0 0 (xlout thick)) + (gl-enable gl_lighting) (with-gl-begun (gl_quads) ;; top (cgl-normal :top @@ -151,13 +152,16 @@ (vrbi)(vrbo)(vrto)(vrti) ;; front - (cgl-normal :front - (- outr in) (+ outb (ups in)) inz - (- outr in) (+ outt (downs in)) inz - (+ outl in) (+ outt (downs in)) inz - ) - (vrti)(vlti)(vlbi)(vrbi) + #+nahhh ;; we're just doing the frame! + (progn + (cgl-normal :front + (- outr in) (+ outb (ups in)) inz + (- outr in) (+ outt (downs in)) inz + (+ outl in) (+ outt (downs in)) inz + ) + + (vrti)(vlti)(vlbi)(vrbi)) ) (gl-translatef 0 0 (xlout thick)))) --- /project/cello/cvsroot/cello/image.lisp 2006/10/13 05:57:27 1.14 +++ /project/cello/cvsroot/cello/image.lisp 2006/10/17 21:30:08 1.15 @@ -17,7 +17,9 @@ (in-package :cello) (eval-when (compile load eval) - (export '(mouse-over-p ix-view ix-stack ix-row ix-stack-lazy ix-row-lazy a-stack a-row a-stack-lazy a-row-lazy ^visible))) + (export '(mouse-over-p ix-view ix-stack ix-row ix-stack-lazy ix-row-lazy + a-stack a-row a-stack-lazy a-row-lazy ^visible + skin ^skin))) ; ------------------------------------------------------ (defmodel ogl-quadric-based (ogl-node) @@ -84,7 +86,11 @@ (defmodel ix-zero-tl (geo-zero-tl ix-family)()) (defmodel ix-kid-sized (geo-kid-sized ix-family)()) (defmodel ix-inline (geo-inline ix-view)()) +(defobserver .kids ((self ix-inline)) + (when .togl .retog.)) (defmodel ix-inline-lazy (geo-inline-lazy ix-view)()) +(defobserver .kids ((self ix-inline-lazy)) + (when .togl .retog.)) (defmodel ix-stack (ix-inline) () @@ -106,6 +112,9 @@ (:default-initargs :orientation :horizontal)) +(eval-now! + (export '(a-stack a-row))) + (defmacro a-stack ((&rest stack-args) &body dd-kids) `(mk-part ,(gensym "STAK") (ix-stack) ,@stack-args @@ -185,7 +194,6 @@ (v2 (v2-h v)) (ix-view (inset-h (inset v))))) - (defun inset-v (v) (etypecase v (number v) @@ -201,13 +209,14 @@ (setf (px self) (v2-h new-offset)) (setf (py self) (v2-v new-offset))) -(defmethod g-offset ((self ix-view) &optional (accum-h 0) (accum-v 0)) + +(defmethod g-offset ((self ix-view) &optional (accum-h 0) (accum-v 0) within) (trc nil "goffset self" self 'px (px self) 'py (py self) 'fm-parent (fm-parent self)) (let ( (oh (+ accum-h (or (px self) 0))) (ov (+ accum-v (or (py self) 0))) ) - (if (null (fm-parent self)) + (if (eq within (fm-parent self)) ;; if within is nil we simply goto null parent (mkv2 oh ov) (g-offset (fm-parent self) oh ov)))) --- /project/cello/cvsroot/cello/ix-canvas.lisp 2006/07/06 22:09:10 1.4 +++ /project/cello/cvsroot/cello/ix-canvas.lisp 2006/10/17 21:30:08 1.5 @@ -133,14 +133,15 @@ ;------------------------------------------- -(defmethod g-offset ((self ix-canvas) &optional (accum-h 0) (accum-v 0)) +(defmethod g-offset ((self ix-canvas) &optional (accum-h 0) (accum-v 0) within) ;(trc "goffset self" self 'px (px self) 'py (py self) 'fm-parent (fm-parent self)) (if (fm-parent self) (g-offset (fm-parent self) (+ (res-to-res accum-h (target-res self) (enclosing-res self)) (or (px self) 0)) (+ (res-to-res accum-v (target-res self) (enclosing-res self)) - (or (py self) 0))) + (or (py self) 0)) + within) (mkv2 accum-h accum-v))) (defmodel ix-root (ix-family) --- /project/cello/cvsroot/cello/ix-layer-expand.lisp 2006/07/24 05:00:35 1.7 +++ /project/cello/cvsroot/cello/ix-layer-expand.lisp 2006/10/17 21:30:08 1.8 @@ -35,16 +35,16 @@ (def-layer-expansion +dark-green+) (def-layer-expansion +green+) (def-layer-expansion +turquoise+) -(def-layer-expansion +dk-blue+) +(def-layer-expansion +dark-blue+) (def-layer-expansion +blue+) -(def-layer-expansion +lt-blue+) +(def-layer-expansion +light-blue+) (def-layer-expansion +black+) (def-layer-expansion +yellow+) -(def-layer-expansion +lt-yellow+) +(def-layer-expansion +light-yellow+) (def-layer-expansion +purple+) (def-layer-expansion +gray+) -(def-layer-expansion +lt-gray+) -(def-layer-expansion +dk-gray+) +(def-layer-expansion +light-gray+) +(def-layer-expansion +dark-gray+) (defmethod ix-layer-expand ((key (eql :fill)) &rest args) --- /project/cello/cvsroot/cello/ix-opengl.lisp 2006/10/13 05:57:27 1.8 +++ /project/cello/cvsroot/cello/ix-opengl.lisp 2006/10/17 21:30:08 1.9 @@ -51,15 +51,7 @@ (defmethod ogl-node-window (other) (c-break "ogl-node-window undefined for ~a" other)) - -(export! .og. .ogc. .retog.) - -(define-symbol-macro .og. - (or (ogl-context self) - (setf (ogl-context self) (nearest self ctk::togl)))) - -(define-symbol-macro .ogc. (togl-ptr .og.)) -(define-symbol-macro .retog. (when .ogc. (togl-post-redisplay .ogc.))) +(export! ogl-context) (defmodel ogl-node () ((ogl-context :cell nil :initform nil :accessor ogl-context) --- /project/cello/cvsroot/cello/ix-styled.lisp 2006/10/02 02:59:18 1.6 +++ /project/cello/cvsroot/cello/ix-styled.lisp 2006/10/17 21:30:08 1.7 @@ -16,7 +16,7 @@ (in-package :cello) -(eval-when (compile load execute) +(eval-when (:compile-toplevel :load-toplevel :execute) (export '(with-styles))) ;;; (defclass Helper () @@ -155,4 +155,4 @@ -|# \ No newline at end of file +|# --- /project/cello/cvsroot/cello/ix-text.lisp 2006/10/13 05:57:27 1.10 +++ /project/cello/cvsroot/cello/ix-text.lisp 2006/10/17 21:30:08 1.11 @@ -81,11 +81,13 @@ (round (ftgl::ftgl-size font)) (ftgl::ftgl-target-res font))) (ix-string-width self (^display-text$))))) -(defmacro alabel (text &rest key-arg-pairs) - `(cells::make-part (gensym "ALABEL") 'ix-text - ,@key-arg-pairs +(export! a-label) + +(defmacro a-label (text$ &rest key-arg-pairs) + `(make-kid 'ix-text + ,@key-arg-pairs :style-id :label - :text$ ,text)) + :text$ ,text$)) (defmethod display-text$ :around ((self ix-text)) (or (call-next-method) --- /project/cello/cvsroot/cello/ix-togl.lisp 2006/10/13 05:57:27 1.12 +++ /project/cello/cvsroot/cello/ix-togl.lisp 2006/10/17 21:30:08 1.13 @@ -69,10 +69,6 @@ :event-handler 'ix-togl-event-handler )) -(export! .togl) - -(define-symbol-macro .togl (nearest self ix-togl)) - (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)) @@ -103,11 +99,15 @@ (:ButtonPress (setf (mouse-pos self) (mkv2 (ctk::xbe-x xe) (- (ctk::xbe-y xe)))) ; trigger mouseview recalc - (setf (mouse-down-evt self) (eko (nil "mousedown!!!") + (setf (mouse-down-evt self) (eko ("mousedown!!!" (ctk::xbe button xe)) (make-os-event :modifiers (keyboard-modifiers .tkw) :where (mouse-pos self) - :realtime (now))))) + :realtime (now) + :c-event xe))) + (when (eql 3 (ctk::xbe button xe)) + (when (^mouse-view) + (inspect (^mouse-view))))) (:ButtonRelease (setf (mouse-pos self) (mkv2 (ctk::xbe-x xe) (- (ctk::xbe-y xe)))) ; trigger mouseview recalc @@ -115,7 +115,8 @@ (make-os-event :modifiers (keyboard-modifiers .tkw) :where (mouse-pos self) - :realtime (now))))) + :realtime (now) + :c-event xe)))) (:MotionNotify (trc nil "setting mouse pos!!!!" (ctk::xbe-x xe) (- (ctk::xbe-y xe))) --- /project/cello/cvsroot/cello/slider.lisp 2006/06/26 17:05:20 1.4 +++ /project/cello/cvsroot/cello/slider.lisp 2006/10/17 21:30:08 1.5 @@ -37,7 +37,7 @@ (thumb-layers :initarg :thumb-layers :accessor thumb-layers :initform (with-layers (:out 24) :on - +lt-gray+ + +light-gray+ (:frame-3d :edge-raised :thickness (u96ths 3)))) (tracked-pct :initarg :tracked-pct :initform nil :accessor tracked-pct) @@ -45,7 +45,7 @@ (jumper-action :initarg :jumper-action :reader jumper-action :initform 'ix-slider-jumper-action) (jumper-layers :initarg :jumper-layers :reader jumper-layers - :initform (with-layers +lt-gray+ :on + :initform (with-layers +light-gray+ :on (:frame-3d :edge-raised :thickness (u96ths 3)))) ) --- /project/cello/cvsroot/cello/window-utilities.lisp 2006/08/31 17:34:47 1.8 +++ /project/cello/cvsroot/cello/window-utilities.lisp 2006/10/17 21:30:08 1.9 @@ -28,33 +28,11 @@ ;;(trc "*** No special do-double-click for ix-view, event:" self osEvent) nil) -; ------------------- right button -------------------------------------- - (defun geo-dump (i) (when (typep i 'ix-view) (print (list :pxy (cons (px i)(py i)) :lt (lt i) :lb (lb i))) (geo-dump (fm-parent i)))) -(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 - ((control-key-down buttons) (geo-dump i)) - (t (print `(inspecting ,i)) - ;;(c-stop :inspecting) - (inspect i)))))) - -(defmethod do-right-button :around (self buttons wxwy) - (declare (ignorable buttons wxwy)) - (when self - (or (call-next-method) - (do-right-button (fm-parent self) 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))) @@ -69,9 +47,6 @@ ; --------------- geometry ------------------------------- - - - (defun point-in-box (pt box) (and (<= (r-left box) (v2-h pt) (r-right box)) (>= (r-top box) (v2-v pt) (r-bottom box)))) --- /project/cello/cvsroot/cello/wm-mouse.lisp 2006/06/05 01:47:49 1.4 +++ /project/cello/cvsroot/cello/wm-mouse.lisp 2006/10/17 21:30:08 1.5 @@ -35,7 +35,8 @@ (:conc-name nil)) modifiers where - realtime) + realtime + c-event) (defun mk-os-event (modifiers where) (make-os-event :modifiers modifiers @@ -51,6 +52,10 @@ (defun evt-where (os-event) (where os-event)) +(export! evt-c-event) +(defun evt-c-event (os-event) + (c-event os-event)) + (defun evt-wherex (os-event) (declare (optimize (speed 3) (safety 0) (debug 0))) ;; (logand (the fixnum (evtLParam os-event)) (1- 65536)) @@ -60,15 +65,6 @@ (declare (optimize (speed 3) (safety 0) (debug 0))) (v2-v (evt-where os-event))) -(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) (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) -

1 0

[cello-cvs] CVS cello
by fgoenninger 13 Oct '06

13 Oct '06

Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv20980 Modified Files: application.lisp Log Message: Changed: Code formatting only. No (!) functional differences. --- /project/cello/cvsroot/cello/application.lisp 2006/10/02 02:59:18 1.7 +++ /project/cello/cvsroot/cello/application.lisp 2006/10/13 08:04:45 1.8 @@ -21,26 +21,42 @@ (defparameter *first-kill-all-the-windows* nil) (defun cello-reset (&optional (system-type 'mg-system)) + + ;; Reset CFFI, CFFI Extender (ffx-reset) + + ;; Reset CELLS (cells-reset 'tk-user-queue-handler :debug t) + + ;; Reset OpenGL special vars (makunbound 'ogl::*gl-stop*) - ;(xftgl) - (cl-ftgl-reset) ;; 2006-09-27 back in temporarily ... new 2006-08-28 in face of weird OGL 1282 when new chars hit in ratios + + (cl-ftgl-reset) ;; 2006-09-27 back in temporarily ... + ;; new 2006-08-28: in face of weird OGL 1282 when + ;; new chars hit in ratios + + ;; Init global *sys* ... needed for Cello context ops (when system-type (setf *sys* (make-instance system-type :md-name 'mgsys))) - (values)) + (values)) (defmodel mg-system (family) - ( - (main-window :initarg :main-window :initform (c-in nil) :accessor main-window) - (mouse :cell nil :initarg :mouse :initform nil :accessor mouse) - (sys-time :initarg :sys-time :initform (c-in (now)) :accessor sys-time) - (user-preferences :initarg :user-preferences :initform (c-in nil) :accessor user-preferences) - ) + ((main-window :initarg :main-window + :initform (c-in nil) + :accessor main-window) + (mouse :cell nil + :initarg :mouse + :initform nil + :accessor mouse) + (sys-time :initarg :sys-time + :initform (c-in (now)) + :accessor sys-time) + (user-preferences :initarg :user-preferences + :initform (c-in nil) + :accessor user-preferences)) (:default-initargs - :kids (c-in nil) - )) + :kids (c-in nil))) (defun sys-now () (sys-time *sys*)) @@ -81,6 +97,3 @@ (defun fm-find-system (md) (upper md mg-system)) - - -

1 0

[cello-cvs] CVS cello
by fgoenninger 13 Oct '06

13 Oct '06

Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv19014 Modified Files: cello-ftgl.lisp Log Message: Changed: Demo code only. Make FTGL-WINDOW (the demo) work with new Celtk/Cello changes. At least I tried to ;-) --- /project/cello/cvsroot/cello/cello-ftgl.lisp 2006/10/02 02:59:18 1.8 +++ /project/cello/cvsroot/cello/cello-ftgl.lisp 2006/10/13 07:59:12 1.9 @@ -98,7 +98,7 @@ :face *gui-style-button-face* :sizes '(14 9 14 14 14) :text-color +green+)) - (run-cello-window (make-instance 'ftgl-window) + (run-cello-window 'ftgl-window (lambda () ;;; -- not sure how much of this new reset stuff is necessary --- (kt-opengl-init) @@ -108,8 +108,6 @@ (defmodel ftgl-window (cello-window) () (:default-initargs - :idler nil - :display-continuous t :ll 0 :lt 0 :lr (c-in (scr2log 900)) :lb (c-in (scr2log -900)) @@ -117,7 +115,6 @@ :title$ "Hello, ftgl" :skin nil :lighting :off - :clear-rgba (list 0 0 0 1) :pre-layer (c? (with-layers +blue+ :off)) :clipped nil :kids (c? (the-kids @@ -133,6 +130,7 @@ :lighting :off :text$ s :style-id :unique + :fm-parent *parent* :pre-layer (c? (with-layers (:rgba (if (^mouse-over-p) +red+ +blue+)))))))))))

1 0

[cello-cvs] CVS cello/kt-opengl
by ktilton 13 Oct '06

13 Oct '06

Update of /project/cello/cvsroot/cello/kt-opengl In directory clnet:/tmp/cvs-serv1625/kt-opengl Modified Files: kt-opengl.lisp Log Message: --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lisp 2006/10/02 03:55:23 1.10 +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lisp 2006/10/13 05:57:28 1.11 @@ -21,7 +21,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Id: kt-opengl.lisp,v 1.10 2006/10/02 03:55:23 ktilton Exp $ +;;; $Id: kt-opengl.lisp,v 1.11 2006/10/13 05:57:28 ktilton Exp $ (pushnew :kt-opengl *features*) @@ -48,8 +48,7 @@ (defun kt-opengl-reset () (loop for ec = (glgeterror) for n below 10 - when (zerop ec) do (cells::trc "kt-opengl-reset sees zero error code") - (loop-finish) + when (zerop ec) do (loop-finish) do (cells::trc "kt-opengl-init sees error" ec))) (eval-when (:load-toplevel :execute)

1 0

[cello-cvs] CVS cello
by ktilton 13 Oct '06

13 Oct '06

Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv1625 Modified Files: control.lisp ctl-toggle.lisp image.lisp ix-opengl.lisp ix-polygon.lisp ix-text.lisp ix-togl.lisp mouse-click.lisp Log Message: --- /project/cello/cvsroot/cello/control.lisp 2006/10/02 02:59:18 1.5 +++ /project/cello/cvsroot/cello/control.lisp 2006/10/13 05:57:27 1.6 @@ -16,34 +16,25 @@ (in-package :cello) -(defmodel control () - ( - (title$ :initarg :title$ :accessor title$ - :initform (c? (format nil "~:(~a~)" ;; this is just a poor default-- really s.b. supplied by form author - (string-downcase (substitute #\space #\- (string (md-name self))))))) - (ct-action :cell nil :initarg :ct-action :initform nil :reader ct-action) - (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? (bwhen (c (^click-evt)) - (let ((age (f-sensitivity :age (0.1) - (click-age c )))) - (when (> age 0.5) age))))) - (mouse-up-handler :initform nil :initarg mouse-up-handler :accessor mouse-up-handler - :documentation "Menus use this") - (click-evt :initform (c-in nil) :initarg :click-evt :accessor click-evt) - (click-tolerance :cell nil :initform (mkv2 0 0) - :unchanged-if 'v2= - :initarg :click-tolerance :reader click-tolerance) - (key-evt :cell :ephemeral :initform nil :initarg :key-evt :accessor key-evt) - (enabled :initform t :initarg :enabled :accessor enabled) - (hilited :initform (c? (bwhen (click (^click-evt)) - (click-over click))) - :initarg :hilited :accessor hilited) - (kb-selector :cell nil :initarg :kb-selector :initform nil :reader kb-selector) - ) - (:default-initargs - :gl-name (c? (incf (gl-name-highest .w.))))) +(defmd control () + (title$ (c? (format nil "~:(~a~)" ;; this is just a poor default-- really s.b. supplied by form author + (string-downcase (substitute #\space #\- (string (md-name self))))))) + (ct-action nil :cell nil) + click-repeat-p + (click-repeat-event (c? (bwhen (c (^click-evt)) + (let ((age (f-sensitivity :age (0.1) + (click-age c )))) + (when (> age 0.5) age))))) + (mouse-up-handler nil :documentation "Menus use this") + (click-evt (c-in nil)) + (click-tolerance (mkv2 0 0) :cell nil) + (key-evt nil :cell :ephemeral) + (enabled t) + (hilited (c? (bwhen (click (^click-evt)) + (trc nil "got click!" click) + (click-over click)))) + (kb-selector nil :cell nil) + :gl-name (c? (incf (gl-name-highest .w.)))) (defobserver click-repeat-event () (with-integrity (:change :obs-click-repeat-event) --- /project/cello/cvsroot/cello/ctl-toggle.lisp 2006/10/02 02:59:18 1.4 +++ /project/cello/cvsroot/cello/ctl-toggle.lisp 2006/10/13 05:57:27 1.5 @@ -33,48 +33,55 @@ :fill (:rgba (^text-color))))) -(defmodel ct-button (control ix-text) ;; same inheritance, but otherwise unrelated to CTText - ((inset :unchanged-if 'v2= :initform (mkv2 (upts 4) (upts 4))) - (depressed :initarg :depressed :reader depressed :initform (c? (^hilited)))) - (:default-initargs - :title$ (c? (string-capitalize (md-name self))) - :text$ (c? (^title$)) - :clipped t - :justify-hz :center - :justify-vt :center - :style-id :button - :skin (c? (skin .w.)) - :text-color (c? (if (^depressed) - +dk-gray+ +white+)) - :pre-layer (c? (let* ((thick (min (u96ths 4) (* 0.08 (l-width self)))) - (defl (if (clo::^depressed) (downs (/ thick 3)) 0)) - (push-in (if (clo::^depressed) (xlout (* .5 thick)) 0))) - (declare (ignorable thick defl)) - (trc nil "ctbutton" thick defl) - - (with-layers - (:v3f (/ defl 2) defl push-in) - - +white+ - :on - (:frame-3d :edge-raised - :thickness thick - :texturing (list (clo::^skin))) - (:rgba (^text-color)) - ))) - #+old (c? (let* ((thick (min (u96ths 4) (* 0.08 (l-width self)))) - (defl (if (^depressed) (downs (/ thick 3)) 0)) - (push-in (if (^depressed) (xlout (* .5 thick)) 0))) - (declare (ignorable thick defl)) - (trc nil "ctbutton" thick defl) +(defmd ct-button (control ix-text) ;; same inheritance, but otherwise unrelated to CTText + (md-value (c-in nil) :cell :ephemeral) + (inset (mkv2 (upts 4) (upts 4)) :unchanged-if 'v2=) + (depressed (c? (^hilited))) + :ct-action (lambda (self event) + (declare (ignore event)) + (with-c-change :button-press + .retog. + (setf (^md-value) t))) + :title$ (c? (string-capitalize (md-name self))) + :text$ (c? (^title$)) + :clipped t + :justify-hz :center + :justify-vt :center + :style-id :button + :skin (c? (skin .w.)) + :text-color (c? (cond + ((not (^enabled)) +red+) + ((^depressed) +dk-gray+) + (t +white+))) + :pre-layer (c? (let* ((thick (min (u96ths 4) (* 0.08 (l-width self)))) + (defl (if (clo::^depressed) (downs (/ thick 3)) 0)) + (push-in (if (clo::^depressed) (xlout (* .5 thick)) 0))) + (declare (ignorable thick defl)) + (trc nil "ctbutton" thick defl) + + (with-layers + (:v3f (/ defl 2) defl push-in) - (with-layers - (:v3f (/ defl 2) defl push-in) - +lt-gray+ - :on - (:frame-3d :edge-raised - :thickness thick) - (:rgba (^text-color))))))) + +white+ + :on + (:frame-3d :edge-raised + :thickness thick + :texturing (list (clo::^skin))) + (:rgba (^text-color)) + ))) + #+old (c? (let* ((thick (min (u96ths 4) (* 0.08 (l-width self)))) + (defl (if (^depressed) (downs (/ thick 3)) 0)) + (push-in (if (^depressed) (xlout (* .5 thick)) 0))) + (declare (ignorable thick defl)) + (trc nil "ctbutton" thick defl) + + (with-layers + (:v3f (/ defl 2) defl push-in) + +lt-gray+ + :on + (:frame-3d :edge-raised + :thickness thick) + (:rgba (^text-color)))))) (defmacro ct-button-ex ((text command) &rest initargs) `(make-instance 'ct-button @@ -105,8 +112,9 @@ :ct-action (lambda (self event) (declare (ignorable event)) - (let ((newv (funcall (transition-fn self) (md-value self) (states self)))) - (ct-fsm-assume-value self newv))))) + (with-integrity (:change :ctfsm-action) + (let ((newv (funcall (transition-fn self) (md-value self) (states self)))) + (ct-fsm-assume-value self newv)))))) (defmethod ct-fsm-assume-value (self new-value) (setf (md-value self) new-value)) @@ -119,40 +127,35 @@ (:default-initargs :states '(nil t))) - ;------------------------------------------------------ -#+nope + (defmodel ct-twister (ct-toggle ix-polygon) ;; convert to IMBitmapMulti?? -; -; For twist-down control to open/close details -; + ; + ; For twist-down control to open/close details + ; () (:default-initargs :md-value (c-in nil) ;;; closed by default :poly-style :fill - :pre-layer (c? (with-layers (:rgba (if (^hilited) - +black+ +gray+)))) + :pre-layer (c? (with-layers + (:rgba (if (^hilited) + +green+ +black+)))) :vertices (c? (if (md-value self) - (u-cvt '((2 . 4) (7 . 9) (12 . 4)) :96ths) - (u-cvt '((4 . 2) (9 . 7) (4 . 12)) :96ths) - #+big '((0 . 5) (14 . 5) (7 . 12)) - #+big '((5 . 0) (12 . 7) (5 . 14)) - )) + '((2 . -4) (7 . -9) (12 . -4)) + '((4 . -2) (9 . -7) (4 . -12)))) :ll 0 :lt 0 :lr (u96ths 15) :lb (downs (u96ths 15)))) (defmacro mk-twisted (twisted-name (label-class &rest label-args) (twisted-class &rest twisted-args)) - `(mk-part :twisted-group (ix-zero-tl) + `(make-kid :twisted-group (ix-zero-tl) :showkids (c-in nil) :ll (c? (geo-kid-wrap self 'pl)) :lr (c? (geo-kid-wrap self 'pr)) - :kid-factory (lambda (self kid-value) - (declare (ignore self kid-value))) :kids (c? (let ((thetree self)) ;; (trc "making all parts of tree for" (md-value self) rethinker) (the-kids - (mk-part :header (ix-kid-sized) + (mk-part 'ix-kid-sized :ll (u96ths -20) :px 0 :kids (c? (packed-flat! (mk-part :opener (ct-twister) @@ -172,19 +175,19 @@ (defmacro mk-twisted-part (twisted-name (label$ &rest label-args) twisted-part) - `(mk-part :twisted-group (ix-zero-tl) - :showkids (c-in nil) + `(make-kid 'ix-zero-tl + :showkids (c-in nil) ;; /// parameterize :ll (c? (geo-kid-wrap self 'pl)) :lr (c? (geo-kid-wrap self 'pr)) - :kid-factory #'null :kids (c? (the-kids - (mk-part :header (ix-kid-sized) + (make-kid 'ix-kid-sized :ll (u96ths -20) :px 0 :kids (c? (packed-flat! - (mk-part :opener (ct-twister) + (make-kid 'ct-twister :py (u96ths 2) :px (c? (px-maintain-pr (u96ths -3)))) - (mk-part ,twisted-name (ix-text) + (make-kid 'ix-text + :md-name ',twisted-name ,@label-args :text$ ,label$)))) ,twisted-part --- /project/cello/cvsroot/cello/image.lisp 2006/10/02 02:59:18 1.13 +++ /project/cello/cvsroot/cello/image.lisp 2006/10/13 05:57:27 1.14 @@ -81,6 +81,8 @@ :initform (c? (or .cache (^showkids))) :reader kids-ever-shown))) +(defmodel ix-zero-tl (geo-zero-tl ix-family)()) +(defmodel ix-kid-sized (geo-kid-sized ix-family)()) (defmodel ix-inline (geo-inline ix-view)()) (defmodel ix-inline-lazy (geo-inline-lazy ix-view)()) --- /project/cello/cvsroot/cello/ix-opengl.lisp 2006/10/02 02:59:18 1.7 +++ /project/cello/cvsroot/cello/ix-opengl.lisp 2006/10/13 05:57:27 1.8 @@ -56,7 +56,7 @@ (define-symbol-macro .og. (or (ogl-context self) - (setf (ogl-context self) (upper self ctk::togl)))) + (setf (ogl-context self) (nearest self ctk::togl)))) (define-symbol-macro .ogc. (togl-ptr .og.)) (define-symbol-macro .retog. (when .ogc. (togl-post-redisplay .ogc.))) --- /project/cello/cvsroot/cello/ix-polygon.lisp 2006/06/26 17:05:20 1.3 +++ /project/cello/cvsroot/cello/ix-polygon.lisp 2006/10/13 05:57:27 1.4 @@ -32,10 +32,10 @@ (append (mapcar #'g2d (vertices self)) (nreverse (mapcar #'sym2d (vertices self)))) (mapcar #'g2d (vertices self))))) + (with-matrix (nil) - (ix-render-layer (fore-color self) nil) - (gl-line-width (poly-thickness self)) - (with-gl-begun (gl_lines) + (gl-line-width (poly-thickness self)) + (with-gl-begun (gl_line_loop) (dolist (v vs) (gl-vertex3f (v2-h v) (v2-v v) 0))) (ogl::glec :f3d)))))) --- /project/cello/cvsroot/cello/ix-text.lisp 2006/10/02 02:59:18 1.9 +++ /project/cello/cvsroot/cello/ix-text.lisp 2006/10/13 05:57:27 1.10 @@ -19,7 +19,7 @@ ;=========================================================== (eval-when (compile load eval) - (export '(ix-paint inset))) + (export '(ix-paint inset ix-text ix-styled ix-view))) (defmodel ix-text (ix-styled ix-view) ( --- /project/cello/cvsroot/cello/ix-togl.lisp 2006/10/02 02:59:18 1.11 +++ /project/cello/cvsroot/cello/ix-togl.lisp 2006/10/13 05:57:27 1.12 @@ -103,7 +103,7 @@ (:ButtonPress (setf (mouse-pos self) (mkv2 (ctk::xbe-x xe) (- (ctk::xbe-y xe)))) ; trigger mouseview recalc - (setf (mouse-down-evt self) (eko ("mousedown!!!!!!!!!") + (setf (mouse-down-evt self) (eko (nil "mousedown!!!") (make-os-event :modifiers (keyboard-modifiers .tkw) :where (mouse-pos self) @@ -111,14 +111,14 @@ (:ButtonRelease (setf (mouse-pos self) (mkv2 (ctk::xbe-x xe) (- (ctk::xbe-y xe)))) ; trigger mouseview recalc - (setf (mouse-up-evt self) (eko ("mouse up!!!!!!!!!") + (setf (mouse-up-evt self) (eko (nil "mouse up!!!") (make-os-event :modifiers (keyboard-modifiers .tkw) :where (mouse-pos self) :realtime (now))))) (:MotionNotify - (trc nil "setting mouse pos!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!" (ctk::xbe-x xe) (- (ctk::xbe-y xe))) + (trc nil "setting mouse pos!!!!" (ctk::xbe-x xe) (- (ctk::xbe-y xe))) (setf (mouse-pos self) (mkv2 (ctk::xbe-x xe) (- (ctk::xbe-y xe))))) (:EnterNotify ) @@ -218,8 +218,9 @@ (setf (mouse-over-p new-value) t)))) (defobserver mouse-down-evt (self m-down) + .retog. (when m-down - (trc nil "mousedown" m-down (mouse-control self)) + (trcx nil mousedown self m-down (mouse-control self)) (bwhen (clickee (mouse-control self)) (trc nil "mousedown clickee, clickw" clickee self) (mk-part :click (mouse-click) ;; wow, a free-floating part @@ -229,11 +230,12 @@ :clickee-pxy (mkv2 (px clickee) (py clickee)))))) (defobserver mouse-up-evt (self up) + .retog. (when up ;; should be since this is ephemeral, but still.. - (trc "mouseup" self up (mouse-control self)) + (trc nil "mouseup" self up (mouse-control self)) (bwhen (clickee (mouse-control self)) (bwhen (upper (mouse-up-handler clickee)) - (trc "mouseup clickee, clickw" clickee self) + (trc nil "mouseup clickee, clickw" clickee self) (funcall upper clickee up))))) (defparameter *gw* nil) --- /project/cello/cvsroot/cello/mouse-click.lisp 2006/10/02 02:59:18 1.6 +++ /project/cello/cvsroot/cello/mouse-click.lisp 2006/10/13 05:57:27 1.7 @@ -30,7 +30,8 @@ :documentation "Unreliable unless click-repeat-p forcing events") (click-completed :reader click-completed :initform (c? (when (typep (click-window self) 'model) ;; <- acl used to turn windows into - (mouse-up-evt (click-window self))))) ;; closed-stream instances + (eko (nil "click-completed" (click-window self)) + (mouse-up-evt (click-window self)))))) ;; closed-stream instances (click-over :reader click-over :initform (c? (when (typep (click-window self) 'model) @@ -45,11 +46,11 @@ (mouse-pos (click-window self))))))) (clicked :reader clicked - :initform (c? (trc "clicked?> typeof clickw" (click-window self) (type-of (click-window self))) + :initform (c? (trc nil "clicked?> typeof clickw" (click-window self) (type-of (click-window self))) (when (typep (click-window self) 'model) - (trc "clicked?> asking clickcompleted") + (trc nil "clicked?> asking clickcompleted") (bwhen (up (^click-completed)) - (trc "clicked?> asking point-in-box" + (trc nil "clicked?> asking point-in-box" (evt-where up) (clickee self) (without-c-dependency @@ -60,7 +61,8 @@ (cons (clickee self) up)))))) ) (:default-initargs - :expiration (c? (mouse-up-evt (click-window self))))) + :expiration (c? (eko (nil "expiry?" (click-window self)) + (mouse-up-evt (click-window self)))))) (defmethod initialize-instance :after ((self mouse-click) &key) (with-integrity (:change :ii-mouseclick) @@ -69,7 +71,7 @@ (focus-navigate (focus (click-window self)) (clickee self)))) ;;;20060601 (to-be self) ;; unnecessary? 2301kt just moved this from after next line - (trc "echo click set self clickee" self (clickee self)) + (trc nil "echo click set self clickee" self (clickee self)) (when (clickee self) (setf (click-evt (clickee self)) self)))) @@ -91,18 +93,19 @@ (declare (ignorable other click))) (defmethod not-to-be :around ((self mouse-click)) - (when (typep (click-window self) 'window) ;; /// why worry about this? - (trc "echo click clearing self from clickee" (clickee self)) - (setf (click-evt (clickee self)) nil) ;; do this first? - ;; (trc "echo click not-to-be-ing self from clickee" self) - (call-next-method) - (set-doubleclick? (click-window self) self) ;; from Win32 days - )) + (when (typep (click-window self) 'model) ;; ACL can do weird things closing a window + (with-integrity (:change :not-to-be-click) + (trc nil "echo click clearing self from clickee" (clickee self)) + (setf (click-evt (clickee self)) nil) ;; do this first? + ;; (trc "echo click not-to-be-ing self from clickee" self) + (call-next-method) + (set-doubleclick? (click-window self) self) ;; from Win32 days + ))) (defobserver clicked () - (trc "echo clicked " self new-value) + (trc nil "echo clicked " self new-value) (when (and new-value (click-window self)) - (trc "echo clicked calling control-do-action" self new-value) + (trc nil "echo clicked calling control-do-action" self new-value) (control-do-action (car new-value) (cdr new-value)))) ;----------------------------------------

1 0

[cello-cvs] CVS cello/cl-magick
by ktilton 13 Oct '06

13 Oct '06

Update of /project/cello/cvsroot/cello/cl-magick In directory clnet:/tmp/cvs-serv1625/cl-magick Modified Files: wand-texture.lisp Log Message: --- /project/cello/cvsroot/cello/cl-magick/wand-texture.lisp 2006/09/05 23:05:37 1.7 +++ /project/cello/cvsroot/cello/cl-magick/wand-texture.lisp 2006/10/13 05:57:27 1.8 @@ -42,14 +42,14 @@ (grow-sz (cons (expt 2 (ceiling (log (car (image-size self)) 2))) (expt 2 (ceiling (log (cdr (image-size self)) 2))))) (best-fit-sz (best-fit-cons trunc-sz (image-size self) grow-sz))) - (print `(texture-name> gennning texture ,self)) ;; frgo: debug... + ;;(print `(texture-name> gennning texture ,self)) ;; frgo: debug... (unless (equal (image-size self) best-fit-sz) - (print `(texture-name> tex-refit ,(image-size self) to ,best-fit-sz)) ;; frgo: debug... + ;;(print `(texture-name> tex-refit ,(image-size self) to ,best-fit-sz)) ;; frgo: debug... (magick-scale-image (mgk-wand self) (car best-fit-sz) (cdr best-fit-sz)) ;;; gaussian-filter 0) (setf (image-size self) best-fit-sz)) - (print `(texture-name> new image size , self ,(image-size self))) ;; frgo: debug... + ;;(print `(texture-name> new image size , self ,(image-size self))) ;; frgo: debug... (let ((tx (wand-image-to-texture self))) (if (plusp tx) (setf (texture-name self) tx) @@ -70,7 +70,7 @@ (cdr (image-size self))))) ;;(assert (not *ogl-listing-p*)) (assert (plusp tx)) - (cells:trc "!!!!wand-image-to-texture genning new tx: ~a" tx) ;; frgo: debug... + (cells:trc nil "!!!!wand-image-to-texture genning new tx: ~a" tx) ;; frgo: debug... (gl-bind-texture gl_texture_2d tx) (progn ;; useless?? @@ -87,7 +87,7 @@ (gl-tex-image2d gl_texture_2d 0 3 (car (image-size self)) (cdr (image-size self)) 0 gl_rgb gl_unsigned_byte pixels) (kt-opengl::glec :tex-image) - (print `(wand-image-to-texture loaded texture sized ,(image-size self))) ;; frgo: debug... + ;;(print `(wand-image-to-texture loaded texture sized ,(image-size self))) ;; frgo: debug... (fgn-free pixels) tx))

1 0

[cello-cvs] CVS cello/cl-ftgl
by ktilton 13 Oct '06

13 Oct '06

Update of /project/cello/cvsroot/cello/cl-ftgl In directory clnet:/tmp/cvs-serv1625/cl-ftgl Modified Files: cl-ftgl.lisp Log Message: --- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2006/10/02 02:59:18 1.15 +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2006/10/13 05:57:27 1.16 @@ -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.15 2006/10/02 02:59:18 ktilton Exp $ +;;; $Header: /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp,v 1.16 2006/10/13 05:57:27 ktilton Exp $ (eval-when (:compile-toplevel :load-toplevel) (pushnew :cl-ftgl *features*)) @@ -181,7 +181,6 @@ (defun cl-ftgl-reset () #-(or mcl macosx) (setq *ftgl-loaded-p* nil) - (cells::trc "nailing fonts loaded!!!!!!!!!!!!!") (setq *ftgl-fonts-loaded* nil)) (defmacro dbgftgl (tag &body body) @@ -397,7 +396,7 @@ (fgc-bitmap-make fpath)) (defmethod fgc-font-make ((font ftgl-texture) fpath) - (format t "~%*** FGC-FONT-MAKE: fpath = ~A~%" fpath) + (format *debug-io* "~%*** FGC-FONT-MAKE: fpath = ~A~%" fpath) (fgc-texture-make fpath)) (defmethod fgc-font-make ((font ftgl-extruded) fpath)

1 0

[cello-cvs] CVS cello
by ktilton 06 Oct '06

06 Oct '06

Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv7054 Modified Files: lighting.lisp Log Message: --- /project/cello/cvsroot/cello/lighting.lisp 2006/10/02 02:59:18 1.6 +++ /project/cello/cvsroot/cello/lighting.lisp 2006/10/06 08:01:51 1.7 @@ -93,7 +93,6 @@ (loop for light in (fixed-lighting self) do (ix-render-light light)) (when (and (not lights) (emergency-lighting self)) - (trc "emergency lighting!!!!!!!!!!" self) (dolist (e-light (emergency-lighting self)) (ix-render-light e-light)))))

1 0

[cello-cvs] CVS cello/kt-opengl
by ktilton 02 Oct '06

02 Oct '06

Update of /project/cello/cvsroot/cello/kt-opengl In directory clnet:/tmp/cvs-serv8357/kt-opengl Modified Files: colors.lisp kt-opengl.lisp kt-opengl.lpr ogl-utils.lisp Log Message: --- /project/cello/cvsroot/cello/kt-opengl/colors.lisp 2006/10/01 09:34:08 1.4 +++ /project/cello/cvsroot/cello/kt-opengl/colors.lisp 2006/10/02 03:55:23 1.5 @@ -20,7 +20,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; -;;; $Id: colors.lisp,v 1.4 2006/10/01 09:34:08 fgoenninger Exp $ +;;; $Id: colors.lisp,v 1.5 2006/10/02 03:55:23 ktilton Exp $ (in-package #:kt-opengl) @@ -225,7 +225,7 @@ (define-ogl-rgba-color +GREEN+ 0 255 0 255) (define-ogl-rgba-color +BLUE+ 0 0 255 255) -(define-ogl-rgba-color +WHITE+ 0 0 0 255) +(define-ogl-rgba-color +WHITE+ 255 255 255 255) (define-ogl-rgba-color +BLACK+ 0 0 0 255) (define-ogl-rgba-color +GRAY+ 128 128 128 255) (define-ogl-rgba-color +TURQUOISE+ 0 255 255 255) @@ -237,6 +237,7 @@ (define-ogl-rgba-color +DK-GRAY+ 64 64 64 255) (define-ogl-rgba-color +LIGHT-BLUE+ 127 127 255 255) +(define-ogl-rgba-color +YELLOW+ 255 255 127 255) (define-ogl-rgba-color +LIGHT-YELLOW+ 255 255 127 255) (define-ogl-rgba-color +LIGHT-GRAY+ 192 192 192 255) (define-ogl-rgba-color +LT-GRAY+ 192 192 192 255) --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lisp 2006/10/01 13:41:30 1.9 +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lisp 2006/10/02 03:55:23 1.10 @@ -21,7 +21,10 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Id: kt-opengl.lisp,v 1.9 2006/10/01 13:41:30 fgoenninger Exp $ +;;; $Id: kt-opengl.lisp,v 1.10 2006/10/02 03:55:23 ktilton Exp $ + +(pushnew :kt-opengl *features*) + (in-package :kt-opengl) @@ -42,12 +45,14 @@ (assert (and opengl-loaded-p glu-loaded-p)) (setf *opengl-dll* t))))) -(eval-when (:load-toplevel :execute) - (kt-opengl-init)) - (defun kt-opengl-reset () (loop for ec = (glgeterror) for n below 10 when (zerop ec) do (cells::trc "kt-opengl-reset sees zero error code") (loop-finish) do (cells::trc "kt-opengl-init sees error" ec))) + +(eval-when (:load-toplevel :execute) + (kt-opengl-init)) + + --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lpr 2006/08/28 21:45:28 1.5 +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lpr 2006/10/02 03:55:23 1.6 @@ -5,14 +5,17 @@ (defpackage :KT-OPENGL) (define-project :name :kt-opengl - :modules (list (make-instance 'module :name "kt-opengl.lisp") + :modules (list (make-instance 'module :name "defpackage.lisp") + (make-instance 'module :name "kt-opengl-config.lisp") + (make-instance 'module :name "kt-opengl.lisp") (make-instance 'module :name "gl-def.lisp") (make-instance 'module :name "gl-constants.lisp") (make-instance 'module :name "gl-functions.lisp") (make-instance 'module :name "glu-functions.lisp") (make-instance 'module :name "ogl-macros.lisp") (make-instance 'module :name "ogl-utils.lisp") - (make-instance 'module :name "move-to-gl.lisp")) + (make-instance 'module :name "move-to-gl.lisp") + (make-instance 'module :name "colors.lisp")) :projects (list (make-instance 'project-module :name "..\\cffi-extender\\cffi-extender")) :libraries nil --- /project/cello/cvsroot/cello/kt-opengl/ogl-utils.lisp 2006/10/01 20:44:22 1.8 +++ /project/cello/cvsroot/cello/kt-opengl/ogl-utils.lisp 2006/10/02 03:55:23 1.9 @@ -22,7 +22,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Id: ogl-utils.lisp,v 1.8 2006/10/01 20:44:22 fgoenninger Exp $ +;;; $Id: ogl-utils.lisp,v 1.9 2006/10/02 03:55:23 ktilton Exp $ (declaim (optimize (debug 1) (speed 3) (safety 1) (compilation-speed 0))) @@ -179,9 +179,9 @@ (defun ncalc-normalf(v0x v0y v0z v1x v1y v1z v2x v2y v2z &aux d0x d0y d0z d1x d1y d1z) - (declare (type GLfloat - v0x v0y v0z v1x v1y v1z v2x v2y v2z - d0x d0y d0z d1x d1y d1z)) +;;; (declare (type GLfloat +;;; v0x v0y v0z v1x v1y v1z v2x v2y v2z +;;; d0x d0y d0z d1x d1y d1z)) (setf d0x (- v1x v0x) d0y (- v1y v0y) @@ -197,7 +197,7 @@ (- (* d0x d1y) (* d0y d1x)))) (defun xgl-normalize-v3f (x y z) - (declare (type GLfloat x y z)) +;;; (declare (type GLfloat x y z)) (let ((m2 (+ (* x x) (* y y) (* z z)))) (if (zerop m2)

1 0

[cello-cvs] CVS cello
by ktilton 02 Oct '06

02 Oct '06

Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv8357 Modified Files: ix-paint.lisp Log Message: --- /project/cello/cvsroot/cello/ix-paint.lisp 2006/10/02 02:59:18 1.6 +++ /project/cello/cvsroot/cello/ix-paint.lisp 2006/10/02 03:55:23 1.7 @@ -55,10 +55,6 @@ (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) - ,@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))

1 0

[cello-cvs] CVS cello/cl-ftgl
by ktilton 02 Oct '06

02 Oct '06

Update of /project/cello/cvsroot/cello/cl-ftgl In directory clnet:/tmp/cvs-serv27598/cl-ftgl Modified Files: cl-ftgl.lisp Log Message: --- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2006/09/17 22:39:20 1.14 +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2006/10/02 02:59:18 1.15 @@ -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.14 2006/09/17 22:39:20 fgoenninger Exp $ +;;; $Header: /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp,v 1.15 2006/10/02 02:59:18 ktilton Exp $ (eval-when (:compile-toplevel :load-toplevel) (pushnew :cl-ftgl *features*)) @@ -189,11 +189,6 @@ `(progn #+nahhh (unless (boundp '*gl-begun*) (assert (zerop (glgeterror)))) - #+nahhh (loop for (key . fonts) in (mathx::mp-fonts mathx::*font-node*) - when (eq key 'mathx::mathvar) - do (loop for font across fonts - when (or (eql 12 (ftgl-size font))(ftgl-ifont font)) - do (cells::trc nil "dbgftgl sees ifont" ,tag (ftgl-face font)(ftgl-size font)(ftgl-ifont font)))) (progn ;; cells:wtrc (0 100 "dbgftgl" ,tag) (ftgl-assert-opengl-context) (unless (boundp '*gl-begun*) (glec :dbgftgl-entry)) @@ -259,12 +254,6 @@ (defun dbgfont (font calltag) (declare (ignore font calltag)) -;;; (cells::trc "dbgfont" calltag (ftgl-dbg font) (ftgl-face font)(ftgl-size font)(ftgl-ifont font)) -;;; (unless (find font mathx::*font-node-all*) -;;; (cells::trc "dbgfont unknown!!!!! " calltag ) -;;; (dolist (f mathx::*font-node-all*) -;;; (cells::trc "known" (ftgl-dbg f)(ftgl-face f)(ftgl-size f))) -;;; (break "odd font")) ) (defun ftgl-assert-opengl-context () @@ -408,7 +397,7 @@ (fgc-bitmap-make fpath)) (defmethod fgc-font-make ((font ftgl-texture) fpath) - ;;(format t "~%*** FGC-FONT-MAKE: fpath = ~A~%" fpath) + (format t "~%*** FGC-FONT-MAKE: fpath = ~A~%" fpath) (fgc-texture-make fpath)) (defmethod fgc-font-make ((font ftgl-extruded) fpath) @@ -423,7 +412,8 @@ (fgc-polygon-make fpath)) (defun ftgl-string-length (font cs) - (fgc-string-advance (ftgl-get-metrics-font font) cs)) + (dbgftgl :ftgl-string-length + (fgc-string-advance (ftgl-get-metrics-font font) cs))) (defmethod font-bearing-x (font &optional text) (declare (ignorable font text))

1 0

[cello-cvs] CVS cello/cl-magick
by ktilton 02 Oct '06

02 Oct '06

Update of /project/cello/cvsroot/cello/cl-magick In directory clnet:/tmp/cvs-serv27598/cl-magick Modified Files: cl-magick.lisp wand-image.lisp Log Message: --- /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2006/09/05 23:05:37 1.12 +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2006/10/02 02:59:18 1.13 @@ -20,7 +20,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Id: cl-magick.lisp,v 1.12 2006/09/05 23:05:37 ktilton Exp $ +;;; $Id: cl-magick.lisp,v 1.13 2006/10/02 02:59:18 ktilton Exp $ (defpackage :cl-magick @@ -109,14 +109,14 @@ (when file-path$ (cl-magick-init) (let ((key (list* wand-type (namestring file-path$) iargs))) - (or (let ((old (cdr (assoc key (wands-loaded) :test 'equal)))) - (when old + (or #+nahhh (let ((old (cdr (assoc key (wands-loaded) :test 'equal)))) + #+shhh (when old (print `(wand-ensure-typed re-using-prior-load ,wand-type ,file-path$))) old) (let ((wi (apply 'make-instance wand-type :file-path$ file-path$ iargs))) - (print `(wand-ensure-typed forced-to-load ,wand-type ,file-path$)) + #+shh (print `(wand-ensure-typed forced-to-load ,wand-type ,file-path$)) (push (cons key wi) (wands-loaded)) wi) (error "Unable to load image file ~a" file-path$))))) @@ -129,3 +129,4 @@ (print `(unloading foreign library ,dll)) (setf *imagick-dll-loaded* nil) (ff:unload-foreign-library dll)))) + --- /project/cello/cvsroot/cello/cl-magick/wand-image.lisp 2006/09/05 23:05:37 1.8 +++ /project/cello/cvsroot/cello/cl-magick/wand-image.lisp 2006/10/02 02:59:18 1.9 @@ -100,8 +100,8 @@ (rows (- last-row first-row)) (pixels (fgn-alloc :unsigned-char (* 3 columns rows) :wand-image))) (assert (not (zerop pixels))() "wand-get-image-pixels > fgn-alloc of ~a bytes failed" (* 3 columns rows)) - (print (list "wand-get-image-pixels got" wand (* 3 columns rows) pixels)) ;; frgo: debug ... - (cells:trc "image format" wand (magick-get-image-format wand)) ;; frgo:debug... + ;;(print (list "wand-get-image-pixels got" wand (* 3 columns rows) pixels)) ;; frgo: debug ... + (cells:trc nil "image format" wand (magick-get-image-format wand)) ;; frgo:debug... ; ; these next two are quite slow thx to FFI I guess ; @@ -115,7 +115,7 @@ (magick-get-image-pixels wand first-col first-row columns rows "RGB" 0 pixels ) ;;(print `(writeimage ,(magick-write-image wand "/tmp/wand-image-test.jpg"))) - (progn + #+shhh (progn ; ; look at a few pixels ;

1 0

[cello-cvs] CVS cello
by ktilton 02 Oct '06

02 Oct '06

Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv27598 Modified Files: application.lisp cello-ftgl.lisp control.lisp ctl-markbox.lisp ctl-toggle.lisp frame.lisp image.lisp ix-opengl.lisp ix-paint.lisp ix-styled.lisp ix-text.lisp ix-togl.lisp lighting.lisp mouse-click.lisp Log Message: --- /project/cello/cvsroot/cello/application.lisp 2006/08/28 21:45:22 1.6 +++ /project/cello/cvsroot/cello/application.lisp 2006/10/02 02:59:18 1.7 @@ -22,10 +22,10 @@ (defun cello-reset (&optional (system-type 'mg-system)) (ffx-reset) - (cells-reset 'tk-user-queue-handler) + (cells-reset 'tk-user-queue-handler :debug t) (makunbound 'ogl::*gl-stop*) ;(xftgl) - ;(cl-ftgl-reset) ;; new 2006-08-28 in face of weird OGL 1282 when new chars hit in ratios + (cl-ftgl-reset) ;; 2006-09-27 back in temporarily ... new 2006-08-28 in face of weird OGL 1282 when new chars hit in ratios (when system-type (setf *sys* (make-instance system-type :md-name 'mgsys))) (values)) --- /project/cello/cvsroot/cello/cello-ftgl.lisp 2006/09/05 18:43:56 1.7 +++ /project/cello/cvsroot/cello/cello-ftgl.lisp 2006/10/02 02:59:18 1.8 @@ -33,13 +33,13 @@ (when start (unless end (setf end (length string)))) - - (ftgl-string-length font (if (or start end) - (subseq string start end) - string))) + (ftgl::dbgftgl :font-string-length + (ftgl-string-length font (if (or start end) + (subseq string start end) + string)))) (defun font-ftgl-ensure (mode face size) ;; ///sorry about the silly naming - (trc "font-ftgl-ensure requesting" mode face size) + (trc nil "font-ftgl-ensure requesting" mode face size) (ftgl-font-ensure mode face size (cs-target-res))) (defmodel font-id (ct-toggle ix-text) @@ -58,11 +58,13 @@ (when new-value (setf (md-value (fm-other :ftgl-test)) (^font-pathname)))) +(export! gui-style-ftgl) + (defclass gui-style-ftgl (gui-style gui-style-sizable) ((mode :initarg :mode :accessor mode :initform :texture))) (defmethod make-style-font (style) - (trc "no font for style" style)) + (break "no font for style ~a" style)) (defmethod make-style-font ((style gui-style-ftgl)) (font-ftgl-ensure (mode style) (face style) (gui-style-size style))) @@ -239,6 +241,17 @@ (let* ((t$ (display-text$ self))) (trc nil "ix-render-in-font ftgl-texture" :pxy (pxy self) (l-rect self) t$) + #+youarehere + (let ((ll (^ll))(lr (^lr))(lt (^lt))(lb (^lb))) ;; keep outside gl-begun since can kick off FTGL glyph build + ;(gl-color3f 0 0 0) + (gl-line-width 1) + (with-gl-begun (gl_lines) + (gl-vertex3f 0 0 0)(gl-vertex3f ll 0 0) + (gl-vertex3f 0 0 0)(gl-vertex3f lr 0 0) + (gl-vertex3f 0 0 0)(gl-vertex3f 0 lt 0) + (gl-vertex3f 0 0 0)(gl-vertex3f 0 lb 0) + )) + (gl-enable gl_texture_2d) (trc nil "(gl-is-enabled gl_texture_2d)!!!!!!!" (gl-is-enabled gl_texture_2d) (ogl-get-boolean gl_texture_2d)) @@ -247,6 +260,8 @@ (gl-enable gl_blend) (gl-blend-func gl_src_alpha gl_one_minus_src_alpha) (gl-polygon-mode gl_front_and_back gl_fill) + + (when (zoom self) (apply 'gl-scalef (zoom self))) --- /project/cello/cvsroot/cello/control.lisp 2006/06/05 01:47:49 1.4 +++ /project/cello/cvsroot/cello/control.lisp 2006/10/02 02:59:18 1.5 @@ -46,9 +46,10 @@ :gl-name (c? (incf (gl-name-highest .w.))))) (defobserver click-repeat-event () - (when new-value - (bwhen (f (ct-action self)) - (funcall f self (os-event (^click-evt)))))) ;; /// make fresh event with new time + (with-integrity (:change :obs-click-repeat-event) + (when new-value + (bwhen (f (ct-action self)) + (funcall f self (os-event (^click-evt))))))) ;; /// make fresh event with new time (defmethod enabled (other)(assert other) nil) --- /project/cello/cvsroot/cello/ctl-markbox.lisp 2006/07/06 22:09:10 1.6 +++ /project/cello/cvsroot/cello/ctl-markbox.lisp 2006/10/02 02:59:18 1.7 @@ -111,6 +111,7 @@ radio-values)) ;--------------- CTCheckBox -------------------------------------------- +(export! ct-check-box ct-check-text ct-radio-labeled ct-radio-push-button) (defmodel ct-check-box (ct-mark-box) () @@ -127,18 +128,20 @@ :spacing (u96ths 8) :outset (u96ths 2) :kids (c? (the-kids - (mk-part :check-box (ct-check-box) + (make-kid 'ct-check-box + :md-name :check-box :md-value (c? (md-value .parent)) :enabled nil) ;; let parent handle clicks since text is clickable by the rules - (mk-part :label (ix-text) + (make-kid 'ix-text + :md-name :label :text$ (c? (title$ .parent)) - :style-id :button - ))) + :style-id :button))) :ct-action (lambda (self event) (declare (ignorable event)) (trc nil "checktext bingo" (not (md-value self))) - (setf (md-value self) (not (md-value self)))))) + (with-c-change :check-text-action + (setf (md-value self) (not (md-value self))))))) (defmodel ct-radio-labeled (ix-row ct-radio-item) () --- /project/cello/cvsroot/cello/ctl-toggle.lisp 2006/07/03 00:35:12 1.3 +++ /project/cello/cvsroot/cello/ctl-toggle.lisp 2006/10/02 02:59:18 1.4 @@ -16,6 +16,8 @@ (in-package :cello) +(export! ct-text ct-button ct-button-ex ct-selectable-button mk-twisted mk-twisted-part) + (defmodel ct-text (control ix-text) () (:default-initargs @@ -30,6 +32,7 @@ :pre-layer (with-layers :off +white+ :fill (:rgba (^text-color))))) + (defmodel ct-button (control ix-text) ;; same inheritance, but otherwise unrelated to CTText ((inset :unchanged-if 'v2= :initform (mkv2 (upts 4) (upts 4))) (depressed :initarg :depressed :reader depressed :initform (c? (^hilited)))) @@ -43,7 +46,23 @@ :skin (c? (skin .w.)) :text-color (c? (if (^depressed) +dk-gray+ +white+)) - :pre-layer (c? (let* ((thick (min (u96ths 4) (* 0.08 (l-width self)))) + :pre-layer (c? (let* ((thick (min (u96ths 4) (* 0.08 (l-width self)))) + (defl (if (clo::^depressed) (downs (/ thick 3)) 0)) + (push-in (if (clo::^depressed) (xlout (* .5 thick)) 0))) + (declare (ignorable thick defl)) + (trc nil "ctbutton" thick defl) + + (with-layers + (:v3f (/ defl 2) defl push-in) + + +white+ + :on + (:frame-3d :edge-raised + :thickness thick + :texturing (list (clo::^skin))) + (:rgba (^text-color)) + ))) + #+old (c? (let* ((thick (min (u96ths 4) (* 0.08 (l-width self)))) (defl (if (^depressed) (downs (/ thick 3)) 0)) (push-in (if (^depressed) (xlout (* .5 thick)) 0))) (declare (ignorable thick defl)) @@ -57,6 +76,16 @@ :thickness thick) (:rgba (^text-color))))))) +(defmacro ct-button-ex ((text command) &rest initargs) + `(make-instance 'ct-button + :fm-parent *parent* + :title$ ,text + :ct-action (lambda (self event) + (declare (ignorable self event)) + (with-c-change :ct-button-ex-ct-action + ,command)) + ,@initargs)) + (defmodel ct-selectable-button (ct-selectable ct-button)()) ; ---------------- CT FSM --------------------- --- /project/cello/cvsroot/cello/frame.lisp 2006/06/05 01:47:49 1.3 +++ /project/cello/cvsroot/cello/frame.lisp 2006/10/02 02:59:18 1.4 @@ -72,50 +72,52 @@ (:edge-raised (nearer thick))))) (destructuring-bind (&optional uface uback) texturing + (declare (ignorable uback)) (with-attrib (gl_texture_bit gl_enable_bit gl_hint_bit gl_line_bit gl_color_buffer_bit) (if uface (progn ;;quick hack - + (trc nil "bingo frame3d texturing!!!!" uface (texture-name uface) (r-width lbox) (image-size uface)) (ogl-tex-activate (texture-name uface)) (ogl-tex-gen-setup gl_object_linear gl_modulate gl_repeat - 1 ;;.02 ;(eko ("f3dscale") (/ 1 (/ (r-width lbox) (car (image-size uface))))) + .003 + ;; (eko ("f3dscale") (/ 1 (/ (r-width lbox) (car )))) :s :tee) - (setf uface nil uback nil)) + ) (progn (gl-disable gl_texture_2d) (gl-enable gl_lighting))) (flet ((vrto () (when uface ;; just treating it as a flag for "texture on" - (gl-tex-coord2f (r-right uback)(r-top uback))) + (gl-tex-coord2f 1 1)) (gl-vertex3f outr outt 0)) (vlto () (when uface - (gl-tex-coord2f (r-left uback)(r-top uback))) + (gl-tex-coord2f 0 1)) (gl-vertex3f outl outt 0)) (vlbo () (when uface - (gl-tex-coord2f (r-left uback)(r-bottom uback))) + (gl-tex-coord2f 0 0)) (gl-vertex3f outl outb 0)) (vrbo () (when uface - (gl-tex-coord2f (r-right uback)(r-bottom uback))) + (gl-tex-coord2f 1 0)) (gl-vertex3f outr outb 0)) (vlti () (when uface - (gl-tex-coord2f inl int)) + (gl-tex-coord2f 0 1)) (gl-vertex3f inl int inz)) (vlbi () (when uface - (gl-tex-coord2f (r-left uface)(r-bottom uface))) + (gl-tex-coord2f 0 0)) (gl-vertex3f inl inb inz)) (vrti () (when uface - (gl-tex-coord2f (r-right uface)(r-top uface))) + (gl-tex-coord2f 1 1)) (gl-vertex3f inr int inz)) (vrbi () (when uface - (gl-tex-coord2f (r-right uface)(r-bottom uface))) + (gl-tex-coord2f 1 0)) (gl-vertex3f inr inb inz))) (flet ((render () (gl-translatef 0 0 (xlout thick)) --- /project/cello/cvsroot/cello/image.lisp 2006/09/05 18:43:56 1.12 +++ /project/cello/cvsroot/cello/image.lisp 2006/10/02 02:59:18 1.13 @@ -168,7 +168,7 @@ (defobserver mouse-over-p () (bwhen (p .parent) (when (typep p 'ix-view) - (with-integrity(:change) + (with-integrity(:change 'mose-over) (setf (mouse-over-p p) new-value))))) (defmethod ix-selectable ((self ix-view)) nil) @@ -276,6 +276,7 @@ (nreverse output)))) `(lambda (self l-box mode) (declare (ignorable self l-box)) + (trc nil "with-layers called!!!!!!!!!!!!!!!!" self mode) (ecase mode (:before ,@(collect-output (subseq layers 0 --- /project/cello/cvsroot/cello/ix-opengl.lisp 2006/10/01 20:47:54 1.6 +++ /project/cello/cvsroot/cello/ix-opengl.lisp 2006/10/02 02:59:18 1.7 @@ -51,11 +51,15 @@ (defmethod ogl-node-window (other) (c-break "ogl-node-window undefined for ~a" other)) + +(export! .og. .ogc. .retog.) + (define-symbol-macro .og. (or (ogl-context self) (setf (ogl-context self) (upper self ctk::togl)))) (define-symbol-macro .ogc. (togl-ptr .og.)) +(define-symbol-macro .retog. (when .ogc. (togl-post-redisplay .ogc.))) (defmodel ogl-node () ((ogl-context :cell nil :initform nil :accessor ogl-context) --- /project/cello/cvsroot/cello/ix-paint.lisp 2006/10/01 20:46:51 1.5 +++ /project/cello/cvsroot/cello/ix-paint.lisp 2006/10/02 02:59:18 1.6 @@ -68,7 +68,7 @@ (assert (zerop (glgeterror))) (when n - (trc "pushing gl-name" self n) + (trc nil "pushing gl-name" self n) (gl-push-name n)) (rpchk 'ix-paint t nil self) @@ -97,7 +97,7 @@ (assert (functionp pre-layer)) (count-it :pre-layer) (nr-make ixr-box (ll self) (lt self) (lr self) (lb self)) - + (trc nil "calling pre-layer" self) (funcall pre-layer self ixr-box :before) (call-next-method self) (funcall pre-layer self ixr-box :after)) --- /project/cello/cvsroot/cello/ix-styled.lisp 2006/06/26 17:05:20 1.5 +++ /project/cello/cvsroot/cello/ix-styled.lisp 2006/10/02 02:59:18 1.6 @@ -59,6 +59,7 @@ (when style ;;(print `(gui-style ,style ,(styles-default))) (or (ix-find-style self style) + (find style (styles-default) :key 'id) (find :default (styles-default) :key 'id) (break "gui-style cannot find requested style ~a" style)))) --- /project/cello/cvsroot/cello/ix-text.lisp 2006/07/06 22:09:10 1.8 +++ /project/cello/cvsroot/cello/ix-text.lisp 2006/10/02 02:59:18 1.9 @@ -54,14 +54,17 @@ :initform (mkv2 0 0) :accessor inset) (ll :initform (c? (- (inset-h self)))) - (lt :initform (c? (ups 0 (font-ascent (text-font self)) (inset-v self)))) - (lr :initform (c? (^lr-width (+ (cond - ((char-mask self) (ix-string-width self (char-mask self))) - ((^text-width)) - ((^maxcharwidth)) - (t (error "Please specify a font or :lr <n>."))) - (* 2 (inset-h self)))))) - (lb :initform (c? (downs 0 (font-descent (text-font self)) (inset-v self)))) + (lt :initform (c? (eko (nil "ixtext lt") + (ups 0 (font-ascent (text-font self)) (inset-v self))))) + (lr :initform (c? (eko (nil "ix-text lr") + (^lr-width (+ (cond + ((char-mask self) (ix-string-width self (char-mask self))) + ((^text-width)) + ((^maxcharwidth)) + (t (error "Please specify a font or :lr <n>."))) + (* 2 (inset-h self))))))) + (lb :initform (c? (eko (nil "ixtext LB") + (downs (font-descent (text-font self)) (inset-v self))))) ) (:default-initargs :lighting :off)) --- /project/cello/cvsroot/cello/ix-togl.lisp 2006/10/01 20:46:00 1.10 +++ /project/cello/cvsroot/cello/ix-togl.lisp 2006/10/02 02:59:18 1.11 @@ -22,7 +22,7 @@ ;------------- Window --------------- ; -(export! mouse-view ^mouse-view mouse-pos ^mouse-pos mouse-control ^mouse-control) +(export! mouse-view ^mouse-view mouse-pos ^mouse-pos mouse-control ^mouse-control mouse-down-evt ^mouse-down-evt) (defmodel ix-togl ( #+not focuser ogl-lit-scene control ogl-shared-resource-tender togl ix-view) ( @@ -36,7 +36,7 @@ :initform (c? (let ((mp (^mouse-pos))) (trc nil "mouseview sees pos" .w. mp) (when mp - (eko (nil "mouseview >" self) + (eko (nil "ix-togl mouseview >" self) (without-c-dependency (find-ix-under self mp))))))) @@ -103,11 +103,20 @@ (:ButtonPress (setf (mouse-pos self) (mkv2 (ctk::xbe-x xe) (- (ctk::xbe-y xe)))) ; trigger mouseview recalc - (setf (mouse-down-evt self) (make-os-event - :modifiers (keyboard-modifiers .tkw) - :where (mkv2 (ctk::xbe-x xe)(ctk::xbe-y xe)) - :realtime (now)))) - (:ButtonRelease ) + (setf (mouse-down-evt self) (eko ("mousedown!!!!!!!!!") + (make-os-event + :modifiers (keyboard-modifiers .tkw) + :where (mouse-pos self) + :realtime (now))))) + (:ButtonRelease + (setf (mouse-pos self) (mkv2 (ctk::xbe-x xe) + (- (ctk::xbe-y xe)))) ; trigger mouseview recalc + (setf (mouse-up-evt self) (eko ("mouse up!!!!!!!!!") + (make-os-event + :modifiers (keyboard-modifiers .tkw) + :where (mouse-pos self) + :realtime (now))))) + (:MotionNotify (trc nil "setting mouse pos!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!" (ctk::xbe-x xe) (- (ctk::xbe-y xe))) (setf (mouse-pos self) (mkv2 (ctk::xbe-x xe) @@ -200,11 +209,11 @@ (defobserver mouse-view () (when old-value - (with-integrity (:change) + (with-integrity (:change 'mview-lost) (trc nil "mouseover lost by" old-value (window-cache old-value)) (setf (mouse-over-p old-value) nil))) (when new-value - (with-integrity (:change) + (with-integrity (:change 'mview-gained) (trc nil "mouseover gained by" new-value (window-cache new-value)) (setf (mouse-over-p new-value) t)))) @@ -213,7 +222,7 @@ (trc nil "mousedown" m-down (mouse-control self)) (bwhen (clickee (mouse-control self)) (trc nil "mousedown clickee, clickw" clickee self) - (mk-part :click (mouse-click) + (mk-part :click (mouse-click) ;; wow, a free-floating part :click-window self :clickee clickee :os-event m-down @@ -221,10 +230,10 @@ (defobserver mouse-up-evt (self up) (when up ;; should be since this is ephemeral, but still.. - (trc nil "mouseup" self up (mouse-control self)) + (trc "mouseup" self up (mouse-control self)) (bwhen (clickee (mouse-control self)) (bwhen (upper (mouse-up-handler clickee)) - (trc nil "mouseup clickee, clickw" clickee self) + (trc "mouseup clickee, clickw" clickee self) (funcall upper clickee up))))) (defparameter *gw* nil) @@ -242,15 +251,15 @@ (gl-hint gl_perspective_correction_hint gl_nicest)) (defun cello-gl-init () - (trc "clearing gl errors....") + (trc nil "clearing gl errors....") (loop for ct upfrom 0 - until (zerop (eko ("cleared gl errorr") + until (zerop (eko (nil "cleared gl errorr") (glGetError))) when (> ct 10) do #-lispworks (c-break "gl-init") #+lispworks (return-from cello-gl-init)) - (macrolet ((glm (param num) + #+shhh (macrolet ((glm (param num) (declare (ignore num)) `(trc ,(symbol-name param) (ogl-get-int ,param)))) (glm gl_max_list_nesting 0) --- /project/cello/cvsroot/cello/lighting.lisp 2006/06/26 17:05:20 1.5 +++ /project/cello/cvsroot/cello/lighting.lisp 2006/10/02 02:59:18 1.6 @@ -62,7 +62,7 @@ :ambient *dim* :diffuse *bright* :specular *bright*) - #+(or) (make-instance 'light + (make-instance 'light :id gl_light1 :enabled t :pos (make-ff-array :float 700 (downs 600) (nearer 200) 1) @@ -93,7 +93,7 @@ (loop for light in (fixed-lighting self) do (ix-render-light light)) (when (and (not lights) (emergency-lighting self)) - (trc nil "emergency lighting" self) + (trc "emergency lighting!!!!!!!!!!" self) (dolist (e-light (emergency-lighting self)) (ix-render-light e-light))))) --- /project/cello/cvsroot/cello/mouse-click.lisp 2006/06/11 13:32:24 1.5 +++ /project/cello/cvsroot/cello/mouse-click.lisp 2006/10/02 02:59:18 1.6 @@ -29,27 +29,27 @@ (click-age :initform (c? (- (sys-time *sys*) (evt-when (os-event self)))) :documentation "Unreliable unless click-repeat-p forcing events") (click-completed :reader click-completed - :initform (c? (when (typep (click-window self) 'window) ;; <- acl used to turn windows into + :initform (c? (when (typep (click-window self) 'model) ;; <- acl used to turn windows into (mouse-up-evt (click-window self))))) ;; closed-stream instances (click-over :reader click-over - :initform (c? (when (typep (click-window self) 'window) + :initform (c? (when (typep (click-window self) 'model) (unless (^click-completed) (when (mouse-over-p (clickee self)) (mouse-pos (click-window self))))))) (in-drag :reader in-drag - :initform (c? (when (typep (click-window self) 'window) + :initform (c? (when (typep (click-window self) 'model) (unless (^click-completed) (when (mouse-over-p (clickee self)) (mouse-pos (click-window self))))))) (clicked :reader clicked - :initform (c? (trc nil "clicked?> typeof clickw" (click-window self) (type-of (click-window self))) - (when (typep (click-window self) 'window) - (trc nil "clicked?> asking clickcompleted") + :initform (c? (trc "clicked?> typeof clickw" (click-window self) (type-of (click-window self))) + (when (typep (click-window self) 'model) + (trc "clicked?> asking clickcompleted") (bwhen (up (^click-completed)) - (trc nil "clicked?> asking point-in-box" + (trc "clicked?> asking point-in-box" (evt-where up) (clickee self) (without-c-dependency @@ -63,15 +63,16 @@ :expiration (c? (mouse-up-evt (click-window self))))) (defmethod initialize-instance :after ((self mouse-click) &key) - (when (typep (clickee self) 'focus) - (unless (control-key-down (evt-buttons (os-event self))) ;; lame debugging enabler; make better - (focus-navigate (focus (click-window self)) (clickee self)))) + (with-integrity (:change :ii-mouseclick) + (when (typep (clickee self) 'focus) + (unless (control-key-down (evt-buttons (os-event self))) ;; lame debugging enabler; make better + (focus-navigate (focus (click-window self)) (clickee self)))) - ;;;20060601 (to-be self) ;; unnecessary? 2301kt just moved this from after next line - (trc nil "echo click set self clickee" self (clickee self)) + ;;;20060601 (to-be self) ;; unnecessary? 2301kt just moved this from after next line + (trc "echo click set self clickee" self (clickee self)) - (when (clickee self) - (setf (click-evt (clickee self)) self))) + (when (clickee self) + (setf (click-evt (clickee self)) self)))) (defmethod (setf click-evt) :around (new-click self) (when (or (null new-click) @@ -91,7 +92,7 @@ (defmethod not-to-be :around ((self mouse-click)) (when (typep (click-window self) 'window) ;; /// why worry about this? - (trc nil "echo click clearing self from clickee" (clickee self)) + (trc "echo click clearing self from clickee" (clickee self)) (setf (click-evt (clickee self)) nil) ;; do this first? ;; (trc "echo click not-to-be-ing self from clickee" self) (call-next-method) @@ -99,8 +100,9 @@ )) (defobserver clicked () + (trc "echo clicked " self new-value) (when (and new-value (click-window self)) - (trc nil "echo clicked calling control-do-action" self new-value) + (trc "echo clicked calling control-do-action" self new-value) (control-do-action (car new-value) (cdr new-value)))) ;----------------------------------------

1 0

[cello-cvs] CVS cello
by fgoenninger 01 Oct '06

01 Oct '06

Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv21334 Modified Files: ix-opengl.lisp Log Message: Minor change only. Added some comments and code reformatted. --- /project/cello/cvsroot/cello/ix-opengl.lisp 2006/08/28 21:45:22 1.5 +++ /project/cello/cvsroot/cello/ix-opengl.lisp 2006/10/01 20:47:54 1.6 @@ -17,13 +17,20 @@ (in-package :cello) +(export! .og. + .ogc. + ogl-shared-resource-tender + ogl-node + ogl-family + dsp-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 () +(defclass ogl-shared-resource-tender () ;; mixin ((display-lists :initform nil :accessor display-lists) (quadrics :initform nil :accessor quadrics) (textures :initform nil :accessor textures))) @@ -44,8 +51,6 @@ (defmethod ogl-node-window (other) (c-break "ogl-node-window undefined for ~a" other)) -(export! .og. .ogc.) - (define-symbol-macro .og. (or (ogl-context self) (setf (ogl-context self) (upper self ctk::togl)))) @@ -55,30 +60,30 @@ (defmodel ogl-node () ((ogl-context :cell nil :initform nil :accessor ogl-context) (dsp-list :initarg :dsp-list :accessor dsp-list - :initform nil #+not (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))))) + :initform (c-in nil) + #+not (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*) (assert (zerop (glgeterror))) @@ -86,12 +91,11 @@ (trc nil "render" self (^height)) (ix-paint self)))) -(defmodel ogl-family () +(defmodel ogl-family () ;; mixin () - (:default-initargs :gl-name (c? (incf (gl-name-highest .w.))) - :clipped nil)) + :clipped nil)) (defobserver dsp-list () (when old-value

1 0

[cello-cvs] CVS cello
by fgoenninger 01 Oct '06

01 Oct '06

Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv21204 Modified Files: ix-paint.lisp Log Message: Minor change only. Code reformatted. --- /project/cello/cvsroot/cello/ix-paint.lisp 2006/08/28 21:45:22 1.4 +++ /project/cello/cvsroot/cello/ix-paint.lisp 2006/10/01 20:46:51 1.5 @@ -5,7 +5,7 @@ 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. +(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. @@ -32,15 +32,16 @@ (ogl-raster-pos-get)) (assert (find k (kids self))() "kid ~a no longer amongst kids ~a" k (kids self)) (c-assert (px k) () "pX is null in ~a" k) - (c-assert (py k) () "pY is null in ~a" k) - + (c-assert (py k) () "pY is null in ~a" k) (if (dsp-list k) (progn (count-it :call-list) (trc "ix-paint calling list" (dsp-list k)) - (gl-call-list (dsp-list k))) ; 06/0629 edit caret presences causes INVALID_OP on - ; first run only in a session; just continue from + (gl-call-list (dsp-list k))) ;; 06/06/29 edit caret presences + ;; causes INVALID_OP on + ;; first run only in a session; + ;; just continue from (ix-paint k))))) (defun rpchk (id pfail psucc &optional self)

1 0

[cello-cvs] CVS cello
by fgoenninger 01 Oct '06

01 Oct '06

Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv21056 Modified Files: ix-togl.lisp Log Message: Minor change only. Code formatted differently. --- /project/cello/cvsroot/cello/ix-togl.lisp 2006/09/05 23:05:36 1.9 +++ /project/cello/cvsroot/cello/ix-togl.lisp 2006/10/01 20:46:00 1.10 @@ -70,17 +70,18 @@ )) (export! .togl) + (define-symbol-macro .togl (nearest self ix-togl)) (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)) + (c-stopped)) (with-metrics (nil nil "ctk::togl-display-using-class") - (bif (dl (dsp-list self)) - (progn - (trc "togl display using disp list !!!!" self) - (gl-call-list (dsp-list self))) - (ix-paint self))))) + (bif (dl (dsp-list self)) + (progn + (trc "togl display using disp list !!!!" self) + (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

1 0

[cello-cvs] CVS cello/kt-opengl
by fgoenninger 01 Oct '06

01 Oct '06

Update of /project/cello/cvsroot/cello/kt-opengl In directory clnet:/tmp/cvs-serv20896 Modified Files: defpackage.lisp Log Message: Added. Some futher expors of symbols. --- /project/cello/cvsroot/cello/kt-opengl/defpackage.lisp 2006/10/01 12:28:58 1.1 +++ /project/cello/cvsroot/cello/kt-opengl/defpackage.lisp 2006/10/01 20:45:04 1.2 @@ -20,7 +20,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Id: defpackage.lisp,v 1.1 2006/10/01 12:28:58 fgoenninger Exp $ +;;; $Id: defpackage.lisp,v 1.2 2006/10/01 20:45:04 fgoenninger Exp $ (pushnew :kt-opengl *features*) @@ -50,6 +50,7 @@ #:with-gl-doubles #:with-display-list #:with-gl-translation + #:with-ogl-isolation #:gl-pushm #:gl-popm @@ -62,12 +63,30 @@ #:ogl-get-int #:ogl-get-boolean + #:v3i + #:make-v3i + #:mk-vertex3i + #:v3i-x + #:v3i-y + #:v3i-z + #:mkv3i + #:v3f #:make-v3f + #:mk-vertex3f #:v3f-x #:v3f-y #:v3f-z + #:mkv3f + #:v3d + #:make-v3d + #:mk-vertex3d + #:v3d-x + #:v3d-y + #:v3d-z + #:mkv3d + #:xlin #:xlout #:farther @@ -79,6 +98,8 @@ #:ogl-texture-delete #:ogl-tex-gen-setup #:ogl-tex-activate + + #:ogl-current-color #:ogl-bounds #:ogl-scissor-box

1 0

[cello-cvs] CVS cello/kt-opengl
by fgoenninger 01 Oct '06

01 Oct '06

Update of /project/cello/cvsroot/cello/kt-opengl In directory clnet:/tmp/cvs-serv20668 Modified Files: ogl-utils.lisp Log Message: Code cleanup. Added: Type declarations and compiler directives. --- /project/cello/cvsroot/cello/kt-opengl/ogl-utils.lisp 2006/10/01 12:30:14 1.7 +++ /project/cello/cvsroot/cello/kt-opengl/ogl-utils.lisp 2006/10/01 20:44:22 1.8 @@ -22,10 +22,82 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Id: ogl-utils.lisp,v 1.7 2006/10/01 12:30:14 fgoenninger Exp $ +;;; $Id: ogl-utils.lisp,v 1.8 2006/10/01 20:44:22 fgoenninger Exp $ + +(declaim (optimize (debug 1) (speed 3) (safety 1) (compilation-speed 0))) (in-package :kt-opengl) +;;; =========================================================================== +;;; SPECIAL / GLOBAL VARS +;;; =========================================================================== + +(defparameter *textures-1* (fgn-alloc 'gluint 1 :ignore)) +(defparameter *new-listing* nil) + +(defparameter *dbg-viewport-r* (fgn-alloc 'glint 4 :ignore)) + +;;; =========================================================================== +;;; DATA STRUCTURES / DATA DEFINITIONS +;;; =========================================================================== + +(defstruct v3i + (x :type GLint) + (y :type GLint) + (z :type GLint)) + +(defstruct v3f + (x :type GLfloat) + (y :type GLfloat) + (z :type GLfloat)) + +(defstruct v3d + (x :type GLdouble) + (y :type GLdouble) + (z :type GLdouble)) + +;;; =========================================================================== +;;; FUNCTIONS +;;; =========================================================================== + +;;; --------------------------------------------------------------------------- +;;; CONSTRUCTORS +;;; --------------------------------------------------------------------------- + +(defun mk-vertex3i (x y z) + (make-v3i :x x :y y :z z)) + +(defun mk-vertex3f (x y z) + (make-v3f :x x :y y :z z)) + +(defun mk-vertex3d (x y z) + (make-v3d :x x :y y :z z)) + +(defmacro mkv3i (v3i-lists) + `(mapcar #'(lambda (vtx) + (mk-vertex3i (first vtx) + (second vtx) + (third vtx))) + ',v3i-lists)) + +(defmacro mkv3f (v3f-lists) + `(mapcar #'(lambda (vtx) + (mk-vertex3f (first vtx) + (second vtx) + (third vtx))) + ',v3f-lists)) + +(defmacro mkv3d (v3d-lists) + `(mapcar #'(lambda (vtx) + (mk-vertex3d (first vtx) + (second vtx) + (third vtx))) + ',v3d-lists)) + +;;; --------------------------------------------------------------------------- +;;; TEXTURE SUPPORT +;;; --------------------------------------------------------------------------- + (defun ogl-tex-activate (tex-name) (assert tex-name) ;;(print `(ogl-tex-activate doing ,tex-name)) @@ -33,8 +105,6 @@ (gl-bind-texture gl_texture_2d tex-name) (gl-polygon-mode gl_front_and_back gl_fill)) ;; just front ? -(defparameter *textures-1* (fgn-alloc 'gluint 1 :ignore)) - (defun ogl-texture-delete (texture-name) ;;(print `(deleting-tx ,texture-name)) (setf (ff-elt *textures-1* gluint 0) texture-name) @@ -86,7 +156,6 @@ (gl-get-integerv gl_scissor_box box) box)) -(ukt::export! ogl-current-color) (defun ogl-current-color () (let ((rgba (fgn-alloc 'glint 4 :ogl-current-color))) (gl-get-integerv gl_current_color rgba) @@ -98,34 +167,38 @@ (defun farther (&rest values) (apply '- values)) + (defun xlin (&rest values) ;; yep. moves matrix, not object (apply '+ values)) (defun nearer (&rest values) (apply '+ values)) + (defun xlout (&rest values) ;; yep. moves matrix, not object (apply '- values)) (defun ncalc-normalf(v0x v0y v0z v1x v1y v1z v2x v2y v2z &aux d0x d0y d0z d1x d1y d1z) + (declare (type GLfloat + v0x v0y v0z v1x v1y v1z v2x v2y v2z + d0x d0y d0z d1x d1y d1z)) + (setf d0x (- v1x v0x) - d0y (- v1y v0y) - d0z (- v1z v0z)) + d0y (- v1y v0y) + d0z (- v1z v0z)) (setf d1x (- v2x v1x) - d1y (- v2y v1y) - d1z (- v2z v1z)) + d1y (- v2y v1y) + d1z (- v2z v1z)) (xgl-normalize-v3f (- (* d0y d1z) (* d0z d1y)) (- (* d0z d1x) (* d0x d1z)) (- (* d0x d1y) (* d0y d1x)))) - -(defstruct v3f - (x 0)(y 0)(z 0)) - (defun xgl-normalize-v3f (x y z) + (declare (type GLfloat x y z)) + (let ((m2 (+ (* x x) (* y y) (* z z)))) (if (zerop m2) (values x y z) @@ -134,11 +207,6 @@ ;;(cells::count-it :normalize-3f) (values (+ (/ x m)) (+ (/ y m)) (+ (/ z m))))))) -;;;(cffi-uffi-compat:def-foreign-type bool* (* glboolean)) -;;; -;;;#-lispworks -;;;(declaim (type bool* *ogl-boolean*)) - (defparameter *ogl-boolean* (fgn-alloc 'glboolean 1 :ignore)) @@ -146,11 +214,6 @@ (gl-get-booleanv gl-code *ogl-boolean*) (not (zerop (cffi-uffi-compat:deref-array *ogl-boolean* '(:array glboolean) 0)))) -;;;(cffi-uffi-compat:def-foreign-type glint* (* glint)) -;;; -;;;#-lispworks -;;;(declaim (type glint* *ogl-int*)) - (defparameter *ogl-int* (fgn-alloc 'glint 1 :ignore)) @@ -168,9 +231,6 @@ (gl-get-integerv gl-code *ogl-int*) (eltgli *ogl-int* 0)) -(defparameter *dbg-viewport-r* - (fgn-alloc 'glint 4 :ignore)) - (defun dump-viewport (key) (gl-get-integerv gl_viewport *dbg-viewport-r*) (format t "~&dump-viewport> ~a: ~a" key @@ -245,8 +305,6 @@ (loop for (key . list) in (ogl-list-cache node) do (format t "~d : ~a" list key))) -(defparameter *new-listing* nil) - (defun flatten (&rest args) (mapcan (lambda (arg) (if (consp arg)

1 0

[cello-cvs] CVS cello/kt-opengl
by fgoenninger 01 Oct '06

01 Oct '06

Update of /project/cello/cvsroot/cello/kt-opengl In directory clnet:/tmp/cvs-serv20427 Modified Files: ogl-macros.lisp Log Message: Code cleanup. --- /project/cello/cvsroot/cello/kt-opengl/ogl-macros.lisp 2006/10/01 12:30:01 1.9 +++ /project/cello/cvsroot/cello/kt-opengl/ogl-macros.lisp 2006/10/01 20:42:51 1.10 @@ -93,6 +93,10 @@ (gl-pop-client-attrib) (glec :with-client-attrib-pop))) +(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) + ,@body)) + (defvar *gl-begun*) (defvar *gl-stop*)

1 0

[cello-cvs] CVS cello
by fgoenninger 01 Oct '06

01 Oct '06

Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv20281 Modified Files: cello.lisp Log Message: Added: Exports for ct-... symbols. --- /project/cello/cvsroot/cello/cello.lisp 2006/08/28 21:45:22 1.12 +++ /project/cello/cvsroot/cello/cello.lisp 2006/10/01 20:41:53 1.13 @@ -15,7 +15,7 @@ |# -;;; $Id: cello.lisp,v 1.12 2006/08/28 21:45:22 ktilton Exp $ +;;; $Id: cello.lisp,v 1.13 2006/10/01 20:41:53 fgoenninger Exp $ ;;; ============================================================================ @@ -37,11 +37,34 @@ #:cl-openal #:cl-ftgl #:cl-magick) + (:export + #:cello-window #:cello-window-event-handler #:with-layers #:visible + + #:ct-button + #:ct-drag + #:ct-poly-drag + #:ct-mark-box + #:ct-radio-item + #:ct-radio-button + #:ct-text-radio-item + #:ct-radio + #:ct-radio-row + #:ct-radio-stack + #:ct-radio-push-button + #:ct-push-toggle + #:ct-selector + #:ct-selector-inline + #:ct-selectable + #:ct-text + #:ct-toggle + #:ct-twister + #:ct-jumper + #:ix-togl)) ;;; ============================================================================

1 0

[cello-cvs] CVS cello/kt-opengl
by fgoenninger 01 Oct '06

01 Oct '06

Update of /project/cello/cvsroot/cello/kt-opengl In directory clnet:/tmp/cvs-serv20208 Modified Files: kt-opengl.lisp Log Message: Code cleanup. --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lisp 2006/10/01 13:03:32 1.8 +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lisp 2006/10/01 13:41:30 1.9 @@ -21,83 +21,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Id: kt-opengl.lisp,v 1.8 2006/10/01 13:03:32 fgoenninger Exp $ - -(pushnew :kt-opengl *features*) - -(defpackage #:kt-opengl - (:nicknames #:ogl) - (:use #:common-lisp #:cffi #:ffx) - (:export - - #:kt-opengl-init - #:kt-opengl-reset - #:glec - - #:*ogl-listing-p* - #:*selecting* - - #:with-matrix - #:with-attrib - #:with-client-attrib - #:with-gl-begun - #:with-gl-param - #:with-bitmap-shifted - #:with-gl-parami - #:with-gl-paramf - #:with-gl-paramd - #:with-gl-integers - #:with-gl-floats - #:with-gl-doubles - #:with-display-list - #:with-gl-translation - - #:gl-pushm - #:gl-popm - - #:closed-stream-p - - #:ncalc-normalf - #:ncalc-normalfv - - #:ogl-get-int - #:ogl-get-boolean - - #:v3f - #:make-v3f - #:v3f-x - #:v3f-y - #:v3f-z - - #:xlin - #:xlout - #:farther - #:nearer - - #:texture-name - #:ogl-texture - #:ogl-texture-gen - #:ogl-texture-delete - #:ogl-tex-gen-setup - #:ogl-tex-activate - - #:ogl-bounds - #:ogl-scissor-box - #:ogl-raster-pos-get - - #:ogl-pen-move - - #:ogl-list-cache - #:ogl-lists-delete - - #:eltgli - - #:gl-name - - #:gl-get-integers - #:gl-get-floats - #:gl-get-doubles - )) +;;; $Id: kt-opengl.lisp,v 1.9 2006/10/01 13:41:30 fgoenninger Exp $ (in-package :kt-opengl)

1 0

[cello-cvs] CVS cello/kt-opengl
by fgoenninger 01 Oct '06

01 Oct '06

Update of /project/cello/cvsroot/cello/kt-opengl In directory clnet:/tmp/cvs-serv14796 Modified Files: kt-opengl.lisp Log Message: Code cleanup. --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lisp 2006/10/01 12:29:44 1.7 +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lisp 2006/10/01 13:03:32 1.8 @@ -21,7 +21,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Id: kt-opengl.lisp,v 1.7 2006/10/01 12:29:44 fgoenninger Exp $ +;;; $Id: kt-opengl.lisp,v 1.8 2006/10/01 13:03:32 fgoenninger Exp $ (pushnew :kt-opengl *features*) @@ -127,25 +127,3 @@ when (zerop ec) do (cells::trc "kt-opengl-reset sees zero error code") (loop-finish) do (cells::trc "kt-opengl-init sees error" ec))) - -(defun gl-boolean-test (value) - #+allegro (not (eql value #\null)) - #-allegro (not (zerop value))) - -(defun dump-lists (min max) - (loop with start - and end - for lx from min to max - when (let ((is (gl-is-list lx))) - (when (gl-boolean-test is) - (print (list "dl test" lx is (char-code is)))) - (gl-boolean-test is)) - do (if start - (if end - (if (eql lx (1+ end)) - (setf end lx) - (print `(gl ,start to ,end))) - (if (eql lx (1+ start)) - (setf end lx) - (print `(gl ,start)))) - (setf start lx))))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

cello-cvs October 2006