[cello-cvs] CVS cello
ktilton
ktilton at common-lisp.net
Fri Oct 13 05:57:27 UTC 2006
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
, at 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))))
;----------------------------------------
More information about the Cello-cvs
mailing list