[snow-cvs] r24 - in trunk/src/lisp/snow: . showcase swing
Alessio Stalla
astalla at common-lisp.net
Thu Nov 26 18:56:59 UTC 2009
Author: astalla
Date: Thu Nov 26 13:56:58 2009
New Revision: 24
Log:
Fixed $(c? ...) syntax
Improved showcase to show source only when asked
Convenience c-expr function to make a quick-and-dirty Cells expression
Modified:
trunk/src/lisp/snow/cells.lisp
trunk/src/lisp/snow/data-binding.lisp
trunk/src/lisp/snow/packages.lisp
trunk/src/lisp/snow/showcase/showcase.lisp
trunk/src/lisp/snow/snow.lisp
trunk/src/lisp/snow/swing/swing.lisp
trunk/src/lisp/snow/utils.lisp
Modified: trunk/src/lisp/snow/cells.lisp
==============================================================================
--- trunk/src/lisp/snow/cells.lisp (original)
+++ trunk/src/lisp/snow/cells.lisp Thu Nov 26 13:56:58 2009
@@ -30,6 +30,18 @@
(in-package :snow)
+(defmodel cell-expression ()
+ ((expression :initarg :expression :accessor c-value
+ :initform (error "expression is mandatory")
+ :cell t)))
+
+(defun c-expr (&optional initial-value)
+ (make-instance 'cell-expression :expression (c-in initial-value)))
+
+
+(defobserver c-value ((x cell-expression) new-value)
+ (format t "nv ~A ~A~%" x new-value))
+
;;Cellular slot Binding
(defmodel cell-data-binding (data-binding cells::model-object)
((expression :initarg :expression :reader binding-expression
Modified: trunk/src/lisp/snow/data-binding.lisp
==============================================================================
--- trunk/src/lisp/snow/data-binding.lisp (original)
+++ trunk/src/lisp/snow/data-binding.lisp Thu Nov 26 13:56:58 2009
@@ -145,9 +145,9 @@
#+snow-cells
(progn
(setf (gethash 'cell ht) 'make-cell-data-binding)
- (setf (gethash 'cells:c? ht)
- #'(lambda (&rest args) ;;c? is a macro
- (make-cell-data-binding (eval `(cells:c? , at args)))))
+;; (setf (gethash 'cells:c? ht)
+;; #'(lambda (&rest args) ;;c? is a macro
+;; (make-cell-data-binding (eval `(cells:c? , at args)))))
(setf (gethash 'slot ht) 'make-slot-data-binding))
ht))
@@ -184,5 +184,7 @@
,*package*)) ;;Packages are externalizable: http://www.lispworks.com/documentation/HyperSpec/Body/03_bdbb.htm
(#\(
(let ((list (read stream)))
- `(make-data-binding ',(car list) ,@(cdr list))))
+ (if #+snow-cells (eq (car list) 'cells:c?) #-snow-cells nil
+ `(make-data-binding 'cell ,list)
+ `(make-data-binding ',(car list) ,@(cdr list)))))
(t `(make-simple-data-binding ,(read stream)))))))
Modified: trunk/src/lisp/snow/packages.lisp
==============================================================================
--- trunk/src/lisp/snow/packages.lisp (original)
+++ trunk/src/lisp/snow/packages.lisp Thu Nov 26 13:56:58 2009
@@ -69,16 +69,22 @@
#:widget-location
#:widget-property
#:widget-size
+ #:widget-visible-p
;;Data binding
#:make-var
#:make-bean-data-binding
#:make-cell-data-binding
#:make-simple-data-binding
#:make-slot-data-binding
- #:var
#:bean
#:cell
#:slot
+ #:var
+ #:simple-data-binding
+ #+snow-cells
+ #:c-expr
+ #+snow-cells
+ #:c-value
;;Various
#:call-in-gui-thread
#:defimplementation
Modified: trunk/src/lisp/snow/showcase/showcase.lisp
==============================================================================
--- trunk/src/lisp/snow/showcase/showcase.lisp (original)
+++ trunk/src/lisp/snow/showcase/showcase.lisp Thu Nov 26 13:56:58 2009
@@ -11,24 +11,42 @@
(defvar *examples* (list))
(defmacro define-example (name &body body)
- (cl-utilities:with-unique-names (original-code)
- `(pushnew (list ,name
- (lambda ()
- (let ((,original-code ',body))
-
- (split (:orientation :vertical)
- (panel (:layout-manager '(:mig "fill") :layout "wrap")
- , at body)
- (scroll ()
- (text-area :text
- ,(with-output-to-string (str)
- (let ((*print-case* :downcase))
- (dolist (form body)
- (pprint form str)
- (terpri str))))))))))
- *examples*
- :test #'equal
- :key #'car)))
+ (cl-utilities:with-unique-names (original-code show-source-p)
+ `(pushnew
+ (list ,name
+ (lambda ()
+ (let ((,original-code ',body) (,show-source-p (c-expr nil)))
+ (panel (:layout-manager '(:mig "fill"))
+ (panel (:layout "hidemode 3"
+ :visible-p
+ ;;TODO handle booleans more transparently
+ $(c? (jbool (not (c-value ,show-source-p)))))
+ (panel (:layout-manager '(:mig "fill") :layout "grow, wrap")
+ , at body)
+ (button :text "Show source"
+ :layout "dock south"
+ :on-action (lambda (evt)
+ (declare (ignore evt))
+ (setf (c-value ,show-source-p) t)))
+ (setf ,gui-panel self))
+ (panel (:layout "dock south, hidemode 3"
+ :visible-p $(c? (jbool (c-value ,show-source-p))))
+ (scroll (:layout "grow, wrap")
+ (text-area :text
+ ,(with-output-to-string (str)
+ (let ((*print-case* :downcase))
+ (dolist (form body)
+ (pprint form str)
+ (terpri str))))))
+ (button :text "Hide source"
+ :layout "dock south"
+ :on-action (lambda (evt)
+ (declare (ignore evt))
+ (setf (c-value ,show-source-p) nil)))
+ (setf ,source-panel self))))))
+ *examples*
+ :test #'equal
+ :key #'car)))
(defmodel my-model ()
((a :accessor aaa :initform (c-in "4"))
@@ -103,7 +121,8 @@
(dolist (x *examples*)
(tab (car x) (funcall (cadr x))))))))
-#|| (let ((fr (frame (:title "pippo" :visible-p t)
+#||
+(let ((fr (frame (:title "pippo" :visible-p t)
(panel (:layout "wrap")
(button :text "ciao" :enabled nil)
(button :text "mondo" :enabled 42
Modified: trunk/src/lisp/snow/snow.lisp
==============================================================================
--- trunk/src/lisp/snow/snow.lisp (original)
+++ trunk/src/lisp/snow/snow.lisp Thu Nov 26 13:56:58 2009
@@ -111,7 +111,7 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun common-widget-args ()
- '(layout binding (enabled-p t) location size))
+ '(layout binding (enabled-p t) (visible-p t) location size))
(defun common-widget-args-declarations ()
(let ((arg-names (mapcar (lambda (x) (if (atom x) x (car x)))
(common-widget-args))))
@@ -125,17 +125,19 @@
:collect value))
(defun filter-widget-args (args)
"Eliminates widget arguments processed by common-widget-setup; else, they would be evaluated twice in the macro expansion."
- (filter-arglist args '(:id :layout :binding :enabled-p :location
+ (filter-arglist args '(:id :layout :binding :enabled-p :visible-p :location
:layout-manager :size))))
-(defun common-widget-setup (self layout binding enabled-p location size)
+(defun common-widget-setup (self layout binding enabled-p visible-p
+ location size)
(setup-widget self :layout layout :binding binding :enabled-p enabled-p
- :location location :size size))
+ :visible-p visible-p :location location :size size))
-(defun setup-widget (self &key layout binding (enabled-p t) location size
- &allow-other-keys)
+(defun setup-widget (self &key layout binding (enabled-p t) (visible-p t)
+ location size &allow-other-keys)
(when *parent* (add-child self *parent* layout))
(setf (widget-enabled-p self) enabled-p)
+ (setf (widget-visible-p self) visible-p)
(when location (setf (widget-location self) location))
(when binding (bind-widget self binding))
(when size (setf (widget-size self) size)))
@@ -162,23 +164,26 @@
(setf (get ',name 'widget-p) t)))
(define-widget-macro with-widget
- ((widget &rest args &key id layout binding (enabled-p t) location size)
+ ((widget &rest args &key id layout binding (enabled-p t) (visible-p t)
+ location size)
&body body)
`(dont-add ,widget)
`(progn
,@(generate-default-children-processing-code id body)
- (common-widget-setup self ,layout ,binding ,enabled-p ,location ,size)))
+ (common-widget-setup self ,layout ,binding ,enabled-p ,visible-p ,location ,size)))
(define-widget-macro child
- (widget &rest args &key layout binding (enabled-p t) location size)
+ (widget &rest args &key layout binding (enabled-p t) (visible-p t)
+ location size)
widget
`(setup-widget , at args))
(defmacro define-widget (name keys constructor &body body)
+ "Convenience macro for defining a widget."
(with-unique-names (args)
`(define-widget-macro ,name
(&rest ,args &key ,@(common-widget-args) , at keys)
- `(funcall (lambda (&rest args)
+ `(funcall (lambda (&rest args) ;;to evaluate args only once
(let ((self (apply (function ,',constructor) args)))
(apply #'setup-widget self args)
self))
@@ -187,11 +192,12 @@
,, at body))))
(defmacro define-container-widget (name keys constructor &body body)
+ "Convenience macro for defining a container widget."
(with-unique-names (args macro-body)
`(define-widget-macro ,name
((&rest ,args &key id ,@(common-widget-args) layout-manager , at keys)
&body ,macro-body)
- `(funcall (lambda (&rest args)
+ `(funcall (lambda (&rest args) ;;to evaluate args only once
(let ((self (apply (function ,',constructor) args)))
(apply #'setup-widget self args)
(apply #'setup-container-widget self args)
@@ -243,6 +249,10 @@
(definterface (setf widget-enabled-p) *gui-backend* (value widget))
+(definterface widget-visible-p *gui-backend* (widget))
+
+(definterface (setf widget-visible-p) *gui-backend* (value widget))
+
(definterface (setf widget-location) *gui-backend* (value widget))
(definterface (setf widget-size) *gui-backend* (value widget))
@@ -256,15 +266,15 @@
(definterface pack *gui-backend* (window))
;;Windows
-(definterface make-frame *gui-backend* (&key menu-bar title visible-p on-close
+(definterface make-frame *gui-backend* (&key menu-bar title on-close
&allow-other-keys))
-(define-container-widget frame (menu-bar title visible-p on-close) make-frame)
+(define-container-widget frame (menu-bar title on-close) make-frame)
(definterface make-dialog *gui-backend*
(&key parent title modal-p visible-p &allow-other-keys))
-(define-container-widget dialog (parent title modal-p visible-p)
+(define-container-widget dialog (parent title modal-p)
make-dialog)
;;Menus
@@ -293,7 +303,7 @@
(define-widget-macro tabs
((&rest args
- &key id layout binding (enabled-p t) location size (wrap t)
+ &key id layout binding (enabled-p t) (visible-p t) location size (wrap t)
(tab-placement :top))
&body body)
`(make-tabs :wrap ,wrap :tab-placement ,tab-placement)
@@ -303,7 +313,8 @@
`((let ((,id self))
, at body))
body))
- (common-widget-setup self ,layout ,binding ,enabled-p ,location ,size)))
+ (common-widget-setup self ,layout ,binding ,enabled-p ,visible-p
+ ,location ,size)))
(defmacro tab (name &body body)
`(if *tabs*
@@ -317,19 +328,19 @@
(definterface (setf scroll-panel-view) *gui-backend* (view self))
(define-widget-macro scroll
- ((&rest args &key layout binding (enabled-p t) location size) body)
+ ((&rest args &key layout binding (enabled-p t) (visible-p t) location size) body)
`(make-scroll-panel (dont-add ,body))
- `(common-widget-setup self ,layout ,binding ,enabled-p ,location ,size))
+ `(setup-widget self , at args))
(definterface make-split-panel *gui-backend*
(child1 child2 &key (orientation :horizontal) smoothp))
(define-widget-macro split
- ((&rest args &key layout binding (enabled-p t) location size orientation smoothp)
+ ((&rest args &key layout binding (enabled-p t) (visible-p t) location size orientation smoothp)
child1 child2)
`(make-split-panel (dont-add ,child1) (dont-add ,child2)
:orientation ,orientation :smoothp ,smoothp)
- `(common-widget-setup self ,layout ,binding ,enabled-p ,location ,size))
+ `(common-widget-setup self ,layout ,binding ,enabled-p ,visible-p ,location ,size))
;;Buttons and similar
(definterface make-button *gui-backend* (&key text on-action &allow-other-keys))
Modified: trunk/src/lisp/snow/swing/swing.lisp
==============================================================================
--- trunk/src/lisp/snow/swing/swing.lisp (original)
+++ trunk/src/lisp/snow/swing/swing.lisp Thu Nov 26 13:56:58 2009
@@ -87,13 +87,18 @@
child)
(jcall +add-to-container+ parent child)))
-(defimplementation (setf widget-enabled-p) (*gui-backend* :swing)
- (value widget)
+(defimpl (setf widget-enabled-p) (value widget)
(setf (widget-property widget :enabled) value))
-(defimplementation widget-enabled-p (*gui-backend* :swing) (widget)
+(defimpl widget-enabled-p (widget)
(widget-property widget :enabled))
+(defimpl (setf widget-visible-p) (value widget)
+ (setf (widget-property widget :visible) value))
+
+(defimpl widget-visible-p (widget)
+ (widget-property widget :visible))
+
(defimplementation (setf widget-location) (*gui-backend* :swing) (value widget)
(invoke "setLocation" widget (aref value 0) (aref value 1)))
Modified: trunk/src/lisp/snow/utils.lisp
==============================================================================
--- trunk/src/lisp/snow/utils.lisp (original)
+++ trunk/src/lisp/snow/utils.lisp Thu Nov 26 13:56:58 2009
@@ -74,12 +74,12 @@
(defun get-interface (dispatch-var interface-name)
(cdr (assoc interface-name (getf (symbol-plist dispatch-var) 'interfaces)
- :test #'equal))) ;to handle (setf x) function names
+ :test #'equal))) ;;to handle (setf x) function names
(defun (setf get-interface) (value dispatch-var interface-name)
(bif (it (assoc interface-name
(getf (symbol-plist dispatch-var) 'interfaces)
- :test #'equal)) ;to handle (setf x) function names
+ :test #'equal)) ;;to handle (setf x) function names
(setf (cdr it) value)
(progn
(push (cons interface-name value)
@@ -102,7 +102,7 @@
(let ((interface (get-interface dispatch-var interface-name)))
(if interface
(setf (interface-implementation interface dispatch-value) value)
- (error "Interface ~A not found in ~A" interface-name dispatch-var))))
+ (error "Interface ~S not found in ~S" interface-name dispatch-var))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun extract-argument-names (arglist)
@@ -114,7 +114,7 @@
(defmacro definterface (name dispatch-var arglist &optional documentation)
(with-unique-names (args)
`(progn
- (defun ,name (&rest ,args) ;todo...
+ (defun ,name (&rest ,args) ;;todo...
,@(when documentation `(,documentation))
(destructuring-bind ,arglist ,args ;to check for arglist consistency
(declare (ignore ,@(extract-argument-names arglist))))
@@ -129,7 +129,7 @@
(defmacro defimplementation (name (dispatch-var dispatch-value) arglist
&body body)
`(setf (get-implementation ',dispatch-var ',name ,dispatch-value)
- (lambda ,arglist , at body))) ;todo check arglist is congruent with interface
+ (lambda ,arglist , at body))) ;;todo check arglist is congruent with interface
(defun fix-implementation (dispatch-var)
"Makes the current implementation of an interface permanent, avoiding a layer of indirection when calling the interface functions and thus improving performance, but losing the ability to change the implementation at runtime. Use only when your are absolutely sure you won't ever need to use a different implementation."
More information about the snow-cvs
mailing list