;;; swing.lisp
;;;
;;; Copyright (C) 2008-2010 Alessio Stalla
;;;
;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
;;;
;;; As a special exception, the copyright holders of this library give you
;;; permission to link this library with independent modules to produce an
;;; executable, regardless of the license terms of these independent
;;; modules, and to copy and distribute the resulting executable under
;;; terms of your choice, provided that you also meet, for each linked
;;; independent module, the terms and conditions of the license of that
;;; module.  An independent module is a module which is not derived from
;;; or based on this library.  If you modify this library, you may extend
;;; this exception to your version of the library, but you are not
;;; obligated to do so.  If you do not wish to do so, delete this
;;; exception statement from your version.

(in-package :snow)

(defun setup-button (btn text on-action)
  (when text
    (setf (widget-property btn :text) text))
  (when on-action
    (invoke "addActionListener"
	    btn
	    (make-action-listener on-action))))

(defun make-action-listener (obj)
  (cond
    ((or (functionp obj) (symbolp obj))
     (jmake-proxy "java.awt.event.ActionListener"
		  (lambda/dynamic-environment (this method-name event)
		    (declare (ignore this method-name))
		    (let ((*event* event))
		      (funcall obj)))))
    ((stringp obj)
     (unless *backing-bean*
       (error "No backing bean specified while action listener is a method name: ~A~%" obj))
     (make-action-listener (jmethod (jclass-of *backing-bean*) obj
				    (jclass "java.awt.event.ActionEvent"))))
    ((jinstance-of-p obj (jclass "java.lang.reflect.Method"))
     (unless *backing-bean*
       (error "No backing bean specified while action listener is a jmethod: ~A~%" obj))
     (make-action-listener
      (let ((bb *backing-bean*))
	#'(lambda () (jcall obj bb *event*)))))
    (t obj))) ;This allows to use a native Java action listener

(defun make-layout-manager (widget layout &rest args)
  "Creates an object used to layout components."
  (if (typep layout 'java-object)
      layout
      (ecase layout
	((or :default :mig) (apply #'new "net.miginfocom.swing.MigLayout" args))
	(:box (new "javax.swing.BoxLayout"
		   (if (jinstance-of-p widget "javax.swing.JFrame")
		       (invoke "getContentPane" widget)
		       widget)
		   (ecase (car args)
		     (:x (jfield "javax.swing.BoxLayout" "X_AXIS"))
		     (:y (jfield "javax.swing.BoxLayout" "Y_AXIS")))))
	(:flow (new "java.awt.FlowLayout"))
	(:border (new "java.awt.BorderLayout"))
	((nil) nil))))

(defun (setf layout-manager) (lm widget)
  "Sets the layout manager for a given (container) widget."
  (setf (widget-property widget :layout) lm))

(defun setup-mouse-listeners
  (widget on-mouse-click on-mouse-press on-mouse-release
	  on-mouse-enter on-mouse-exit on-mouse-drag on-mouse-move)
  "Sets mouse listener(s) on a widget."
  (let ((mouse-input-listener
	 (new "snow.swing.MouseInputListener"
	      on-mouse-click on-mouse-press on-mouse-release
	      on-mouse-enter on-mouse-exit
	      on-mouse-drag on-mouse-move)))
    (when (or on-mouse-click on-mouse-press on-mouse-release
	      on-mouse-enter on-mouse-exit)
      (invoke "addMouseListener" widget mouse-input-listener))
    (when (or on-mouse-drag on-mouse-move)
      (invoke "addMouseMotionListener" widget mouse-input-listener))))

(defconstant +add-to-container+ (jmethod "java.awt.Container" "add" "java.awt.Component"))

(defconstant +add-to-container-with-constraints+ (jmethod "java.awt.Container" "add" "java.lang.String" "java.awt.Component"))

(defun call-in-gui-thread (fn)
  "Arranges <fn> to be called from a thread in which it is safe to create GUI components (for example, the Event Dispatching Thread in Swing)."
  (jstatic "invokeLater" "javax.swing.SwingUtilities"
	   (new "snow.FunctionRunnable" fn)))

;;Base API implementation
(defun add-child (child &optional (parent *parent*) layout-constraints)
  (if layout-constraints
      (jcall +add-to-container-with-constraints+
	     parent
	     layout-constraints
	     child)
      (jcall +add-to-container+ parent child)))

(defun (setf widget-enabled-p) (value widget)
  (setf (widget-property widget :enabled) value))

(defun widget-enabled-p (widget)
  (widget-property widget :enabled))

(defun (setf widget-font) (value widget)
  (setf (widget-property widget :font) value))

(defun (setf widget-background) (value widget)
  (setf (widget-property widget :background) value))

(defun (setf widget-foreground) (value widget)
  (setf (widget-property widget :foreground) value))

(defun (setf widget-location) (value widget)
  (invoke "setLocation" widget (aref value 0) (aref value 1)))

(defun (setf widget-size) (value widget)
  (invoke "setSize" widget (realpart value) (imagpart value)))

(defun (setf widget-text) (value widget)
  (setf (widget-property widget :text) value))

(defun widget-text (widget)
  (widget-property widget :text))

(defun (setf widget-visible-p) (value widget)
  (setf (widget-property widget :visible) value))

(defun widget-visible-p (widget)
  (widget-property widget :visible))

(defun make-border (border-spec)
  (if (jinstance-of-p border-spec "javax.swing.border.Border")
      border-spec
      (let ((border (ensure-list border-spec)))
	(ecase (car border)
	  (:bevel
	   (let ((type (ecase (or (cadr border) :lowered)
			 (:lowered
			  (jfield "javax.swing.border.BevelBorder" "LOWERED"))
			 (:raised
			  (jfield "javax.swing.border.BevelBorder" "RAISED")))))
	     (jcall (jmethod "javax.swing.BorderFactory"
			     "createBevelBorder" "int")
		    nil type)))
	  (:compound 
	   (let ((outer (cadr border)) (inner (caddr border)))
	     (jcall (jmethod "javax.swing.BorderFactory"
			     "createCompoundBorder"
			     "javax.swing.border.Border"
			     "javax.swing.border.Border")
		    nil outer inner)))
	  (:empty
	   (if (cdr border)
	       (if (= 4 (length (cdr border)))
		   (jcall (jmethod "javax.swing.BorderFactory"
				   "createEmptyBorder" "int" "int" "int" "int")
			  nil (second border) (third border) (fourth border)
			  (fifth border))
		   (error "Wrong number of arguments for empty border: ~A (~S)"
			  (length (cdr border)) (cdr border)))
	       (jcall (jmethod "javax.swing.BorderFactory"
			       "createEmptyBorder")
		      nil)))
	  ))))

(defun (setf widget-border) (value widget)
  (when (jinstance-of-p widget "javax.swing.JComponent")
    (invoke "setBorder" widget (if value (make-border value) nil))))

(defun dispose (obj)
  (invoke "dispose" obj))

(defun show (obj)
  (invoke "show" obj))

(defun hide (obj)
  (invoke "hide" obj))

(defun color (color-spec)
  "Constructs an object representing a color. The color can be specified the 24-bit RGB number, or by symbolic constants such as :black, :red or :green."
  (cond
    ((integerp color-spec) (new "java.awt.Color" color-spec))
    ((keywordp color-spec) (case color-spec
			     (:black (jfield "java.awt.Color" "BLACK"))
			     (:blue  (jfield "java.awt.Color" "BLUE"))
			     (:green (jfield "java.awt.Color" "GREEN"))
			     (:red   (jfield "java.awt.Color" "RED"))
			     (:white (jfield "java.awt.Color" "WHITE"))))
    (t (error "Invalid color: ~A" color-spec))))

(defun font (name size &optional style)
  "Constructs an object representing a font. Parameters:
 name the name of the font family
 size the size in points
 style if provided, one of :plain, :bold, :italic or :bold-italic"
  (let ((style-int (case style
		     ((or :plain nil) (jfield "java.awt.Font" "PLAIN"))
		     (:bold (jfield "java.awt.Font" "BOLD"))
		     (:italic (jfield "java.awt.Font" "ITALIC"))
		     (:bold-italic (logior (jfield "java.awt.Font" "BOLD")
					   (jfield "java.awt.Font" "ITALIC")))
		     (t (error "Unknown font style: ~A" style)))))
    (new "java.awt.Font" name style-int size)))
