From fc7489de87bbf0cfadf10f6f441c049d7b2bece1 Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Thu, 17 Nov 2011 15:25:40 +0000 Subject: [PATCH] Work in progress. --- Makefile | 12 +- dep-ui.asd | 19 +++ dep-ui.lisp | 198 ++++++++---------------------- go.lisp | 4 + jj.lisp | 45 +++++-- package.lisp | 34 ++++++ rolling.lisp | 4 +- swing.lisp | 149 ----------------------- test.lisp | 9 ++ ui-swing.lisp | 380 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 10 files changed, 534 insertions(+), 320 deletions(-) create mode 100644 dep-ui.asd create mode 100644 go.lisp create mode 100644 package.lisp delete mode 100644 swing.lisp create mode 100644 test.lisp create mode 100644 ui-swing.lisp diff --git a/Makefile b/Makefile index ec088c0..389b5c9 100644 --- a/Makefile +++ b/Makefile @@ -1,10 +1,10 @@ -ABCL_JAR = /usr/local/src/abcl-0.0.10/abcl.jar +ABCL_JAR = /home/mdw/src/abcl/abcl.jar JAVAC = javac JAR = jar GPL = /usr/share/common-licenses/GPL-2 INSTALLER = setup-dep-ui.exe -VERSION = 1.1.0 +VERSION = 1.2.0 all: dep-ui.jar @@ -35,10 +35,10 @@ dep-ui.jar: abcl.jar dep-ui.abcl $(SUBFILES) Startup.class mv tmp.jar $@ rm -rf tmp.jar tmp -jj.abcl swing.abcl queue.abcl dep.abcl:: dep-ui.abcl -dep-ui.abcl: build.lisp \ - jj.lisp swing.lisp queue.lisp dep.lisp dep-ui.lisp - abcl --load build.lisp +jj.abcl ui-swing.abcl queue.abcl dep.abcl:: dep-ui.abcl +dep-ui.abcl: dep-ui.asd jj.lisp ui-swing.lisp queue.lisp dep.lisp dep-ui.lisp + abcl --eval "(require :asdf)" \ + --eval "(let ((sys:*compile-file-zip* nil)) (asdf:oos 'asdf:load-op :dep-ui) (exit))" GPL.dostxt: cp $(GPL) $@.new diff --git a/dep-ui.asd b/dep-ui.asd new file mode 100644 index 0000000..f10ad3a --- /dev/null +++ b/dep-ui.asd @@ -0,0 +1,19 @@ +;;; + +(cl:defpackage #:dep-ui.asdf + (:use #:cl #:asdf)) +(cl:in-package #:dep-ui.asdf) + +(defsystem #:dep-ui + :description "User interface built from dependencies" + :version "1.2.0" + :author "Mark Wooding " + :depends-on (#+(or cmu sbcl clisp) "clg") + :components ((:file "queue") + (:file "weak") + (:file "dep" :depends-on ("queue" "weak")) + #+abcl (:file "jj") + (:file "package" :depends-on ("dep" #+abcl "jj")) + #+abcl (:file "ui-swing" :depends-on ("package")) + (:file "dep-ui" + :depends-on ("dep" "package" #+abcl "ui-swing")))) diff --git a/dep-ui.lisp b/dep-ui.lisp index d6e483c..6641ce7 100644 --- a/dep-ui.lisp +++ b/dep-ui.lisp @@ -21,54 +21,46 @@ ;;; along with this program; if not, write to the Free Software Foundation, ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -(defpackage #:dep-ui - (:use #:common-lisp #:jj #:swing #:java #:dep #:extensions) - (:export #:make-label #:make-input #:make-output #:make-group - #:make-radio-dep #:within-group #:defwindow #:make-window - #:add-reason #:drop-reason)) - (in-package #:dep-ui) ;;;-------------------------------------------------------------------------- +;;; Generic interface. -(defparameter bad-text-colour (make-colour 1.0 0.4 0.4)) -(defparameter good-text-colour - (let ((text (make :javax.swing.*j-text-field))) - (send text :get-background))) +(defvar *live-deps*) (defun update-text-field-dep (field dep convert-func) - (let ((text (send field :get-text))) + (let ((text (field-text field))) (multiple-value-bind (value bogusp) (funcall convert-func text) (cond (bogusp - (send field :set-background bad-text-colour) + (set-field-highlight field :bad) (dep-make-bad dep)) (t (unless (dep-goodp dep) - (send field :set-background good-text-colour)) + (set-field-highlight field :good)) (setf (dep-value dep) value)))))) (defun make-text-field-with-dep (convert-func dep) - (let* ((field (make :javax.swing.*j-text-field)) - (doc (send field :get-document))) - (flet ((kick (&optional ev) - (declare (ignore ev)) - (update-text-field-dep field dep convert-func))) - (send doc :add-document-listener - (jinterface-implementation - (java-name :javax.swing.event.*document-listener) - (java-name :insert-update) #'kick - (java-name :remove-update) #'kick - (java-name :changed-update) #'kick)) - (kick)) - field)) + (make-text-field + :notify (lambda (field) + (update-text-field-dep field dep convert-func)))) (defun update-dep-text-field (field dep convert-func) - (cond ((dep-goodp dep) - (send field :set-background good-text-colour) - (send field :set-text (funcall convert-func (dep-value dep)))) - (t - (send field :set-background bad-text-colour) - (send field :set-text "")))) + (multiple-value-bind (highlight value) + (if (dep-goodp dep) + (values :good (dep-value dep)) + (values :bad "")) + (set-field-highlight field highlight) + (setf (field-text field) (funcall convert-func value)))) + +(defun make-dependent-text-field + (dep &optional (convert-func #'princ-to-string)) + (let ((field (make-text-field :readonly t))) + (flet ((kicked (&optional ev) + (declare (ignore ev)) + (update-dep-text-field field dep convert-func))) + (dep-add-listener dep #'kicked) + (kicked)) + field)) (defun safe-read-from-string (string continuation) (with-input-from-string (stream string) @@ -83,101 +75,32 @@ (lambda (value) (values value (not (realp value)))))) -(defun make-dependent-text-field - (dep &optional (convert-func #'princ-to-string)) - (let ((field (make :javax.swing.*j-text-field))) - (send field :set-editable java-false) - (flet ((kicked (&optional ev) - (declare (ignore ev)) - (update-dep-text-field field dep convert-func))) - (dep-add-listener dep #'kicked) - (kicked)) - field)) +(defun make-input (label dep &key (convert #'read-real-from-string)) + (let ((text (make-text-field-with-dep convert dep))) + (pack-labelled-widget *panel* label text))) -(defun make-label (string) - (let* ((amp (position #\& string)) - (text (if amp - (concatenate 'string - (subseq string 0 amp) - (subseq string (1+ amp))) - string)) - (widget (make :javax.swing.*j-label text - (class-field :javax.swing.*j-label - :*trailing*)))) - (when amp - (send widget :set-displayed-mnemonic-index amp)) - widget)) - -(defun add-text-and-label (panel label text) - (let ((label-widget (make-label label))) - (send panel :add label-widget - (make-grid-bag-constraints :fill :horizontal - :anchor :north - :insets 2)) - (send panel :add text - (make-grid-bag-constraints :fill :horizontal - :anchor :north - :weight-x 1.0 - :insets 2 - :grid-width :remainder)) - (send label-widget :set-label-for text))) - -(defvar *panel* nil) - -(defun make-input (label dep) - (let ((text (make-text-field-with-dep #'read-real-from-string dep))) - (add-text-and-label *panel* label text))) - -(defun make-output (label dep) +(defun make-output (label dep &key (convert "~,3F")) (let ((text (make-dependent-text-field dep - (lambda (value) - (format nil "~,3F" value))))) - (add-text-and-label *panel* label text))) - -(defun twiddle-dep-radio (button dep name) - (send button :add-action-listener - (implementation :java.awt.event.*action-listener - (action-performed (ev) - (declare (ignore ev)) - (setf (dep-value dep) name))))) - -(defun make-radio-dep (dep &rest settings) - (let ((button-group (make :javax.swing.*button-group)) - (panel (make :javax.swing.*j-panel))) - (send *panel* :add panel - (make-grid-bag-constraints :fill :horizontal - :anchor :north - :insets 0 - :weight-x 1.0 - :grid-width :remainder)) - (loop for (name label) on settings by #'cddr - for selectp = (progn - (unless (dep-goodp dep) - (setf (dep-value dep) name)) - (if (eq (dep-value dep) name) - java-true - java-false)) - for button = (make :javax.swing.*j-radio-button label selectp) - do (twiddle-dep-radio button dep name) - do (send button-group :add button) - do (send panel :add button - (make-grid-bag-constraints :fill :horizontal - :insets 2 - :weight-x 1.0))))) - -(defun make-group (label) - (let ((group (make-group-box label))) - (send group :set-layout (make :java.awt.*grid-bag-layout)) - (send *panel* :add group - (make-grid-bag-constraints :fill :horizontal - :anchor :page-start - :insets 2 - :weight-x 1.0 - :grid-width :remainder)) - group)) + (etypecase convert + (string + (lambda (value) + (format nil convert value))) + ((or symbol function) + convert))))) + (pack-labelled-widget *panel* label text))) + +(defun make-radio-dep (dep plist) + (let ((group (make-radio-group + (lambda (value) (setf (dep-value dep) value)) + plist + :default (if (dep-goodp dep) + (dep-value dep) + (setf (dep-value dep) (cadr plist)))))) + (pack-single-widget *panel* group))) + (defmacro within-group ((label) &body body) - `(let ((*panel* (make-group ,label))) + `(let ((*panel* (pack-single-widget *panel* (make-group ,label)))) ,@body)) (let ((reasons 0)) @@ -187,35 +110,10 @@ (assert (plusp reasons)) (decf reasons) (when (zerop reasons) - (send-class :java.lang.*system :exit 0)))) - -(defun make-window (title populate-func) - (let ((window (make :javax.swing.*j-frame title))) - (send window :set-layout (make :java.awt.*grid-bag-layout)) - (let ((*panel* window)) - (funcall populate-func)) - (send window :pack) - (send window :set-visible java-true) - (add-reason) - (send window :set-default-close-operation - (class-field :javax.swing.*j-frame :*do-nothing-on-close*)) - (send window :add-window-listener - (implementation :java.awt.event.*window-listener - (:window-activated (ev) (declare (ignore ev))) - (:window-deactivated (ev) (declare (ignore ev))) - (:window-iconified (ev) (declare (ignore ev))) - (:window-deiconified (ev) (declare (ignore ev))) - (:window-opened (ev) (declare (ignore ev))) - (:window-closing (ev) - (declare (ignore ev)) - (send window :dispose)) - (:window-closed (ev) - (declare (ignore ev)) - (drop-reason)))) - window)) + (exit)))) (defmacro defwindow (name bvl (title) &body body) `(defun ,name ,bvl - (make-window ,title (lambda () ,@body)))) + (make-toplevel ,title (lambda () ,@body)))) ;;;----- That's all, folks -------------------------------------------------- diff --git a/go.lisp b/go.lisp new file mode 100644 index 0000000..a71ab40 --- /dev/null +++ b/go.lisp @@ -0,0 +1,4 @@ +(require :asdf) +(asdf:oos 'asdf:load-op :dep-ui) +(use-package '(:dep :dep-ui)) + diff --git a/jj.lisp b/jj.lisp index d07d2b4..65cf675 100644 --- a/jj.lisp +++ b/jj.lisp @@ -24,7 +24,7 @@ (defpackage #:jj (:use #:common-lisp #:java) (:export #:java-name #:lisp-name - #:java-true #:java-false #:java-null + #:java-true #:java-false #:java-null #:jboolean #:send #:send-class #:make #:make-java-array #:java-array #:field #:class-field #:magic-constant-case @@ -262,6 +262,10 @@ (defconstant java-null (make-immediate-object nil :ref) "A Java null reference.") +(defun jboolean (thing) + "Return JAVA-TRUE if THING is non-nil, JAVA-FALSE if THING is nil." + (if thing java-true java-false)) + (defmacro define-java-method (lisp-name class method &body args) "Define a Lisp function LISP-NAME to call the named METHOD of CLASS on the given arguments. The CLASS may be a string or symbol (it is converted by @@ -382,10 +386,11 @@ (list (java-class-name java-class) (cons :constructors (expand-java-method (ensure-java-constructor java-class))) - (loop for name being the hash-keys - of (ensure-java-method-table java-class) - using (hash-value method) - collect (cons name (expand-java-method method))))) + (sort (loop for name being the hash-keys + of (ensure-java-method-table java-class) + using (hash-value method) + collect (cons name (expand-java-method method))) + (lambda (x y) (string< (car x) (car y)))))) (defparameter *conversions* (let ((raw '((java.lang.*object boolean) @@ -414,7 +419,8 @@ (defun jclass-convertible-p (from to) "Return whether there is an automatic conversion between FROM and TO. This can be considered a partial order on types." - (or (jclass-superclass-p to from) + (or (null from) + (jclass-superclass-p to from) (member from (assoc to *conversions* :test #'equal) :test #'equal))) @@ -428,7 +434,7 @@ (t (and (jclass-convertible-p (car first) (car second)) (argument-list-betterp (cdr first) (cdr second)))))) -(defun get-jmethod-for-argument-types (java-method argument-types) +(defun get-jmethod-for-argument-types (java-class java-method argument-types) "Given a JAVA-METHOD structure, return the best match overload for the given list of ARGUMENT-TYPES. @@ -494,7 +500,10 @@ (format t "*** chosen = ~S~%" (expand-methodlist chosen))) (cond ((null chosen) - (error "No match found.~% method = ~A, args = ~A" + (error "No match found.~% ~ + class = ~A, method = ~A~% ~ + args = ~A" + (java-class-name java-class) (java-method-name java-method) (expand-arglist argument-types))) ((cdr chosen) @@ -517,14 +526,20 @@ (defun find-jmethod (class name arg-types) "Given a CLASS, a method NAME, and a list of ARG-TYPES, return the Java method object for the best matching overload of the method." - (get-jmethod-for-argument-types (find-java-method class name) - (argument-type-list-from-names arg-types))) + (let ((java-class (find-java-class class))) + (get-jmethod-for-argument-types + java-class + (find-java-method java-class name) + (argument-type-list-from-names arg-types)))) (defun find-jconstructor (class arg-types) "Given a CLASS and a list of ARG-TYPES, return the Java constructor object for the best matching constructor overload." - (get-jmethod-for-argument-types (find-java-constructor class) - (argument-type-list-from-names arg-types))) + (let ((java-class (find-java-class class))) + (get-jmethod-for-argument-types + java-class + (find-java-constructor java-class) + (argument-type-list-from-names arg-types)))) (defun send (object message &rest arguments) "Given an OBJECT, a MESSAGE name (Lisp symbol or Java name string) and @@ -533,7 +548,11 @@ (let ((jargs (mapcar #'make-immediate-object arguments))) (apply #'jcall (find-jmethod (jobject-class object) message - (mapcar (lambda (jarg) (jobject-class jarg)) jargs)) + (mapcar (lambda (jarg) + (if (equal jarg java-null) + nil + (jobject-class jarg))) + jargs)) object jargs))) diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..20d83d2 --- /dev/null +++ b/package.lisp @@ -0,0 +1,34 @@ +;;; -*-lisp-*- +;;; +;;; Package definition for dep-ui +;;; +;;; (c) 2008 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. + +(cl:defpackage #:dep-ui + (:use #:common-lisp #:dep . + #+abcl (#:jj #:java #:extensions)) + (:export #:make-label #:make-input #:make-output #:make-group + #:make-radio-dep #:within-group #:defwindow #:make-window + #:add-reason #:drop-reason)) + +(cl:in-package #:dep-ui) +(defvar *panel* nil) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/rolling.lisp b/rolling.lisp index 61874c7..7f9b342 100644 --- a/rolling.lisp +++ b/rolling.lisp @@ -48,8 +48,8 @@ (make-output "Length:" start-length)) (within-group ("Initial stock") (make-radio-dep stock-type - :round "Round section" - :square "Square section") + '(:round "Round section" + :square "Square section")) (make-input "Stock size:" stock-size) (make-output "Stock length:" stock-length)) #+ no diff --git a/swing.lisp b/swing.lisp deleted file mode 100644 index 238d691..0000000 --- a/swing.lisp +++ /dev/null @@ -1,149 +0,0 @@ -;;; -*-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 -------------------------------------------------- diff --git a/test.lisp b/test.lisp new file mode 100644 index 0000000..4757cfe --- /dev/null +++ b/test.lisp @@ -0,0 +1,9 @@ +(defun test() + (let ((list nil)) + (flet ((func (i) + (jj:implementation java.lang.*runnable + (run () (format t "running ~A~%" i))))) + (mapc (lambda (j) + (jj:send j :run)) + (loop for i in '(a b c d) + collect (func i)))))) diff --git a/ui-swing.lisp b/ui-swing.lisp new file mode 100644 index 0000000..ac133b7 --- /dev/null +++ b/ui-swing.lisp @@ -0,0 +1,380 @@ +;;; -*-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. + +(in-package #:dep-ui) + +;;;-------------------------------------------------------------------------- +;;; Utilities. + +(defun listify (thing) + "Answer THING if it's a list, else a singleton list containing THING." + (if (listp thing) thing (list thing))) + +;;;-------------------------------------------------------------------------- +;;; Basic stuff. + +(defclass widget () + ((java :reader widget-java :initarg :java))) + +(defmethod widget-java ((widget t)) widget) + +(defmethod widget-insets ((widget t)) 2) + +;;;-------------------------------------------------------------------------- +;;; 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)))) + +;;;-------------------------------------------------------------------------- +;;; Colours. + +(let ((builtin-colours (make-hash-table))) + + ;; Build a table of standard Java colours. + (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) + "Return a newly constructed colour object. + + The ARGUMENTS may be one of the following. + + * nil -- return a null reference, rather than a colour. + + * JAVA-OBJECT -- return the JAVA-OBJECT unmolested. + + * KEYWORD -- return the standard colour named by KEYWORD. + + * STRING -- return the Java colour named by STRING. + + * RGB &optional ALPHAP -- interpret the integer RGB as a 3-byte packed + RGB triple (logior (ash RED 16) (ash GREEN 8) (ash BLUE 0)); if + ALPHA-P is nil (the default) then apply full alpha; if it's t, then + read alpha from byte 3 of RGB; otherwise it's a raw alpha value (see + below). + + * RED GREEN BLUE &optional (ALPHA 1.0) -- each of the RED, GREEN, BLUE + and ALPHA arguments is a number, either an integer in [0, 256)" + (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) (null (cddr 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))))))))) + +;;;-------------------------------------------------------------------------- +;;; Text fields. + +(defun make-text-field (&key readonly notify) + "Construct and reutrn a text entry field. + + If READONLY is non-nil then don't allow user edits. If NOTIFY is non-nil, + then assume that it's a function of one argument, and call (funcall NOTIFY + FIELD) when the field's contents are changed." + (let ((field (make :javax.swing.*j-text-field))) + (when readonly + (send field :set-editable java-false)) + (when notify + (flet ((kick (&optional ev) + (declare (ignore ev)) + (funcall notify field))) + (send (send field :get-document) :add-document-listener + (jinterface-implementation + (java-name :javax.swing.event.*document-listener) + (java-name :insert-update) #'kick + (java-name :remove-update) #'kick + (java-name :changed-update) #'kick)) + (kick))) + field)) + +(defun field-text (field) + "Return the contents of the text field FIELD. This is a SETF-able place." + (send field :get-text)) +(defun (setf field-text) (text field) + "Modify the contents of the text field FIELD." + (send field :set-text text)) + +(let ((good-colour + (send (make :javax.swing.*j-text-field) :get-background)) + (bad-colour (make-colour 1.0 0.4 0.4))) + (defun set-field-highlight (field highlight) + "Highlight the text field FIELD according to HIGHLIGHT. + + The HIGHLIGHT may currently be :good or :bad." + (send field :set-background (ecase highlight + (:good good-colour) + (:bad bad-colour))))) + +;;;-------------------------------------------------------------------------- +;;; Labels. + +(defun make-label (string) + "Create and return a label widget showing the STRING. + + If an ampersand appears in the string, underline the following letter." + (let* ((amp (position #\& string)) + (text (if amp + (concatenate 'string + (subseq string 0 amp) + (subseq string (1+ amp))) + string)) + (widget (make :javax.swing.*j-label text + (class-field :javax.swing.*j-label + :*trailing*)))) + (when amp + (send widget :set-displayed-mnemonic-index amp)) + widget)) + +;;;-------------------------------------------------------------------------- +;;; Group boxes. + +(defun make-group (label) + "Create and return a group box with a given LABEL (a string) as its title." + (let ((group (make :javax.swing.*j-panel))) + (send group :set-border + (make :javax.swing.border.*titled-border + (make :javax.swing.border.*etched-border + (class-field :javax.swing.border.*etched-border + :*lowered*)) + label)) + (send group :set-layout (make :java.awt.*grid-bag-layout)) + group)) + +;;;-------------------------------------------------------------------------- +;;; Radio buttons. + +(defclass radio-group (widget) + ((alist))) + +(defmethod widget-insets ((widget radio-group)) 0) + +(defun radio-notifier-hack (value notify) + ;; This would be an FLET function in MAKE-RADIO-GROUP, but ABCL is buggy. + (implementation :java.awt.event.*action-listener + (action-performed (ev) + (declare (ignore ev)) + (format t "notify: ~A~%" value) + (funcall notify value)))) + +(defun make-radio-group (notify plist &key default) + (let* ((button-group (make :javax.swing.*button-group)) + (panel (make :javax.swing.*j-panel)) + (alist (loop for (value label) on plist by #'cddr + for selectp = (jboolean (eq value default)) + for button = (make :javax.swing.*j-radio-button + label selectp) + do (format t "establish ~A~%" value) + (send button :add-action-listener + (radio-notifier-hack value notify)) + (send button-group :add button) + (send panel :add button + (make-grid-bag-constraints :fill :horizontal + :insets 2 + :weight-x 1.0)) + collect (cons value button)))) + (make-instance 'radio-group + :java panel + :alist alist))) + +(defun radio-group-selected (group) + (loop for (value . button) in (slot-value group 'alist) + when (send button :is-selected) return value + finally (return nil))) + +(defun (setf radio-group-selected) (value group) + (send (or (assoc value (slot-value group 'alist)) + (error "Invalid value ~S for this radio group." value)) + :set-selected java-true) + value) + +;;;-------------------------------------------------------------------------- +;;; Widget packing. + +(defun pack-single-widget (panel widget) + (send panel :add (widget-java widget) + (make-grid-bag-constraints :fill :horizontal + :anchor :page-start + :insets (widget-insets widget) + :weight-x 1.0 + :grid-width :remainder)) + widget) + +(defun pack-labelled-widget (panel label widget) + (let ((label-widget (make-label label)) + (other-widget (widget-java widget))) + (send panel :add label-widget + (make-grid-bag-constraints :fill :horizontal + :anchor :north + :insets 2)) + (send panel :add other-widget + (make-grid-bag-constraints :fill :horizontal + :anchor :north + :weight-x 1.0 + :insets 2 + :grid-width :remainder)) + (send label-widget :set-label-for other-widget) + widget)) + +;;;-------------------------------------------------------------------------- +;;; Toplevel windows. + +(defclass toplevel (widget) + ((java :initform (make :javax.swing.*j-frame)))) + +(defmethod toplevel-closing ((widget toplevel)) + (send (widget-java widget) :set-visible java-false)) +(defmethod toplevel-closed ((widget toplevel)) (drop-reason)) +(defmethod toplevel-opened ((widget toplevel)) (add-reason)) + +(defmethod shared-initialize ((widget toplevel) slot-names &key title) + (declare (ignore slot-names)) + (unless (slot-boundp widget 'java) + (setf (slot-value widget 'java) (make :javax.swing.*j-frame))) + (let ((window (widget-java widget))) + (when title + (send window :set-title title)) + (send window :set-layout (make :java.awt.*grid-bag-layout)) + (send window :set-default-close-operation + (class-field :javax.swing.*j-frame :*do-nothing-on-close*)) + (send window :add-window-listener + (implementation :java.awt.event.*window-listener + (:window-activated (ev) (declare (ignore ev))) + (:window-deactivated (ev) (declare (ignore ev))) + (:window-iconified (ev) (declare (ignore ev))) + (:window-deiconified (ev) (declare (ignore ev))) + (:window-opened (ev) (declare (ignore ev))) + (:window-closing (ev) + (declare (ignore ev)) + (toplevel-closing widget)) + (:window-closed (ev) + (declare (ignore ev)) + (toplevel-closed widget)))))) + +(defun show-toplevel (widget) + (let ((window (widget-java widget))) + (unless (send window :is-showing) + (toplevel-opened widget) + (send window :set-visible java-true)))) + +(defun make-toplevel (title populate-func) + (let* ((widget (make-instance 'toplevel :title title))) + (let ((*panel* (widget-java widget))) + (funcall populate-func) + (send *panel* :pack)) + (show-toplevel widget) + widget)) + +;;;-------------------------------------------------------------------------- +;;; Other stuff. + +(unless (fboundp 'exit) + (defun exit (&optional (return-code 0)) + (send-class :java.lang.*system :exit return-code))) + +;;;----- That's all, folks -------------------------------------------------- -- 2.11.0