chiark - git - mdw - jlisp/blob - swing.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Pleasant Lisp interface to Swing functions
   4 ;;;
   5 ;;; (c) 2007 Mark Wooding
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This program is free software; you can redistribute it and/or modify
  11 ;;; it under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 2 of the License, or
  13 ;;; (at your option) any later version.
  14 ;;;
  15 ;;; This program is distributed in the hope that it will be useful,
  16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with this program; if not, write to the Free Software Foundation,
  22 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  23
  24 (defpackage #:swing
  25   (:use #:common-lisp #:jj)
  26   (:export #:make-insets #:make-grid-bag-constraints #:make-colour
  27            #:make-group-box))
  28
  29 (in-package #:swing)
  30
  31 ;;;--------------------------------------------------------------------------
  32 ;;; Utilities.
  33
  34 (defun listify (thing)
  35   (if (listp thing) thing (list thing)))
  36
  37 ;;;--------------------------------------------------------------------------
  38 ;;; Grid-bag constraints.
  39
  40 (defun make-insets (&rest arguments)
  41   "Return a java.awt.*insets object from the given ARGUMENTS.  The forms
  42    accepted are:
  43
  44      * (make-insets) -> (0, 0, 0, 0)
  45
  46      * (make-insets N) -> (N, N, N, N)
  47
  48      * (make-insets &key :left :right :top :bottom) -> obvious thing"
  49   (apply #'make :java.awt.*insets
  50          (cond ((null arguments) '(0 0 0 0))
  51                ((and (endp (cdr arguments))
  52                      (integerp (car arguments)))
  53                 (make-list 4 :initial-element (car arguments)))
  54                (t (destructuring-bind (&key (left 0) (right 0) (top 0)
  55                                             (bottom 0)) arguments
  56                     (list top left bottom right))))))
  57
  58 (defun make-grid-bag-constraints
  59     (&key grid-x grid-y grid-width grid-height weight-x weight-y
  60      anchor fill insets internal-pad-x internal-pad-y)
  61   "Return a java.awt.*grind-bag-constraints object.  Arguments may be as
  62    follows.
  63
  64      * GRID-X, GRID-Y -- an integer or :relative  [default :relative]
  65
  66      * GRID-WIDTH, GRID-HEIGHT -- an integer, :relative or  :remainder
  67        [default 1]
  68
  69      * WEIGHT-X, WEIGHT-Y -- a float in [0, 1]  [default 0.0]
  70
  71      * ANCHOR -- one of :center, :north, :northeast :northwest, :west, :east,
  72        :south, :southwest, :southeast, :page-start, :line-start, :line-end,
  73        :page-end, :last-line-start, :last-line-end, :first-line-start,
  74        :first-line-end  [default :center]
  75
  76      * FILL -- one of :none, :horizontal, :vertical, :both  [default :none]
  77
  78      * INSETS -- something acceptable to make-insets (q.v.)  [default 0]
  79
  80      * INTERNAL-PAD-X, INTERNAL-PAD-Y -- integers  [default 0]"
  81
  82   (flet ((magic (x)
  83            (if (keywordp x)
  84                (magic-constant-case (x :java.awt.*grid-bag-constraints)
  85                  :first-line-start :first-line-end
  86                  :page-start :line-start :line-end :page-end
  87                  :last-line-start :last-line-end
  88                  :none :both :horizontal :vertical
  89                  :relative :remainder
  90                  :northwest :north :northeast
  91                  :west :center :east
  92                  :southwest :south :southeast)
  93                x)))
  94   (make :java.awt.*grid-bag-constraints
  95         (magic (or grid-x :relative)) (magic (or grid-y :relative))
  96         (magic (or grid-width 1)) (magic (or grid-height 1))
  97         (or weight-x 0.0) (or weight-y 0.0)
  98         (magic (or anchor :center)) (magic (or fill :none))
  99         (apply #'make-insets (listify insets))
 100         (or internal-pad-x 0) (or internal-pad-y 0))))
 101
 102 (let ((builtin-colours (make-hash-table)))
 103   (dolist (colour '(:black :blue :cyan :dark-gray :gray :green :light-gray
 104                     :magenta :orange :pink :red :white :yellow))
 105     (setf (gethash colour builtin-colours)
 106           (class-field :java.awt.*color
 107                        (substitute #\_ #\- (string-upcase colour)))))
 108   (defun make-colour (&rest arguments)
 109     (let ((indicator (car arguments)))
 110       (etypecase indicator
 111         (null java-null)
 112         (java-object indicator)
 113         (keyword
 114          (or (gethash indicator builtin-colours)
 115              (error "Colour ~S not found." indicator)))
 116         (string
 117          (send-class :java.awt.*color :get-color indicator))
 118         (number
 119          (multiple-value-bind (red green blue alpha)
 120              (if (and (integerp indicator) (not (numberp (cadr arguments))))
 121                  (destructuring-bind (rgb &key alpha) arguments
 122                    (values (ldb (byte 8 16) rgb)
 123                            (ldb (byte 8  8) rgb)
 124                            (ldb (byte 8  0) rgb)
 125                            (case alpha
 126                              ((t) (ldb (byte 8 24) rgb))
 127                              ((nil) 255)
 128                              (t alpha))))
 129                  (destructuring-bind (r g b &optional (a 1.0)) arguments
 130                    (values r g b a)))
 131            (flet ((fixup (n)
 132                     (if (integerp n) n (round (* n 255)))))
 133              (make :java.awt.*color
 134                    (fixup red)
 135                    (fixup green)
 136                    (fixup blue)
 137                    (fixup alpha)))))))))
 138
 139 (defun make-group-box (title)
 140   (let ((frame (make :javax.swing.*j-panel)))
 141     (send frame :set-border
 142           (make :javax.swing.border.*titled-border
 143                 (make :javax.swing.border.*etched-border
 144                       (class-field :javax.swing.border.*etched-border
 145                                    :*lowered*))
 146                 title))
 147     frame))
 148
 149 ;;;----- That's all, folks --------------------------------------------------