From astalla at common-lisp.net Tue Dec 8 22:05:26 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 08 Dec 2009 17:05:26 -0500 Subject: [snow-cvs] r34 - in trunk: . lib src/java/snow src/lisp/snow/showcase Message-ID: Author: astalla Date: Tue Dec 8 17:05:26 2009 New Revision: 34 Log: Updated abcl Added sample jnlp file Added: trunk/snow.jnlp Modified: trunk/lib/abcl.jar trunk/src/java/snow/Snow.java trunk/src/lisp/snow/showcase/showcase.lisp Modified: trunk/lib/abcl.jar ============================================================================== Binary files. No diff available. Added: trunk/snow.jnlp ============================================================================== --- (empty file) +++ trunk/snow.jnlp Tue Dec 8 17:05:26 2009 @@ -0,0 +1,28 @@ + + + + + Snow Example + Alessio Stalla + + + + + + + + + + + + + + + + + + + + + + Modified: trunk/src/java/snow/Snow.java ============================================================================== --- trunk/src/java/snow/Snow.java (original) +++ trunk/src/java/snow/Snow.java Tue Dec 8 17:05:26 2009 @@ -49,8 +49,12 @@ import javax.script.ScriptEngineManager; import javax.script.ScriptException; +import java.security.*; + import org.armedbear.lisp.Interpreter; +import java.io.*; + public abstract class Snow { private static boolean init = false; @@ -63,7 +67,10 @@ */ public static synchronized void initAux() throws ScriptException { if(!init) { - lispEngine = new ScriptEngineManager(Snow.class.getClassLoader()).getEngineByExtension("lisp"); + try { + lispEngine = new ScriptEngineManager(Snow.class.getClassLoader()).getEngineByExtension("lisp"); + } catch(final Throwable t) { + } URL url = Snow.class.getResource("/snow/snow.asd"); if(url == null) { throw new RuntimeException("snow.asd not found in classpath: have you installed Snow correctly?"); @@ -101,20 +108,18 @@ extracted.mkdirs(); } else { extracted.getParentFile().mkdirs(); - byte[] buf = new byte[(int)entry.getSize()]; //probably inefficient - int read = 0; + FileOutputStream fos = new FileOutputStream(extracted); + byte[] buf = new byte[4096]; while(true) { - int justRead = extractor.read(buf, read, buf.length - read); - if(justRead >= 0 && read < buf.length) { - read += justRead; + int read = extractor.read(buf); + if(read != -1) { + fos.write(buf, 0, read); } else { + fos.flush(); + fos.close(); break; } } - FileOutputStream fos = new FileOutputStream(extracted); - fos.write(buf); - fos.flush(); - fos.close(); } extracted.setLastModified(entry.getTime()); System.out.println("Extracted " + extracted.getAbsolutePath()); @@ -255,7 +260,19 @@ try { if(args.length == 0) { //Launch GUI REPL evalResource(Snow.class, "/snow/start.lisp", false); - } else { //Launch regular ABCL + } else if("--showcase".equals(args[0])) { + //Needed for Java WebStart + Policy.setPolicy + (new Policy() { + public PermissionCollection getPermissions(CodeSource codesource) { + Permissions perms = new Permissions(); + perms.add(new AllPermission()); + return (perms); + } + }); + evalResource(Snow.class, "/snow/showcase/showcase.lisp", false); + getInvocable().invokeFunction("snow-showcase::showcase", true); + } else {//Launch regular ABCL //Copied from org.armedbear.lisp.Main.main() Runnable r = new Runnable() { public void run() { @@ -271,7 +288,9 @@ } } }; - new Thread(null, r, "interpreter", 4194304L).start(); + Thread t = new Thread(null, r, "interpreter", 4194304L); + t.setDaemon(true); + t.start(); } } catch (Exception e) { e.printStackTrace(); Modified: trunk/src/lisp/snow/showcase/showcase.lisp ============================================================================== --- trunk/src/lisp/snow/showcase/showcase.lisp (original) +++ trunk/src/lisp/snow/showcase/showcase.lisp Tue Dec 8 17:05:26 2009 @@ -112,10 +112,11 @@ (princ "Thanks for pushing me! ") (finish-output)))) -(defun showcase () - (with-gui (:swing) - (frame (:id frame :title "Sample JFrame" :visible-p t :size #C(800 600) - :layout-manager '(:mig "fill")) +(defun showcase (&optional exit-on-close-p) + (with-gui () + (frame (:id frame :title "Snow Showcase" :visible-p t :size #C(800 600) + :layout-manager '(:mig "fill") + :on-close (when exit-on-close-p :exit)) (tabs (:layout "grow") (dolist (x (reverse *examples*)) (tab (car x) (funcall (cadr x)))))))) From astalla at common-lisp.net Tue Dec 8 22:24:21 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 08 Dec 2009 17:24:21 -0500 Subject: [snow-cvs] r35 - trunk Message-ID: Author: astalla Date: Tue Dec 8 17:24:21 2009 New Revision: 35 Log: Fixed jnlp file. Modified: trunk/snow.jnlp Modified: trunk/snow.jnlp ============================================================================== --- trunk/snow.jnlp (original) +++ trunk/snow.jnlp Tue Dec 8 17:24:21 2009 @@ -8,6 +8,7 @@ + --showcase @@ -16,7 +17,7 @@ - + From astalla at common-lisp.net Sat Dec 12 09:58:52 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Sat, 12 Dec 2009 04:58:52 -0500 Subject: [snow-cvs] r36 - in trunk: docs src/java/snow/swing src/lisp/snow src/lisp/snow/swing Message-ID: Author: astalla Date: Sat Dec 12 04:58:51 2009 New Revision: 36 Log: Fixed some dynamic environment handling Updated tutorial Modified: trunk/docs/tutorial.html trunk/src/java/snow/swing/ConsoleDocument.java trunk/src/lisp/snow/snow.lisp trunk/src/lisp/snow/swing/swing.lisp Modified: trunk/docs/tutorial.html ============================================================================== --- trunk/docs/tutorial.html (original) +++ trunk/docs/tutorial.html Sat Dec 12 04:58:51 2009 @@ -23,7 +23,7 @@

  • Java applications:

    simply make sure snow.jar and all the jars in the lib/ folder are in the classpath of your application. Snow uses JSR-223 and is built with Java 1.6, so that's the minimum Java version you can use. However, it should be possible to run Snow on 1.5 as well, but you'll need to recompile both Snow and ABCL from sources with a JSR-223 implementation in your classpath. See the Embedding Snow section below for details about using Snow inside your Java application.

  • Lisp applications:

      -
    • Snow come prepackaged with ABCL 0.16, and it wraps the ABCL launcher with its own, that makes sure to load Snow prior to your application. So you can just follow the procedure for Java applications above, and use the snow.Snow class in place of org.armedbear.lisp.Main as the main Java class to launch, e.g. via a shell script. The only difference is that, when launched with no command-line switches, Snow will pop up a GUI repl. You can pass a dummy --no-gui-repl switch to inhibit that. If you are new to Java, the classpath is a list of search places that the JVM uses to resolve classes (think asdf:*central-registry* if you will). It can be set with the environment variable CLASSPATH or with the -classpath command line switch to the java bytecode interpreter (the 'java' command). It is a list of directories and/or .jar files, separated by a platform-dependent character (':' on Linux, ';' on Windows, I don't know about Macs). So for example, you can launch Snow on Linux with 'java -classpath snow.jar:lib/abcl.jar:lib/binding-2.0.6.jar:lib/commons-logging.jar:lib/miglayout-3.6.2.jar snow.Snow'.
      • +
    • Snow comes prepackaged with ABCL 0.17, and it wraps the ABCL launcher with its own, that makes sure to load Snow prior to your application. So you can just follow the procedure for Java applications above, and use the snow.Snow class in place of org.armedbear.lisp.Main as the main Java class to launch, e.g. via a shell script. The only difference is that, when launched with no command-line switches, Snow will pop up a GUI repl. You can pass a dummy --no-gui-repl switch to inhibit that. If you are new to Java, the classpath is a list of search places that the JVM uses to resolve classes (think asdf:*central-registry* if you will). It can be set with the environment variable CLASSPATH or with the -classpath command line switch to the java bytecode interpreter (the 'java' command). It is a list of directories and/or .jar files, separated by a platform-dependent character (':' on Linux, ';' on Windows, I don't know about Macs). So for example, you can launch Snow on Linux with 'java -classpath snow.jar:lib/abcl.jar:lib/binding-2.0.6.jar:lib/commons-logging.jar:lib/miglayout-3.7.1.jar snow.Snow'.
    • Also, Snow has its own version of Cells built in. It is a random, but fairly recent version from CVS, with some fixes to make it run on ABCL. I'm looking forward to having those fixes merged with trunk, so you'll be able to freely update Cells independently.
    • Last but not least, Snow is built with ASDF, so if you are brave enough you can extract the contents of snow.jar (it is a regular zip file), it will create a directory tree full of .lisp source files, fasls and compiled Java classes (.class files). You will then be able to load Snow with ASDF using your own version of ABCL and/or Cells, provided you still meet the requirements about the classpath for Java applications. (there are two .asd files, one in snow/ and one in snow/swing).
    @@ -46,7 +46,7 @@ (pack self) (show self)) -Evaluating this will show a window containing a single button which, when pressed, will output "Hello, world!". The terminology should be familiar to Swing developers. Actually, the output from the button will NOT go to the REPL, but to the OS console instead; I'll explain this later, please ignore it for now.
    +Evaluating this will show a window containing a single button which, when pressed, will output "Hello, world!". The terminology should be familiar to Swing developers.
    The REPL is great for experimenting: the code you input is immediately executed by an interpreter. You can also compile your code, either on the fly in the REPL or from a file; this is outside the scope of this tutorial, but you can find more information in any decent tutorial or book about Common Lisp (I suggest the free ebook Practical Common Lisp by Peter Seibel, available at http://gigamonkeys.com/book/). However, experiments sometimes go wrong; if you make a mistake - for example, evaluating an unexisting function - you will end in the debugger. Try typing the function call 
     (oh-no!)
@@ -78,7 +78,29 @@
 
    How does this work?
    
 The Snow API consists of a set of macros that can be used to declaratively construct a tree of widgets. These macros are designed in such a way to make the tree structure of Lisp source code closely mirror the GUI widget tree structure (in the general case). The macros expand to code that uses a functional interface to create widgets, however it is not recommended to use this functional API directly since it depends on the context established by the macros.
 
-The aspects of such context of interest to the user are:
+The main user-level aspects of the Snow API are:
+
+
    macro with-gui
    
+
+The macro with-gui (&rest args) &body body is used to run Snow code in the appropriate context (i.e., in a GUI-backend-specific thread, with some special bindings established). All Snow code must be run in the dynamic scope of a with-gui invocation; consequences are undefined if this rule is violated. This usually means that you should only use with-gui in the top-level function(s) that create the GUI. Moreover, if you write code that dinamically changes your GUI after it has been created independently on event handling you should wrap that code in with-gui too.
     
+Snow automatically takes care of setting up the right environment inside event-handling callbacks, so you're not required to use with-gui there, even if you modify the GUI. Code run from the Snow REPL is also automatically evaluated in the right context.
    
+Examples:
+
    +;; This function presumably is called to initialize the GUI so with-gui is required.
+(defun make-main-frame (title)
+  (with-gui ()
+    (frame (:title title)
+      (make-some-button))))
+
+;; This function is meant to be only called by GUI-making functions: it can assume that with-gui has been called by some other function higher on the call stack, and can avoid using it.
+(defun make-some-button ()
+  (button :text "Some" :on-action #'handle-some-action))
+
+;; This function is an event handler: Snow will automatically run it in the proper context, so with-gui is not required
+(defun handle-some-action ()
+  (print "Hooray!"))
+
    
+
 
 
    lexical variable self
    
 

Modified: trunk/src/java/snow/swing/ConsoleDocument.java
==============================================================================
--- trunk/src/java/snow/swing/ConsoleDocument.java	(original)
+++ trunk/src/java/snow/swing/ConsoleDocument.java	Sat Dec 12 04:58:51 2009
@@ -35,6 +35,7 @@
 import java.awt.Window;
 import java.awt.event.WindowAdapter;
 import java.awt.event.WindowEvent;
+import java.awt.event.WindowListener;
 import java.io.BufferedReader;
 import java.io.BufferedWriter;
 import java.io.IOException;
@@ -272,6 +273,7 @@
 		    LispThread.currentThread().bindSpecial(Symbol.DEBUGGER_HOOK, debuggerHook);
 		    LispThread.currentThread().bindSpecial(Symbol.STANDARD_INPUT, in);
 		    LispThread.currentThread().bindSpecial(Symbol.STANDARD_OUTPUT, out);
+		    LispThread.currentThread().bindSpecial(Symbol.ERROR_OUTPUT, out);
 		    LispThread.currentThread().bindSpecial(Symbol.TERMINAL_IO, ioStream);
 		    LispThread.currentThread().bindSpecial(Symbol.DEBUG_IO, ioStream);
 		    LispThread.currentThread().bindSpecial(Symbol.QUERY_IO, ioStream);
@@ -284,11 +286,12 @@
 	};
     }
 	
-    public void disposeOnClose(Window parent) {
+    public void disposeOnClose(final Window parent) {
 	parent.addWindowListener(new WindowAdapter() {
 		@Override
 		public void windowClosing(WindowEvent e) {
 		    dispose();
+		    parent.removeWindowListener(this);
 		}
 	    });
     }

Modified: trunk/src/lisp/snow/snow.lisp
==============================================================================
--- trunk/src/lisp/snow/snow.lisp	(original)
+++ trunk/src/lisp/snow/snow.lisp	Sat Dec 12 04:58:51 2009
@@ -63,18 +63,25 @@
 (defvar *dynamic-environment* nil)
 
 (defmacro with-snow-dynamic-environment (&body body)
-  (with-unique-names (gui-backend-var package-var terminal-io-var)
+  (with-unique-names (gui-backend-var package-var terminal-io-var
+		      standard-input-var standard-output-var error-output-var)
     `(if *dynamic-environment*
 	 (with-dynamic-environment (*dynamic-environment*)
 	   , at body)
 	 (let* ((,gui-backend-var *gui-backend*)
 		(,package-var *package*)
-		(,terminal-io-var *terminal-io*)) ;;Etc...
+		(,terminal-io-var *terminal-io*)
+		(,standard-input-var *standard-input*)
+		(,standard-output-var *standard-output*)
+		(,error-output-var *error-output*)) ;;Etc...
        (dynamic-wind
 	(let ((*gui-backend* ,gui-backend-var)
 	      (*package* ,package-var)
 	      (*debugger-hook* *graphical-debugger-hook*)
-	      (*terminal-io* ,terminal-io-var))
+	      (*terminal-io* ,terminal-io-var)
+	      (*standard-input* ,standard-input-var)
+	      (*standard-output* ,standard-output-var)
+	      (*error-output* ,error-output-var))
 	  (proceed
 	   (let ((*dynamic-environment* (capture-dynamic-environment)))
 	     (with-dynamic-environment (*dynamic-environment*)

Modified: trunk/src/lisp/snow/swing/swing.lisp
==============================================================================
--- trunk/src/lisp/snow/swing/swing.lisp	(original)
+++ trunk/src/lisp/snow/swing/swing.lisp	Sat Dec 12 04:58:51 2009
@@ -41,13 +41,15 @@
 (defun make-action-listener (obj)
   (if (or (functionp obj) (symbolp obj))
       (jmake-proxy "java.awt.event.ActionListener"
-		   (let ((env (or snow::*dynamic-environment*
-				  (snow::capture-dynamic-environment))))
-		     (lambda (this method-name event)
-		       (declare (ignore this method-name))
-		       (snow::with-dynamic-environment (env)
-			 (let ((snow::*dynamic-environment* env))
-			   (funcall obj event))))))
+		   (snow::lambda/dynamic-environment (this method-name event)
+		     (funcall obj event)))
+;		   (let ((env (or snow::*dynamic-environment*
+;				  (snow::capture-dynamic-environment))))
+;		     (lambda (this method-name event)
+;		       (declare (ignore this method-name))
+;		       (snow::with-dynamic-environment (env)
+;			 (let ((snow::*dynamic-environment* env))
+;			   (funcall obj event))))))
       obj)) ;This allows to use a native Java action listener
 
 (defimpl make-layout-manager (widget layout &rest args)
@@ -310,10 +312,9 @@
 	(repl-doc (new "snow.swing.ConsoleDocument"
 		       (compile nil
 				`(lambda ()
-				   (let (, at environment)
-				     ;;safe: *debugger-hook* is rebound
-				     (install-graphical-debugger)
-				     (top-level::top-level-loop)))))))
+				   (snow::with-snow-dynamic-environment
+				     (let (, at environment)
+				       (top-level::top-level-loop))))))))
     (setf (widget-property text-area :document) repl-doc)
     (invoke "setupTextComponent" repl-doc text-area)
     (when dispose-on-close



From astalla at common-lisp.net  Mon Dec 21 22:47:35 2009
From: astalla at common-lisp.net (Alessio Stalla)
Date: Mon, 21 Dec 2009 17:47:35 -0500
Subject: [snow-cvs] r37 - in trunk/src/lisp/snow: . showcase swing
Message-ID: 

Author: astalla
Date: Mon Dec 21 17:47:34 2009
New Revision: 37

Log:
Preliminary support for borders


Modified:
   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

Modified: trunk/src/lisp/snow/packages.lisp
==============================================================================
--- trunk/src/lisp/snow/packages.lisp	(original)
+++ trunk/src/lisp/snow/packages.lisp	Mon Dec 21 17:47:34 2009
@@ -35,7 +35,7 @@
   (:export
     ;;Widgets
     #:button
-    #:check-box
+    #:check-box
     #:progress-bar
     #:dialog
     #:frame
@@ -66,6 +66,7 @@
     #:scroll-panel-view
     #:set-widget-properties
     #:show
+    #:widget-border
     #:widget-enabled-p
     #:widget-location
     #:widget-property

Modified: trunk/src/lisp/snow/showcase/showcase.lisp
==============================================================================
--- trunk/src/lisp/snow/showcase/showcase.lisp	(original)
+++ trunk/src/lisp/snow/showcase/showcase.lisp	Mon Dec 21 17:47:34 2009
@@ -98,9 +98,9 @@
   (scroll (:layout "grow")
     (tree :model (make-tree-model '(1 2 (c (a b)) 3)))))
 
-(define-example "Layout"
+(define-example "Layout & Borders"
   (label :text "BorderLayout" :layout "wrap")
-  (panel (:layout-manager :border :layout "wrap")
+  (panel (:layout-manager :border :layout "wrap" :border :bevel)
     (button :text "borderlayout - center")
     (button :text "borderlayout - east"
 	    :layout (jfield "java.awt.BorderLayout" "EAST"))))

Modified: trunk/src/lisp/snow/snow.lisp
==============================================================================
--- trunk/src/lisp/snow/snow.lisp	(original)
+++ trunk/src/lisp/snow/snow.lisp	Mon Dec 21 17:47:34 2009
@@ -30,7 +30,7 @@
 
 (in-package :snow)
 
-;;Common Interfaces
+;;Common Interfaces (much to do here!)
 (defvar *gui-backend* :swing "Variable used to determine the GUI backend, and thus interface implementation, to use. Defaults to :swing.")
 
 (definterface add-child *gui-backend* (child &optional (parent *parent*) layout-constraints))
@@ -47,6 +47,8 @@
 
 (definterface (setf widget-size) *gui-backend* (value widget))
 
+(definterface (setf widget-border) *gui-backend* (value widget))
+
 (definterface dispose *gui-backend* (obj))
 
 (definterface show *gui-backend* (obj))
@@ -185,7 +187,7 @@
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun common-widget-args ()
-    '(layout binding (enabled-p t) (visible-p t) location size
+    '(layout binding (enabled-p t) (visible-p t) location size border
       on-mouse-click on-mouse-press on-mouse-release
       on-mouse-enter on-mouse-exit
       on-mouse-drag on-mouse-move))
@@ -210,7 +212,7 @@
   "Sets mouse listener(s) on a widget.")
 
 (defun setup-widget (self &key layout binding (enabled-p t) (visible-p t)
-		     location size
+		     location size border
 		     ;;mouse event handling
 		     on-mouse-click on-mouse-press on-mouse-release
 		     on-mouse-enter on-mouse-exit
@@ -238,7 +240,9 @@
        (wrap-event-callback on-mouse-move)))
     (when location (setf (widget-location self) location))
     (when binding (bind-widget self binding))
-    (when size (setf (widget-size self) size))))
+    (when size (setf (widget-size self) size))
+    (when border
+      (setf (widget-border self) border))))
 
 #+emacs (put 'define-widget-macro 'lisp-indent-function 3)
 #+emacs (put 'define-widget 'lisp-indent-function 3)

Modified: trunk/src/lisp/snow/swing/swing.lisp
==============================================================================
--- trunk/src/lisp/snow/swing/swing.lisp	(original)
+++ trunk/src/lisp/snow/swing/swing.lisp	Mon Dec 21 17:47:34 2009
@@ -120,6 +120,25 @@
 (defimpl (setf widget-size) (value widget)
   (invoke "setSize" widget (realpart value) (imagpart value)))
 
+(defun make-border (border-spec)
+  (if (jinstance-of-p border-spec "javax.swing.border.Border")
+      border-spec
+      (let ((border (snow::ensure-list border-spec)))
+	(ecase (car border)
+	  (:bevel
+	   (let ((type (ecase (or (cadr border) :lowered)
+			 (:lowered
+			  (jfield "javax.swing.border.BevelBorder" "LOWERED"))
+			 (:raised
+			  (jfield "javax.swing.border.BevelBorder" "RAISED")))))
+	     (jcall (jmethod "javax.swing.BorderFactory"
+			     "createBevelBorder" "int")
+		    nil type)))))))
+
+(defimpl (setf widget-border) (value widget)
+  (when (jinstance-of-p widget "javax.swing.JComponent")
+    (invoke "setBorder" widget (if value (make-border value) nil))))
+
 (defimpl dispose (obj)
   (invoke "dispose" obj))
 



From astalla at common-lisp.net  Sun Dec 27 10:28:52 2009
From: astalla at common-lisp.net (Alessio Stalla)
Date: Sun, 27 Dec 2009 05:28:52 -0500
Subject: [snow-cvs] r38 - in trunk/src/lisp/snow: . swing
Message-ID: 

Author: astalla
Date: Sun Dec 27 05:28:51 2009
New Revision: 38

Log:
Added the possibility to set the font of any component.


Modified:
   trunk/src/lisp/snow/packages.lisp
   trunk/src/lisp/snow/snow.lisp
   trunk/src/lisp/snow/swing/swing.lisp
   trunk/src/lisp/snow/widgets.lisp

Modified: trunk/src/lisp/snow/packages.lisp
==============================================================================
--- trunk/src/lisp/snow/packages.lisp	(original)
+++ trunk/src/lisp/snow/packages.lisp	Sun Dec 27 05:28:51 2009
@@ -68,6 +68,7 @@
     #:show
     #:widget-border
     #:widget-enabled-p
+    #:widget-font
     #:widget-location
     #:widget-property
     #:widget-size
@@ -91,6 +92,7 @@
     #:call-in-gui-thread
     #:defimplementation
     #:definterface
+    #:font
     #:*gui-backend*
     #:jbool
     #:layout-manager

Modified: trunk/src/lisp/snow/snow.lisp
==============================================================================
--- trunk/src/lisp/snow/snow.lisp	(original)
+++ trunk/src/lisp/snow/snow.lisp	Sun Dec 27 05:28:51 2009
@@ -49,8 +49,16 @@
 
 (definterface (setf widget-border) *gui-backend* (value widget))
 
+(definterface (setf widget-font) *gui-backend* (value widget))
+
 (definterface dispose *gui-backend* (obj))
 
+(definterface font *gui-backend* (name size &optional style)
+  "Constructs an object representing a font. Parameters:
+ name the name of the font family
+ size the size in points
+ style if provided, one of :plain, :bold, :italic or :bold-italic")
+
 (definterface show *gui-backend* (obj))
 
 (definterface hide *gui-backend* (obj))
@@ -187,7 +195,7 @@
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun common-widget-args ()
-    '(layout binding (enabled-p t) (visible-p t) location size border
+    '(layout binding (enabled-p t) (visible-p t) location size border font
       on-mouse-click on-mouse-press on-mouse-release
       on-mouse-enter on-mouse-exit
       on-mouse-drag on-mouse-move))
