;;; widgets.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)

(defmacro defwidget (name &rest args)
  (let ((maker-sym (intern (str (symbol-name '#:make-) (symbol-name name)))))
    `(define-widget ,name (,@args &allow-other-keys) ,maker-sym)))

;;Windows and dialogs
(defun make-frame (&key menu-bar title visible-p on-close
			   &allow-other-keys)
  (let ((f (new "javax.swing.JFrame")))
    (set-widget-properties f
      :title title 
      :visible (jbool visible-p))
    (when menu-bar
      (setf (widget-property f "JMenuBar") menu-bar))
    (when on-close
      (let ((on-close
	     (case on-close
	       ((#'ext:exit 'ext:exit :exit)
		(lambda (evt)
		  (declare (ignore evt))
		  (ext:exit)))
	       (t on-close))))
	(invoke "addWindowListener" f (new "snow.swing.WindowListener"
					   nil nil on-close nil nil nil nil))))
    f))

(define-container-widget frame (menu-bar title on-close) make-frame)

(defun make-dialog (&key parent title modal-p visible-p &allow-other-keys)
  (let ((d (jnew "javax.swing.JDialog"
		parent
		(if modal-p
		    (jfield "java.awt.Dialog$ModalityType" "APPLICATION_MODAL")
		    (jfield "java.awt.Dialog$ModalityType" "MODELESS")))))
    (set-widget-properties d
      :title title)
    d))

(define-widget-macro dialog
    ((&rest args &key &common-widget-args
	    id layout-manager parent title modal-p visible-p)
     &body body)
    `(funcall (lambda (&rest args) ;;to evaluate args only once
		(let ((self (apply (function make-dialog) args)))
		  (apply #'setup-widget self `(:visible-p nil ,@args))
		  (apply #'setup-container-widget self args)
		  self))
	      ;;remove id because it must not be evaluated
	      ;;and visible-p because it must be set last
	      ,@(filter-arglist args '(:id :visible-p)))
  `(progn
     ,@(generate-default-children-processing-code id body)
     (setf (widget-visible-p self) ,visible-p)))

(defun pack (window)
  (jcall (jmethod "java.awt.Window" "pack") window)
  window)

;;Menus
(defun make-menu-bar (&key &allow-other-keys)
  (jnew "javax.swing.JMenuBar"))

(define-container-widget menu-bar () make-menu-bar)

(defun make-menu (&key text &allow-other-keys)
  (if text
      (jnew "javax.swing.JMenu" text)
      (jnew "javax.swing.JMenu")))

(define-container-widget menu (text) make-menu)

(defun make-menu-item (&key text on-action &allow-other-keys)
  (let ((m (new "javax.swing.JMenuItem")))
    (setup-button m text on-action)
    m))

(define-widget menu-item (text on-action) make-menu-item)

;;Panels
(defun make-panel (&key &allow-other-keys)
  (jnew "javax.swing.JPanel"))

(define-container-widget panel () make-panel)

(defvar *tabs*)

(defun make-tabs (&key (wrap t) (tab-placement :top) &allow-other-keys)
  (let ((tabs (jnew "javax.swing.JTabbedPane")))
    (invoke "setTabLayoutPolicy" tabs
	    (if wrap
		(jfield "javax.swing.JTabbedPane" "WRAP_TAB_LAYOUT")
		(jfield "javax.swing.JTabbedPane" "SCROLL_TAB_LAYOUT")))
    (invoke "setTabPlacement" tabs
	    (ecase tab-placement
	      (:top (jfield "javax.swing.JTabbedPane" "TOP"))
	      (:bottom (jfield "javax.swing.JTabbedPane" "BOTTOM"))
	      (:left (jfield "javax.swing.JTabbedPane" "LEFT"))
	      (:right (jfield "javax.swing.JTabbedPane" "RIGHT"))))
    tabs))

(define-widget-macro tabs
    ((&rest args &key id &common-widget-args (wrap t) (tab-placement :top))
     &body body)
    `(make-tabs :wrap ,wrap :tab-placement ,tab-placement)
  `(let ((*tabs* self))
     (dont-add
       ,@(if id
	     `((let ((,id self))
		 ,@body))
	     body))
     (setup-widget self ,@(filter-arglist args '(:id)))))

(defmacro tab (name &body body)
  `(if *tabs*
       (add-child (progn ,@body) *tabs* ,name)
       (error "tab outside tabset: ~A" ,name)))

(defun make-scroll-panel (view)
  (let ((p (jnew "javax.swing.JScrollPane")))
    (setf (scroll-panel-view p) view)
    p))

(defun scroll-panel-view (self)
  (jproperty-value self "viewportView"))

(defun (setf scroll-panel-view) (view self)
  (setf (jproperty-value self "viewportView") view))

(define-widget-macro scroll
    ((&rest args &key &common-widget-args) body)
    `(make-scroll-panel (dont-add ,body))
  `(setup-widget self ,@args))

(defun make-split-panel (child1 child2
			 &key (orientation :horizontal) smoothp)
  (new "javax.swing.JSplitPane"
       (ecase orientation
	 ((or :horizontal :h nil)
	  #.(jfield "javax.swing.JSplitPane" "HORIZONTAL_SPLIT"))
	 ((or :vertical :v)
	  #.(jfield "javax.swing.JSplitPane" "VERTICAL_SPLIT")))
       (jbool smoothp)
       child1
       child2))

(define-widget-macro split
    ((&rest args &key &common-widget-args orientation smoothp)
     child1 child2)
    `(make-split-panel (dont-add ,child1) (dont-add ,child2)
		       :orientation ,orientation :smoothp ,smoothp)
  `(setup-widget self ,@(filter-arglist args '(:orientation :smoothp))))
					
;;Buttons and similar
(defun make-button (&key text on-action &allow-other-keys)
  (let ((btn (new "javax.swing.JButton")))
    (setup-button btn text on-action)
    btn))

(defwidget button text on-action)

(defun make-check-box (&key text selected-p &allow-other-keys)
  (let ((btn (new "javax.swing.JCheckBox")))
    (when text
      (setf (widget-property btn :text) text))
    (setf (widget-property btn :selected)
	  (if selected-p selected-p (jbool nil)))
    btn))

(defwidget check-box text selected-p)

;;Text
(defun make-label (&key text &allow-other-keys)
  (let ((lbl (new "javax.swing.JLabel")))
    (when text
      (setf (widget-property lbl :text) text))
    lbl))

(defwidget label text)

(defun make-text-field (&key text &allow-other-keys)
  (let ((field (new "javax.swing.JTextField")))
    (when text
      (setf (widget-property field :text) text))
    field))

(defwidget text-field text)

(defun make-text-area (&key text &allow-other-keys)
  (let ((text-area (new "javax.swing.JTextArea")))
    (when text
      (setf (widget-property text-area :text) text))
    text-area))

(defwidget text-area text)

(defun make-dialog-prompt-stream ()
  (jnew "snow.SwingDialogPromptStream"))

;;Lists
(defun make-list-model (list)
  (new "snow.list.ConsListModel" list))

(defun make-list-widget (&key model prototype-cell-value selected-index
				      (cell-renderer (new "snow.list.ConsListCellRenderer"))
				 &allow-other-keys)
  (let ((list (new "javax.swing.JList")))
    (when model (setf (widget-property list :model) model))
    (setf (widget-property list :cell-renderer) cell-renderer)
    (setf (widget-property list :prototype-cell-value) prototype-cell-value)
    (when selected-index
      (setf (widget-property list :selected-index) selected-index))
    list))

(defwidget list-widget model selected-index)

;;Trees
(defun make-tree-model (list)
  (new "snow.tree.ConsTreeModel" list))

(defun make-tree (&key model (cell-renderer (new "snow.tree.ConsTreeCellRenderer"))
				 &allow-other-keys)
  (let ((tree (new "javax.swing.JTree")))
    (when model (setf (widget-property tree :model) model))
    (setf (widget-property tree :cell-renderer) cell-renderer)
    tree))

(defwidget tree model)

;;Misc
(defconstant +swingconstant-vertical+ (jfield "javax.swing.SwingConstants" "VERTICAL"))

(defun make-progress-bar (&key value orientation (paint-border t) progress-string &allow-other-keys)
  (let ((pbar (jnew "javax.swing.JProgressBar")))
    (when value
      (setf (widget-property pbar :value) value))
   (when orientation
     (setf (widget-property pbar :orientation) +swingconstant-vertical+))
   (when (not paint-border)
     (setf (widget-property pbar :border-painted) (jbool nil)))
   (when progress-string
     (setf (widget-property pbar :string-painted) (jbool t))
     (setf (widget-property pbar :string) progress-string))
   pbar))

(defwidget progress-bar value orientation (paint-border t) progress-string)