Commit | Line | Data |
---|---|---|
ee79a5f1 MW |
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 -------------------------------------------------- |