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

[Alessio Stalla]

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