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