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

[Alessio Stalla]

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