@@ -212,7 +220,7 @@
   "Sets mouse listener(s) on a widget.")
 
 (defun setup-widget (self &key layout binding (enabled-p t) (visible-p t)
-		     location size border
+		     location size border font
 		     ;;mouse event handling
 		     on-mouse-click on-mouse-press on-mouse-release
 		     on-mouse-enter on-mouse-exit
@@ -241,6 +249,7 @@
     (when location (setf (widget-location self) location))
     (when binding (bind-widget self binding))
     (when size (setf (widget-size self) size))
+    (when font (setf (widget-font self) font))
     (when border
       (setf (widget-border self) border))))
 

Modified: trunk/src/lisp/snow/swing/swing.lisp
==============================================================================
--- trunk/src/lisp/snow/swing/swing.lisp	(original)
+++ trunk/src/lisp/snow/swing/swing.lisp	Sun Dec 27 05:28:51 2009
@@ -108,6 +108,9 @@
 (defimpl widget-enabled-p (widget)
   (widget-property widget :enabled))
 
+(defimpl (setf widget-font) (value widget)
+  (setf (widget-property widget :font) value))
+
 (defimpl (setf widget-visible-p) (value widget)
   (setf (widget-property widget :visible) value))
 
@@ -133,7 +136,27 @@
 			  (jfield "javax.swing.border.BevelBorder" "RAISED")))))
 	     (jcall (jmethod "javax.swing.BorderFactory"
 			     "createBevelBorder" "int")
-		    nil type)))))))
+		    nil type)))
+	  (:compound 
+	   (let ((outer (cadr border)) (inner (caddr border)))
+	     (jcall (jmethod "javax.swing.BorderFactory"
+			     "createCompoundBorder"
+			     "javax.swing.border.Border"
+			     "javax.swing.border.Border")
+		    nil outer inner)))
+	  (:empty
+	   (if (cdr border)
+	       (if (= 4 (length (cdr border)))
+		   (jcall (jmethod "javax.swing.BorderFactory"
+				   "createEmptyBorder" "int" "int" "int" "int")
+			  nil (second border) (third border) (fourth border)
+			  (fifth border))
+		   (error "Wrong number of arguments for empty border: ~A (~S)"
+			  (length (cdr border)) (cdr border)))
+	       (jcall (jmethod "javax.swing.BorderFactory"
+			       "createEmptyBorder")
+		      nil)))
+	  ))))
 
 (defimpl (setf widget-border) (value widget)
   (when (jinstance-of-p widget "javax.swing.JComponent")
@@ -148,6 +171,16 @@
 (defimpl hide (obj)
   (invoke "hide" obj))
 
+(defimpl font (name size &optional style)
+  (let ((style-int (case style
+		     ((or :plain nil) (jfield "java.awt.Font" "PLAIN"))
+		     (:bold (jfield "java.awt.Font" "BOLD"))
+		     (:italic (jfield "java.awt.Font" "ITALIC"))
+		     (:bold-italic (logior (jfield "java.awt.Font" "BOLD")
+					   (jfield "java.awt.Font" "ITALIC")))
+		     (t (error "Unknown font style: ~A" style)))))
+    (new "java.awt.Font" name style-int size)))
+
 ;;; --- Widgets --- ;;;
 
 ;Frames and dialogs

Modified: trunk/src/lisp/snow/widgets.lisp
==============================================================================
--- trunk/src/lisp/snow/widgets.lisp	(original)
+++ trunk/src/lisp/snow/widgets.lisp	Sun Dec 27 05:28:51 2009
@@ -1,3 +1,4 @@
+
 ;;; widgets.lisp
 ;;;
 ;;; Copyright (C) 2008-2009 Alessio Stalla
@@ -118,7 +119,7 @@
   `(setup-widget self ,@(filter-arglist args '(:orientation :smoothp))))
 
 (defmacro defwidget (name &rest args)
-  (let* ((maker-sym (intern (concatenate 'string "MAKE-" (symbol-name name)))))
+  (let* ((maker-sym (intern (str (symbol-name '#:make-) (symbol-name name)))))
     `(progn
        (definterface ,maker-sym *gui-backend* (&key , at args &allow-other-keys))
        (define-widget ,name (, at args &allow-other-keys) ,maker-sym))))



