[cello-cvs] CVS cello
ktilton
ktilton at common-lisp.net
Fri Feb 2 20:11:02 UTC 2007
Update of /project/cello/cvsroot/cello
In directory clnet:/tmp/cvs-serv2070
Modified Files:
application.lisp cello-magick.lisp cello.lisp cello.lpr
control.lisp ctl-markbox.lisp ctl-toggle.lisp focus.lisp
image.lisp ix-canvas.lisp ix-layer-expand.lisp ix-paint.lisp
ix-togl.lisp mouse-click.lisp
Log Message:
--- /project/cello/cvsroot/cello/application.lisp 2006/11/13 05:29:26 1.9
+++ /project/cello/cvsroot/cello/application.lisp 2007/02/02 20:11:00 1.10
@@ -20,6 +20,8 @@
(defparameter *first-kill-all-the-windows* nil)
+(export! cello-reset)
+
(defun cello-reset (&optional (system-type 'mg-system))
;; Reset CFFI, CFFI Extender
--- /project/cello/cvsroot/cello/cello-magick.lisp 2006/11/04 20:56:30 1.6
+++ /project/cello/cvsroot/cello/cello-magick.lisp 2007/02/02 20:11:00 1.7
@@ -53,23 +53,29 @@
(ogl::glec :snapshot)
(record-frame recording pixels columns rows))))
-(defmodel ix-wander (ix-view)
- ((wander :initarg :wander :accessor wander :initform nil)) ;;///just use skin?
- (:default-initargs
- :pre-layer (c? (with-layers (:wand (^wander))))))
-
-(defmodel ix-image-file (ix-wander)
- ((wand-type :initarg :wand-type :accessor wand-type :initform 'wand-pixels))
- (:default-initargs
- :wander (c? (if (^value)
- (let ((wand (wand-ensure-typed (^wand-type) (^value))))
- (assert wand () "Unable to load image file ~a" (^value))
- wand)
- (error "ix-image-file requires value of path to image file")))
- :pre-layer (c? (with-layers +white+ (:wand (^wander))))
- :ll 0 :lt 0 :lb (c? (downs (cdr (image-size (^wander)))))
- :lr (c? (car (image-size (^wander))))
- ))
+(defmd ix-image-file (ix-view)
+ (:documentation "Quick way to drop a view of a binary JPG, PNG, GIF, etc into a Cello window")
+ image-path
+ (mode :texture :documentation ":texture or :pixel, as in OpenGL")
+ tilep
+ transparency
+ :value (c? (if (^image-path)
+ (let ((wand (wand-ensure-typed
+ (ecase (^mode) (:texture 'wand-texture)(:pixel 'wand-pixel))
+ (^image-path)
+ :tilep (^tilep)
+ :storage (if (^transparency) gl_rgba gl_rgb))))
+ (assert wand () "Unable to load image file ~a" (^value))
+ wand)
+ (trc "ix-image-file has no path to image file!!!!!" self)))
+ :pre-layer (c? (bwhen (w (^value))
+ (with-layers +white+ (:wand w))))
+ :ll 0 :lt 0 :lb (c? (bif (w (^value))
+ (downs (cdr (image-size w)))
+ 0))
+ :lr (c? (bif (w (^value))
+ (car (image-size (^value)))
+ 0)))
(defparameter *mapping-textures* nil)
--- /project/cello/cvsroot/cello/cello.lisp 2006/10/17 21:30:08 1.14
+++ /project/cello/cvsroot/cello/cello.lisp 2007/02/02 20:11:00 1.15
@@ -15,7 +15,7 @@
|#
-;;; $Id: cello.lisp,v 1.14 2006/10/17 21:30:08 ktilton Exp $
+;;; $Id: cello.lisp,v 1.15 2007/02/02 20:11:00 ktilton Exp $
;;; ============================================================================
@@ -26,7 +26,7 @@
(:nicknames :clo)
(:use
#:common-lisp
- #-(or ccl cormanlisp sbcl) #:clos
+ #-(or ccl cormanlisp sbcl openmcl) #:clos
#:utils-kt
#:cells
#:gui-geometry
@@ -79,7 +79,7 @@
(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.)))
+(define-symbol-macro .retog. (when (and .og. .ogc.) (togl-post-redisplay .ogc.)))
;;; ============================================================================
;;; MISC
--- /project/cello/cvsroot/cello/cello.lpr 2006/11/13 05:29:26 1.16
+++ /project/cello/cvsroot/cello/cello.lpr 2007/02/02 20:11:00 1.17
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*-
(in-package :cg-user)
--- /project/cello/cvsroot/cello/control.lisp 2006/11/13 05:29:26 1.8
+++ /project/cello/cvsroot/cello/control.lisp 2007/02/02 20:11:00 1.9
@@ -15,7 +15,7 @@
|#
(in-package :cello)
-(export! control enabled ^enabled)
+(export! control enabled ^enabled ct-action-lambda)
(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)))))))
@@ -37,6 +37,11 @@
(kb-selector nil :cell nil)
:gl-name (c? (incf (gl-name-highest .w.))))
+(defmacro ct-action-lambda (&body body)
+ `(lambda (self event)
+ (declare (ignorable self event))
+ , at body))
+
(defmethod kb-selector (other) (declare (ignore other)) nil)
(defobserver click-repeat-event ()
--- /project/cello/cvsroot/cello/ctl-markbox.lisp 2006/11/13 05:29:26 1.11
+++ /project/cello/cvsroot/cello/ctl-markbox.lisp 2007/02/02 20:11:00 1.12
@@ -63,9 +63,9 @@
(:default-initargs
:enabled t
:value (c? (find (associated-value self) (value (^radio))))
- :ct-action (lambda (self event)
- (with-cc :ct-radio-item
- (radio-item-to-value self event (^radio))))))
+ :ct-action (ct-action-lambda
+ (with-cc :ct-radio-item
+ (radio-item-to-value self event (^radio))))))
(defun radio-item-to-value (self event radio)
@@ -89,7 +89,7 @@
(defobserver .value ((self ct-radio)) ;; /// should every control have this?
(when (^on-change)
- (trcx radio-value-observer self new-value old-value old-value-boundp)
+ ;(trcx 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)
@@ -137,11 +137,10 @@
:text$ (c? (title$ .parent))
:style-id :button)))
- :ct-action (lambda (self event)
- (declare (ignorable event))
- (trc nil "checktext bingo" (not (value self)))
- (with-cc :check-text-action
- (setf (value self) (not (value self)))))))
+ :ct-action (ct-action-lambda
+ (trc nil "checktext bingo" (not (value self)))
+ (with-cc :check-text-action
+ (setf (value self) (not (value self)))))))
(defmodel ct-radio-labeled (ix-row ct-radio-item)
()
--- /project/cello/cvsroot/cello/ctl-toggle.lisp 2006/11/13 05:29:26 1.10
+++ /project/cello/cvsroot/cello/ctl-toggle.lisp 2007/02/02 20:11:00 1.11
@@ -39,8 +39,7 @@
(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))
+ :ct-action (ct-action-lambda
(with-cc :button-press
.retog.
(setf (^value) t)))
@@ -89,10 +88,9 @@
`(make-instance 'ct-button
:fm-parent *parent*
:title$ ,text
- :ct-action (lambda (self event)
- (declare (ignorable self event))
- (with-cc :ct-button-ex-ct-action
- ,command))
+ :ct-action (ct-action-lambda
+ (with-cc :ct-button-ex-ct-action
+ ,command))
, at initargs))
(defmodel ct-selectable-button (ct-selectable ct-button)())
@@ -112,12 +110,11 @@
#'eql)))
(car state-table)))
- :ct-action (lambda (self event)
- (declare (ignorable event))
- (trc "twister ct-action" self event)
- (with-integrity (:change :ctfsm-action)
- (let ((newv (funcall (transition-fn self) (value self) (states self))))
- (ct-fsm-assume-value self newv))))))
+ :ct-action (ct-action-lambda
+ (trc "twister ct-action" self event)
+ (with-integrity (:change :ctfsm-action)
+ (let ((newv (funcall (transition-fn self) (value self) (states self))))
+ (ct-fsm-assume-value self newv))))))
(defmethod ct-fsm-assume-value (self new-value)
(setf (value self) new-value))
@@ -149,15 +146,7 @@
'((4 . -2) (9 . -7) (4 . -12))))
:ll 0 :lt 0 :lr (u96ths 15) :lb (downs (u96ths 15))))
-(defmethod (setf .value) :around (new (self ct-twister))
- (trcx ct-twister-value-set!!!!!!!!!!!! self new)
- (call-next-method))
-
-(defobserver .value ((self ct-twister))
- (when (eq :show-contents (md-name self))
- (trcx contents-twister-value-changing!!!!!!! new-value old-value old-value-boundp)))
-
-(export! a-twister)
+(export! a-twister ix-twister ct-radio-tree expanded ^initial-open initial-open ^selectedp selectedp)
(defmacro a-twister ((label component-args initial-open &rest twister-args) twisted-widget)
`(a-stack (, at component-args)
@@ -173,13 +162,75 @@
:text$ ,label
:style-id :button)
label)) ;; actually should be a form to build a widget
- (a-stack (:collapsed (c? (eko ("collapsed!!!!!!!!!!!!" .cause)
+ (a-stack (:collapsed (c? (eko (nil "collapsed!!!!!!!!!!!!" .cause)
(let ((tw (fm^ :show-contents)))
(assert (eq .parent (fm-parent (fm-parent tw))))
(not (value tw))))))
,twisted-widget)))
+(defmd ix-twister (ix-stack)
+ label
+ initial-open
+ twisted-widget
+ :kids (c? (let ((label (^label)))
+ (the-kids
+ (a-stack ()
+ (a-row ()
+ (or (car .cache)
+ (make-kid 'ct-twister
+ :md-name :show-contents
+ :value (c?n (initial-open (u^ ix-twister)))
+ :visible (c? (^enabled))))
+ (if (stringp label)
+ (make-kid 'ix-text
+ :text$ label
+ :style-id :button)
+ label))
+ (a-stack (:px 8 :collapsed (c? (let ((tw (fm^ :show-contents)))
+ (not (value tw)))))
+ (let ((spec (twisted-widget (u^ ix-twister))))
+ (apply 'make-instance (car spec)
+ :fm-parent self (cdr spec)))))))))
+
+(export! selectorp selection label ^selectorp ^selection ^label tree-label ^tree-label
+ ^kids-factory kids-factory)
+
+(defmd ct-radio-tree (ix-stack control)
+ (tree-label (c? (princ (^value))))
+ selectorp
+ (selectedp (c? (eq self (selection (selector self)))))
+ selection
+ label
+ initial-open
+ (expanded (c? (or (fm-descendant-if self 'selectedp)
+ (unless .cache (^initial-open)))))
+ kids-factory
+ :kids (c? (let ((label (^tree-label))
+ (tree self))
+ (the-kids
+ (if (stringp label)
+ (make-kid 'ct-button
+ :text$ label
+ :style-id :button
+ :ct-action (ct-action-lambda
+ #+ugly (with-cc :ct-radio-item-focus-clear
+ (setf .focus nil))
+ (with-cc :ct-radio-item
+ #+xxx (trcx tree-sets-sel (selector self) tree)
+ (setf (selection (selector self)) tree))))
+ label)
+ (bwhen (f (^kids-factory))
+ (a-stack (:px 8 :collapsed (c? (not (expanded tree))))
+ (funcall f self)))))))
+
+(defgeneric selectedp (self)
+ (:method (self) (declare (ignore self)) nil))
+
+(defgeneric selectorp (self)
+ (:method (self) (declare (ignore self)) nil))
+(defmethod selector (self)
+ (fm-ascendant-if self 'selectorp))
#| vestigial?
--- /project/cello/cvsroot/cello/focus.lisp 2006/11/13 05:29:26 1.5
+++ /project/cello/cvsroot/cello/focus.lisp 2007/02/02 20:11:00 1.6
@@ -34,13 +34,12 @@
it without it being a kid there
|#
-(eval-now!
- (export '(^focus focus)))
+
(defmodel focuser (ix-canvas)
(
(focus :initarg :focus
- :initform (c-in nil)
+ :initform (c-input-dbg nil)
:accessor focus)
(textual-focus :initarg :textual-focus
@@ -80,6 +79,10 @@
; (mkPart :selBox (IXEditSelection))
))))
+
+(export! ^focus focus .focus)
+(define-symbol-macro .focus (focus .tkw))
+
(defun focuser (self)
(swdw)
)
--- /project/cello/cvsroot/cello/image.lisp 2006/11/04 20:56:30 1.17
+++ /project/cello/cvsroot/cello/image.lisp 2007/02/02 20:11:00 1.18
@@ -68,6 +68,12 @@
;
(.window-cache :cell nil :initarg :window-cache :initform nil :accessor window-cache)))
+(defobserver pre-layer ()
+ .retog.)
+
+(defobserver visible ()
+ .retog.)
+
;;------- IXFamily -----------------------------
;;
(defmodel ix-family (ix-view family)
@@ -279,6 +285,7 @@
(defmacro with-layers (&rest layers)
(flet ((collect-output (layers)
+ ;;(print (list "layers are" layers))
(let (output)
(dolist (layer layers)
(typecase layer
--- /project/cello/cvsroot/cello/ix-canvas.lisp 2006/10/17 21:30:08 1.5
+++ /project/cello/cvsroot/cello/ix-canvas.lisp 2007/02/02 20:11:00 1.6
@@ -16,6 +16,8 @@
(in-package :cello)
+
+
(defmodel ix-canvas (ix-family)
(
(target-res :initarg :target-res
--- /project/cello/cvsroot/cello/ix-layer-expand.lisp 2006/11/03 13:38:24 1.10
+++ /project/cello/cvsroot/cello/ix-layer-expand.lisp 2007/02/02 20:11:00 1.11
@@ -21,30 +21,32 @@
(defmethod ix-layer-expand ((key (eql :rgba)) &rest args)
`(ix-render-rgba ,(car args)))
+(export! ix-render-rgba)
+
(defun ix-render-rgba (rgba)
(gl-color4fv (rgba-fo rgba)))
-(defmacro def-layer-expansion (color)
+(defmacro def-layer-rgba-expansion (color)
`(defmethod ix-layer-expand ((key (eql ',color)) &rest args)
(declare (ignore args))
`(ix-render-rgba ,',color)))
-(def-layer-expansion +white+)
-(def-layer-expansion +red+)
-(def-layer-expansion +dark-green+)
-(def-layer-expansion +green+)
-(def-layer-expansion +turquoise+)
-(def-layer-expansion +dark-blue+)
-(def-layer-expansion +blue+)
-(def-layer-expansion +light-blue+)
-(def-layer-expansion +black+)
-(def-layer-expansion +yellow+)
-(def-layer-expansion +light-yellow+)
-(def-layer-expansion +purple+)
-(def-layer-expansion +gray+)
-(def-layer-expansion +light-gray+)
-(def-layer-expansion +dark-gray+)
+(def-layer-rgba-expansion +white+)
+(def-layer-rgba-expansion +red+)
+(def-layer-rgba-expansion +dark-green+)
+(def-layer-rgba-expansion +green+)
+(def-layer-rgba-expansion +turquoise+)
+(def-layer-rgba-expansion +dark-blue+)
+(def-layer-rgba-expansion +blue+)
+(def-layer-rgba-expansion +light-blue+)
+(def-layer-rgba-expansion +black+)
+(def-layer-rgba-expansion +yellow+)
+(def-layer-rgba-expansion +light-yellow+)
+(def-layer-rgba-expansion +purple+)
+(def-layer-rgba-expansion +gray+)
+(def-layer-rgba-expansion +light-gray+)
+(def-layer-rgba-expansion +dark-gray+)
(defmethod ix-layer-expand ((key (eql :fill)) &rest args)
@@ -115,6 +117,7 @@
(defmethod ix-layer-expand ((self (eql :poly-mode)) &rest args)
`(gl-polygon-mode ,(car args) ,(cadr args)))
+
(defmethod ix-layer-expand ((self (eql :nice-lines)) &rest args)
`(progn
(gl-disable gl_texture_2d)
--- /project/cello/cvsroot/cello/ix-paint.lisp 2006/11/04 20:56:30 1.8
+++ /project/cello/cvsroot/cello/ix-paint.lisp 2007/02/02 20:11:01 1.9
@@ -93,7 +93,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)
+ (trc self "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-togl.lisp 2006/11/13 05:29:26 1.16
+++ /project/cello/cvsroot/cello/ix-togl.lisp 2007/02/02 20:11:01 1.17
@@ -22,52 +22,52 @@
;------------- Window ---------------
;
-(export! mouse-view ^mouse-view mouse-pos ^mouse-pos mouse-control ^mouse-control mouse-down-evt ^mouse-down-evt)
+(export! mouse-view-tracker 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)
- (
- (redisplayp :cell nil :initarg :redisplayp :initform nil :accessor redisplayp)
- (display-continuous :initarg :display-continuous :initform nil :accessor display-continuous)
- (activep :initarg :activep :initform nil :accessor activep)
-
- (mouse-pos :initarg :mouse-pos :initform (c-in nil) :accessor mouse-pos) ;logical coords. Try to maintain for now.
-
- (mouse-view :initarg :mouse-view :accessor mouse-view
- :initform (c? (let ((mp (^mouse-pos)))
- (trc nil "mouseview sees pos" .w. mp)
- (when mp
- (eko (nil "ix-togl mouseview >" self)
- (without-c-dependency
- (find-ix-under self mp)))))))
+(defmd mouse-view-tracker ()
+ (mouse-view :initarg :mouse-view :accessor mouse-view
+ :initform (c? (let ((pos (mouse-pos .og.)))
+ (trc nil "mouseview sees pos" .w. pos)
+ (when pos
+ (eko (nil "ix-togl mouseview >" self)
+ (without-c-dependency
+ (find-ix-under self pos)))))))
+ (:documentation "Mixin to have mouse view tracked in a subtree of the window, mostly so other GUI layout can depend on
+the sub-tree layout without creating a cyclic dependency, as would happen if the whole window were watched."))
+
+(defmd ix-togl (mouse-view-tracker #+not focuser ogl-lit-scene control ogl-shared-resource-tender togl ix-view)
+ (redisplayp nil :cell nil)
+ display-continuous
+ activep
+ (mouse-pos :initform (c-in nil)) ;logical coords. Try to maintain for now.
- (mouse-control :initarg :mouse-control :accessor mouse-control
- :initform (c? (bwhen (node (^mouse-view))
- (eko (nil "possible mousecontrol" node)
- (fm-ascendant-if node #'fully-enabled)))))
+ (mouse-control (c? (bwhen (node (^mouse-view))
+ (eko (nil "possible mousecontrol" node)
+ (fm-ascendant-if node #'fully-enabled)))))
- (mouse-up-evt :cell :ephemeral :initarg :mouse-up-evt :initform (c-in nil) :accessor mouse-up-evt)
- (mouse-down-evt :cell :ephemeral :initarg :mouse-down-evt :initform (c-in nil) :accessor mouse-down-evt)
- (double-click? :initform (c-in nil) :accessor double-click?)
+ (mouse-up-evt (c-in nil) :cell :ephemeral)
+ (mouse-down-evt (c-in nil) :cell :ephemeral)
+ (double-click? (c-in nil))
- (tick-count :initarg :tick-count :initform (c-in nil) :accessor tick-count)
- (tick-fine :initarg :tick-fine :initform (c-in nil) :accessor tick-fine)
- )
- (:default-initargs
- :px 0 :py 0
- :gl-name (c-in nil)
- :activep (c-in nil)
- :clear-rgba (list 0 0 0 1)
-
- :ll 0 :lt 0
- :lr (c-in (scr2log 1400))
- :lb (c-in (scr2log -800))
+ (tick-count (c-in nil))
+ (tick-fine (c-in nil))
+ :px 0 :py 0
+ :gl-name (c-in nil)
+ :activep (c-in nil)
+ :clear-rgba (list 0 0 0 1)
- ;;:cursor (c? (context-cursor (^mouse-control) (^keyboard-modifiers)))
-
- :tick-count (c-in (os-tickcount))
- :clipped t
- :event-handler 'ix-togl-event-handler
- ))
+ :ll 0 :lt 0
+ :lr (c-in (scr2log 1400))
+ :lb (c-in (scr2log -800))
+ :tick-count (c-in (os-tickcount))
+ :clipped t
+ :event-handler 'ix-togl-event-handler
+ )
+
+(defmethod ctk::togl-create-using-class :around ((self ix-togl))
+ (setf cl-ftgl:*ftgl-ogl* (togl-ptr self)) ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready
+ (kt-opengl:kt-opengl-reset)
+ (call-next-method))
(defmethod ctk::togl-display-using-class ((self ix-togl))
(unless (or *ogl-listing-p* ;; re-entrance happens if a DLL puts up a MessageBox
--- /project/cello/cvsroot/cello/mouse-click.lisp 2006/10/13 05:57:27 1.7
+++ /project/cello/cvsroot/cello/mouse-click.lisp 2007/02/02 20:11:01 1.8
@@ -16,6 +16,8 @@
(in-package :cello)
+(export! os-event)
+
(defmodel mouse ()
((leftb :initarg :leftb :initform (c-in :up) :accessor leftb)
(middleb :initarg :middleb :initform (c-in :up) :accessor middleb)
More information about the Cello-cvs
mailing list