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))))
;----------------------------------------