From astalla at common-lisp.net  Sun Dec 27 22:36:47 2009
From: astalla at common-lisp.net (Alessio Stalla)
Date: Sun, 27 Dec 2009 17:36:47 -0500
Subject: [snow-cvs] r39 - in trunk/src/lisp/snow: . swing
Message-ID: 

Author: astalla
Date: Sun Dec 27 17:36:46 2009
New Revision: 39

Log:
Basic support for colors, setting foreground and background color for all components.


Modified:
   trunk/src/lisp/snow/packages.lisp
   trunk/src/lisp/snow/snow.lisp
   trunk/src/lisp/snow/swing/swing.lisp

Modified: trunk/src/lisp/snow/packages.lisp
==============================================================================
--- trunk/src/lisp/snow/packages.lisp	(original)
+++ trunk/src/lisp/snow/packages.lisp	Sun Dec 27 17:36:46 2009
@@ -66,9 +66,11 @@
     #:scroll-panel-view
     #:set-widget-properties
     #:show
+    #:widget-background
     #:widget-border
     #:widget-enabled-p
     #:widget-font
+    #:widget-foreground
     #:widget-location
     #:widget-property
     #:widget-size
@@ -90,6 +92,7 @@
     #:c-value
     ;;Various
     #:call-in-gui-thread
