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