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