+    #:color
     #:defimplementation
     #:definterface
     #:font

Modified: trunk/src/lisp/snow/snow.lisp
==============================================================================
--- trunk/src/lisp/snow/snow.lisp	(original)
+++ trunk/src/lisp/snow/snow.lisp	Sun Dec 27 17:36:46 2009
@@ -47,12 +47,19 @@
 
 (definterface (setf widget-size) *gui-backend* (value widget))
 
+(definterface (setf widget-background) *gui-backend* (value widget))
+
 (definterface (setf widget-border) *gui-backend* (value widget))
 
 (definterface (setf widget-font) *gui-backend* (value widget))
 
+(definterface (setf widget-foreground) *gui-backend* (value widget))
+
 (definterface dispose *gui-backend* (obj))
 
+(definterface color *gui-backend* (color-spec)
+  "Constructs an object representing a color. The color can be specified the 24-bit RGB number, or by symbolic constants such as :black, :red or :green.")
+
 (definterface font *gui-backend* (name size &optional style)
   "Constructs an object representing a font. Parameters:
  name the name of the font family
@@ -196,6 +203,7 @@
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun common-widget-args ()
     '(layout binding (enabled-p t) (visible-p t) location size border font
+      background foreground
       on-mouse-click on-mouse-press on-mouse-release
       on-mouse-enter on-mouse-exit
       on-mouse-drag on-mouse-move))
