Overhaul.

[jlisp] / swing.lisp

;;; -*-lisp-*-
;;;
;;; Pleasant Lisp interface to Swing functions
;;;
;;; (c) 2007 Mark Wooding
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(defpackage #:swing
  (:use #:common-lisp #:jj)
  (:export #:make-insets #:make-grid-bag-constraints #:make-colour
	   #:make-group-box))

(in-package #:swing)

;;;--------------------------------------------------------------------------
;;; Utilities.

(defun listify (thing)
  (if (listp thing) thing (list thing)))

;;;--------------------------------------------------------------------------
;;; Grid-bag constraints.

(defun make-insets (&rest arguments)
  "Return a java.awt.*insets object from the given ARGUMENTS.  The forms
   accepted are:

     * (make-insets) -> (0, 0, 0, 0)

     * (make-insets N) -> (N, N, N, N)

     * (make-insets &key :left :right :top :bottom) -> obvious thing"
  (apply #'make :java.awt.*insets
	 (cond ((null arguments) '(0 0 0 0))
	       ((and (endp (cdr arguments))
		     (integerp (car arguments)))
		(make-list 4 :initial-element (car arguments)))
	       (t (destructuring-bind (&key (left 0) (right 0) (top 0)
					    (bottom 0)) arguments
		    (list top left bottom right))))))

(defun make-grid-bag-constraints
    (&key grid-x grid-y grid-width grid-height weight-x weight-y
     anchor fill insets internal-pad-x internal-pad-y)
  "Return a java.awt.*grind-bag-constraints object.  Arguments may be as
   follows.

     * GRID-X, GRID-Y -- an integer or :relative  [default :relative]

     * GRID-WIDTH, GRID-HEIGHT -- an integer, :relative or  :remainder
       [default 1]

     * WEIGHT-X, WEIGHT-Y -- a float in [0, 1]  [default 0.0]

     * ANCHOR -- one of :center, :north, :northeast :northwest, :west, :east,
       :south, :southwest, :southeast, :page-start, :line-start, :line-end,
       :page-end, :last-line-start, :last-line-end, :first-line-start,
       :first-line-end  [default :center]

     * FILL -- one of :none, :horizontal, :vertical, :both  [default :none]

     * INSETS -- something acceptable to make-insets (q.v.)  [default 0]

     * INTERNAL-PAD-X, INTERNAL-PAD-Y -- integers  [default 0]"

  (flet ((magic (x)
	   (if (keywordp x)
	       (magic-constant-case (x :java.awt.*grid-bag-constraints)
		 :first-line-start :first-line-end
		 :page-start :line-start :line-end :page-end
		 :last-line-start :last-line-end
		 :none :both :horizontal :vertical
		 :relative :remainder
		 :northwest :north :northeast
		 :west :center :east
		 :southwest :south :southeast)
	       x)))
  (make :java.awt.*grid-bag-constraints
	(magic (or grid-x :relative)) (magic (or grid-y :relative))
	(magic (or grid-width 1)) (magic (or grid-height 1))
	(or weight-x 0.0) (or weight-y 0.0)
	(magic (or anchor :center)) (magic (or fill :none))
	(apply #'make-insets (listify insets))
	(or internal-pad-x 0) (or internal-pad-y 0))))

(let ((builtin-colours (make-hash-table)))
  (dolist (colour '(:black :blue :cyan :dark-gray :gray :green :light-gray
		    :magenta :orange :pink :red :white :yellow))
    (setf (gethash colour builtin-colours)
	  (class-field :java.awt.*color
		       (substitute #\_ #\- (string-upcase colour)))))
  (defun make-colour (&rest arguments)
    (let ((indicator (car arguments)))
      (etypecase indicator
	(null java-null)
	(java-object indicator)
	(keyword
	 (or (gethash indicator builtin-colours)
	     (error "Colour ~S not found." indicator)))
	(string
	 (send-class :java.awt.*color :get-color indicator))
	(number
	 (multiple-value-bind (red green blue alpha)
	     (if (and (integerp indicator) (not (numberp (cadr arguments))))
		 (destructuring-bind (rgb &key alpha) arguments
		   (values (ldb (byte 8 16) rgb)
			   (ldb (byte 8  8) rgb)
			   (ldb (byte 8  0) rgb)
			   (case alpha
			     ((t) (ldb (byte 8 24) rgb))
			     ((nil) 255)
			     (t alpha))))
		 (destructuring-bind (r g b &optional (a 1.0)) arguments
		   (values r g b a)))
	   (flet ((fixup (n)
		    (if (integerp n) n (round (* n 255)))))
	     (make :java.awt.*color
		   (fixup red)
		   (fixup green)
		   (fixup blue)
		   (fixup alpha)))))))))

(defun make-group-box (title)
  (let ((frame (make :javax.swing.*j-panel)))
    (send frame :set-border
	  (make :javax.swing.border.*titled-border
		(make :javax.swing.border.*etched-border
		      (class-field :javax.swing.border.*etched-border
				   :*lowered*))
		title))
    frame))

;;;----- That's all, folks --------------------------------------------------