[snow-cvs] r39 - in trunk/src/lisp/snow: . swing

[Alessio Stalla]

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"))