@@ -220,7 +228,7 @@
   "Sets mouse listener(s) on a widget.")
 
 (defun setup-widget (self &key layout binding (enabled-p t) (visible-p t)
-		     location size border font
+		     location size border font background foreground
 		     ;;mouse event handling
 		     on-mouse-click on-mouse-press on-mouse-release
 		     on-mouse-enter on-mouse-exit
@@ -250,6 +258,14 @@
     (when binding (bind-widget self binding))
     (when size (setf (widget-size self) size))
     (when font (setf (widget-font self) font))
+    (when background
+      (if (keywordp background)
+	  (setf (widget-background self) (color background))
+	  (setf (widget-background self) background)))
+    (when foreground
+      (if (keywordp foreground)
+	  (setf (widget-foreground self) (color foreground))
+	  (setf (widget-foreground self) foreground)))
     (when border
       (setf (widget-border self) border))))
 

Modified: trunk/src/lisp/snow/swing/swing.lisp
==============================================================================
--- trunk/src/lisp/snow/swing/swing.lisp	(original)
+++ trunk/src/lisp/snow/swing/swing.lisp	Sun Dec 27 17:36:46 2009
@@ -111,6 +111,12 @@
 (defimpl (setf widget-font) (value widget)
   (setf (widget-property widget :font) value))
 
