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)) + ,@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)) ,@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 (,@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)