+(defimpl (setf widget-background) (value widget)
+  (setf (widget-property widget :background) value))
+
+(defimpl (setf widget-foreground) (value widget)
+  (setf (widget-property widget :foreground) value))
+
 (defimpl (setf widget-visible-p) (value widget)
   (setf (widget-property widget :visible) value))
 
@@ -171,6 +177,17 @@
 (defimpl hide (obj)
   (invoke "hide" obj))
 
+(defimpl color (color-spec)
+  (cond
+    ((integerp color-spec) (new "java.awt.Color" color-spec))
+    ((keywordp color-spec) (case color-spec
+			     (:black (jfield "java.awt.Color" "BLACK"))
+			     (:blue  (jfield "java.awt.Color" "BLUE"))
+			     (:green (jfield "java.awt.Color" "GREEN"))
+			     (:red   (jfield "java.awt.Color" "RED"))
+			     (:white (jfield "java.awt.Color" "WHITE"))))
+    (t (error "Invalid color: ~A" color-spec))))
+
 (defimpl font (name size &optional style)
   (let ((style-int (case style
 		     ((or :plain nil) (jfield "java.awt.Font" "PLAIN"))



From astalla at common-lisp.net  Mon Dec 28 20:11:26 2009
From: astalla at common-lisp.net (Alessio Stalla)
Date: Mon, 28 Dec 2009 15:11:26 -0500
Subject: [snow-cvs] r40 - in trunk/src/lisp/snow: . showcase swing
Message-ID: 

Author: astalla
Date: Mon Dec 28 15:11:25 2009
New Revision: 40

Log:
Merged cells data binding in data-binding.lisp
Changed implementation of simple-data-binding (and thus make-var and var) to use cells. c-expr and c-value are no longer necessary and have been removed.
Added the possibility to query and change the text of text components.


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/widgets.lisp

Modified: trunk/src/lisp/snow/cells.lisp
==============================================================================
--- trunk/src/lisp/snow/cells.lisp	(original)
+++ trunk/src/lisp/snow/cells.lisp	Mon Dec 28 15:11:25 2009
@@ -28,58 +28,3 @@
 ;;; obligated to do so.  If you do not wish to do so, delete this
 ;;; exception statement from your version.
 
-(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
-	       :initform (error "expression is mandatory")
-	       :cell t)
-   (writer :initarg writer :accessor binding-writer :initform nil :cell nil)
-   (model :accessor binding-model :initform nil :cell nil)))
-
-(defmethod initialize-instance :after ((obj cell-data-binding) &rest args)
-  (declare (ignore args))
-  (setf (binding-model obj)
-	(make-cells-value-model obj)))
-
-(defobserver expression ((binding cell-data-binding) new-value)
-  (bwhen (it (binding-model binding))
-    (invoke "valueChanged" it new-value)))
-
-(defun make-cell-data-binding (expression &optional writer)
-  (check-type writer (or null function))
-  (let ((instance
-	 (make-instance 'cell-data-binding :expression expression)))
-    (setf (binding-writer instance) writer)
-    instance))
-
-(defun make-slot-data-binding (object slot-accessor-name)
-  (make-cell-data-binding
-   (eval `(c? (,slot-accessor-name ,object)))
-   (compile nil `(lambda (x)
-		   (setf (,slot-accessor-name ,object) x)))))
-
-(defmethod make-model ((binding cell-data-binding))
-  (binding-model binding))
-  
-(defun make-cells-value-model (binding)
-  (new "snow.binding.AccessorBinding"
-       binding
-       #'binding-expression
-       (lambda (value place)
-	 (declare (ignore place))
-	 (bwhen (it (binding-writer binding))
-	   (funcall it value)))))
\ No newline at end of file

Modified: trunk/src/lisp/snow/data-binding.lisp
==============================================================================
--- trunk/src/lisp/snow/data-binding.lisp	(original)
+++ trunk/src/lisp/snow/data-binding.lisp	Mon Dec 28 15:11:25 2009
@@ -52,25 +52,60 @@
 
 ;;Concrete Binding implementations
 
-;;Simple Binding
-(defclass simple-data-binding (data-binding)
-  ((variable :initarg :variable :reader binding-variable :initform (error "variable is required"))))
-
-(defun make-var (&optional obj)
-  (new "com.jgoodies.binding.value.ValueHolder" obj (jbool nil)))
-
-(defun var (var)
-  (invoke "getValue" var))
-
-(defun (setf var) (value var)
-  (invoke "setValue" var value)
-  value)
-
-(defun make-simple-data-binding (variable)
-  (make-instance 'simple-data-binding :variable variable))
-
-(defmethod make-model ((binding simple-data-binding))
-  (binding-variable binding))
+;;Cellular slot Binding
+(defmodel cell-data-binding (data-binding cells::model-object)
+  ((expression :initarg :expression :reader binding-expression
+	       :initform (error "expression is mandatory")
+	       :cell t)
+   (writer :initarg writer :accessor binding-writer :initform nil :cell nil)
+   (model :accessor binding-model :initform nil :cell nil)))
+
+(defmethod initialize-instance :after ((obj cell-data-binding) &rest args)
+  (declare (ignore args))
+  (setf (binding-model obj)
+	(make-cells-value-model obj)))
+
+(defobserver expression ((binding cell-data-binding) new-value)
+  (bwhen (it (binding-model binding))
+    (invoke "valueChanged" it new-value)))
+
+(defun make-cell-data-binding (expression &optional writer)
+  (check-type writer (or null function))
+  (let ((instance
+	 (make-instance 'cell-data-binding :expression expression)))
+    (setf (binding-writer instance) writer)
+    instance))
+
+(defun make-slot-data-binding (object slot-accessor-name)
+  (make-cell-data-binding
+   (eval `(c? (,slot-accessor-name ,object)))
+   (compile nil `(lambda (x)
+		   (setf (,slot-accessor-name ,object) x)))))
+
+(defmethod make-model ((binding cell-data-binding))
+  (binding-model binding))
+  
+(defun make-cells-value-model (binding)
+  (new "snow.binding.AccessorBinding"
+       binding
+       #'binding-expression
+       (lambda (value place)
+	 (declare (ignore place))
+	 (bwhen (it (binding-writer binding))
+	   (funcall it value)))))
+
+;;Cells-powered Variable Binding
+(defmodel cell-expression ()
+  ((expression :initarg :expression :accessor var
+	       :initform (error "expression is mandatory")
+	       :cell t)))
+
+(defun make-var (&optional initial-value)
+  (make-instance 'cell-expression :expression (c-in initial-value)))
+
+(defun make-simple-data-binding (var)
+  (make-cell-data-binding (c? (var var))
+			  (lambda (x) (setf (var var) x))))
 
 ;;Bean Binding
 
@@ -129,12 +164,17 @@
       (eval (read-from-string bean-name)))
   "A callback called by the EL engine with a single argument, the name of a bean to fetch from the application.")
 
-;;For EL data bindings we reuse simple-data-binding, since its 'variable' can
-;;really be any JGoodies ValueModel
+(defclass value-model ()
+  ((value-model :initarg :value-model :reader value-model)))
+
 (defun make-property-data-binding (obj path)
-  (make-instance 'simple-data-binding
-		 :variable (new "snow.binding.BeanPropertyPathBinding"
-				obj (apply #'jvector "java.lang.String" path))))
+  (make-instance
+   'value-model
+   :value-model (new "snow.binding.BeanPropertyPathBinding"
+		     obj (apply #'jvector "java.lang.String" path))))
+  
+(defmethod make-model ((binding value-model))
+  (value-model binding))
 
 ;;Default binding types
 (defun default-data-binding-constructors ()
@@ -145,9 +185,6 @@
     #+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 'slot ht) 'make-slot-data-binding))
     ht))
 

Modified: trunk/src/lisp/snow/packages.lisp
==============================================================================
--- trunk/src/lisp/snow/packages.lisp	(original)
+++ trunk/src/lisp/snow/packages.lisp	Mon Dec 28 15:11:25 2009
@@ -59,6 +59,7 @@
     #:make-action-listener
     ;;Common operations on widgets
     #:add-child
+    #:child
     #:dispose
     #:dont-add
     #:hide
@@ -74,6 +75,7 @@
     #:widget-location
     #:widget-property
     #:widget-size
+    #:widget-text
     #:widget-visible-p
     ;;Data binding
     #:make-var
@@ -104,6 +106,7 @@
     #:install-graphical-debugger
     #:*parent*
     #:self
+    #:str
     #:syntax
     #:with-gui
     #:with-widget

Modified: trunk/src/lisp/snow/showcase/showcase.lisp
==============================================================================
--- trunk/src/lisp/snow/showcase/showcase.lisp	(original)
+++ trunk/src/lisp/snow/showcase/showcase.lisp	Mon Dec 28 15:11:25 2009
@@ -12,21 +12,21 @@
     `(pushnew
       (list ,name
 	    (lambda ()
-	      (let ((,original-code ',body) (,show-source-p (c-expr nil)))
+	      (let ((,original-code ',body) (,show-source-p (make-var 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)))))
+			  $(c? (jbool (not (var ,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 (var ,show-source-p) t))))
 		  (panel (:layout "dock south, hidemode 3"
-			  :visible-p $(c? (jbool (c-value ,show-source-p))))
+			  :visible-p $(c? (jbool (var ,show-source-p))))
 		    (scroll (:layout "grow, wrap")
 		      (text-area :text
 				 ,(with-output-to-string (str)
@@ -38,7 +38,7 @@
 			    :layout "dock south"
 			    :on-action (lambda (evt)
 					 (declare (ignore evt))
-					 (setf (c-value ,show-source-p) nil))))))))
+					 (setf (var ,show-source-p) nil))))))))
       *examples*
       :test #'equal
       :key #'car)))

Modified: trunk/src/lisp/snow/snow.lisp
==============================================================================
--- trunk/src/lisp/snow/snow.lisp	(original)
+++ trunk/src/lisp/snow/snow.lisp	Mon Dec 28 15:11:25 2009
@@ -35,25 +35,29 @@
 
 (definterface add-child *gui-backend* (child &optional (parent *parent*) layout-constraints))
 
+(definterface (setf widget-background) *gui-backend* (value widget))
+
+(definterface (setf widget-border) *gui-backend* (value widget))
+
 (definterface widget-enabled-p *gui-backend* (widget))
 
 (definterface (setf widget-enabled-p) *gui-backend* (value widget))
 
-(definterface widget-visible-p *gui-backend* (widget))
+(definterface (setf widget-font) *gui-backend* (value widget))
 
-(definterface (setf widget-visible-p) *gui-backend* (value widget))
+(definterface (setf widget-foreground) *gui-backend* (value widget))
 
 (definterface (setf widget-location) *gui-backend* (value widget))
 
 (definterface (setf widget-size) *gui-backend* (value widget))
 
-(definterface (setf widget-background) *gui-backend* (value widget))
+(definterface widget-text *gui-backend* (widget))
 
-(definterface (setf widget-border) *gui-backend* (value widget))
+(definterface (setf widget-text) *gui-backend* (value widget))
 
-(definterface (setf widget-font) *gui-backend* (value widget))
+(definterface widget-visible-p *gui-backend* (widget))
 
-(definterface (setf widget-foreground) *gui-backend* (value widget))
+(definterface (setf widget-visible-p) *gui-backend* (value widget))
 
 (definterface dispose *gui-backend* (obj))
 
@@ -191,14 +195,11 @@
 	    :for form :in children
 	    :collect (if (listp form)
 			 (cond 
-			   ((get (car form) 'widget-p)
-			    `(let ((*parent* self)) ,form))
+			   ((get (car form) 'widget-p) form)
 			   (t `(let ((*parent* nil)) ,form)))
 			 form))))
-    (if id
-	`((let ((,id self))
-	    , at code))
-	code)))
+    `((let (,@(when id `((,id self))) (*parent* self))
+	, at code))))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun common-widget-args ()
@@ -291,8 +292,8 @@
 
 (define-widget-macro child
     (widget &rest args &key &common-widget-args)
-    widget
-  `(setup-widget , at args))
+    `(dont-add ,widget)
+  `(setup-widget self , at args))
 
 (defmacro define-widget (name keys constructor &body body)
   "Convenience macro for defining a widget."

Modified: trunk/src/lisp/snow/swing/swing.lisp
==============================================================================
--- trunk/src/lisp/snow/swing/swing.lisp	(original)
+++ trunk/src/lisp/snow/swing/swing.lisp	Mon Dec 28 15:11:25 2009
@@ -117,17 +117,24 @@
 (defimpl (setf widget-foreground) (value widget)
   (setf (widget-property widget :foreground) value))
 
+(defimplementation (setf widget-location) (*gui-backend* :swing) (value widget)
+  (invoke "setLocation" widget (aref value 0) (aref value 1)))
+
+(defimpl (setf widget-size) (value widget)
+  (invoke "setSize" widget (realpart value) (imagpart value)))
+
+(defimpl (setf widget-text) (value widget)
+  (setf (widget-property widget :text) value))
+
+(defimpl widget-text (widget)
+  (widget-property widget :text))
+
 (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)))
-
-(defimpl (setf widget-size) (value widget)
-  (invoke "setSize" widget (realpart value) (imagpart value)))
 
 (defun make-border (border-spec)
   (if (jinstance-of-p border-spec "javax.swing.border.Border")

Modified: trunk/src/lisp/snow/widgets.lisp
==============================================================================
--- trunk/src/lisp/snow/widgets.lisp	(original)
+++ trunk/src/lisp/snow/widgets.lisp	Mon Dec 28 15:11:25 2009
@@ -1,4 +1,3 @@
-
 ;;; widgets.lisp
 ;;;
 ;;; Copyright (C) 2008-2009 Alessio Stalla