ClojureでJWindowを作る

ふせんちっくなウィンドウを作ってみます。

無駄にクリック時の動作をかえられるようにしたりしてみました。

;;; MouseAdapter

(ns example.MouseAdapter
 (:gen-class
  :extends java.awt.event.MouseAdapter
  :init init
  :state actionTable
  :constructors {[clojure.lang.Atom][] [][]}
  :main false
;;  :expose-methods {mouseClicked mouseClicked}
  :methods
  [
   [clickAction [java.awt.event.MouseEvent] void]
   [doubleClickAction [java.awt.event.MouseEvent] void]
   [rightClickAction [java.awt.event.MouseEvent] void]
   ]))

(defmacro call-action [action-type]
  `(let [act# (get @(.actionTable ~'this) ~action-type)]
     (when act#
       (act# ~'evt))))


(defn -init ([action-table-atom] [[] action-table-atom])
  ([] (letfn ((dummy [evt] nil))
	[[] (atom {:click-action dummy :double-click-action dummy :right-click-action dummy :press-action dummy
		   :drag-action dummy})])))

(defn -clickAction [this evt] (call-action :click-action))

(defn -doubleClickAction [this evt] (call-action :double-click-action))

(defn -rightClickAction [this evt] (call-action :right-click-action))

(defn -mouseClicked [this evt]
  (cond
   (= java.awt.event.MouseEvent/BUTTON3 (.getButton evt)) (.rightClickAction this evt)
   (= java.awt.event.MouseEvent/BUTTON1 (.getButton evt))
   (if (>= (.getClickCount evt) 2)
     (.doubleClickAction this evt)
     (.clickAction this evt))))

(defn -mousePressed [this evt]
  (call-action :press-action))

(defn -mouseDragged [this evt]
  (call-action :drag-action))

(defn alter-action [adapter type action]
  (swap! (.actionTable adapter) assoc type action))

(defn set-action-table [adapter action-table]
  (set! (.actionTable adapter) action-table))

(defn get-action-table [adapter]
  @(.actionTable adapter))

(require 'example.MouseAdapter)

(defstruct item :name :object :listener)
(defstruct husen-window :window :label :adapter :popup :item-map :size)

(def *default-husen-size* (list 150 50))
(defn get-x [size] (first size))
(defn get-y [size] (second size))

(defmacro define-and-add-item [[popup item-map name text] [evt] & action-performer]
  `(let [obj# (javax.swing.JMenuItem. ~text)
	 listener# (proxy [java.awt.event.ActionListener][]
		     (actionPerformed [~'evt]
				      ~@action-performer))]
     (.addActionListener obj# listener#)
     (.add ~'popup obj#)
     (swap! ~'item-map assoc ~'name (struct item obj# listener#))))


(defn make-husen-window []
  (let [win (javax.swing.JWindow.)
	adapter (atom (example.MouseAdapter.))
	popup (javax.swing.JPopupMenu.)
	item-map (atom nil)
	lbl (javax.swing.JLabel. "")
	size (atom *default-husen-size*)
	point-map (atom {:location nil :press-point nil})]

    (.setSize lbl (get-x @size) (get-y @size))
    (.setVisible lbl true)
    (.add (.getContentPane win) lbl)

    (define-and-add-item [popup item-map :set-visible-item "setVisible(false)"]
      [evt]
      (.setVisible win false))
    (define-and-add-item [popup item-map :set-text-item "Set Text"]
      [evt]
      (let [txt (javax.swing.JOptionPane/showInputDialog (.getContentPane win) "Input Text:")]
	(when txt
	  (.setText lbl txt))))
    (define-and-add-item [popup item-map :set-icon-item "Set Icon"]
      [evt]
      (let [chooser (javax.swing.JFileChooser.)]
	(if (= javax.swing.JFileChooser/APPROVE_OPTION
	       (.showOpenDialog chooser (.getContentPane win)))
	  (let [icon (javax.swing.ImageIcon. (.. chooser getSelectedFile getAbsolutePath))]
	    (if icon
	      (.setIcon lbl icon)
	      (.setText lbl (.. chooser getSelectedFile getName)))))))
    (define-and-add-item [popup item-map :set-default-size "Set Default Size"]
      [evt]
      (.setSize win (get-x @size) (get-y @size))
      (.setSize lbl (get-x @size) (get-y @size)))
    (define-and-add-item [popup item-map :set-icon-size "Set Icon Size"]
      [evt]
      (let [icon (.getIcon lbl)
	    height
	    (if (isa? (.getClass icon) javax.swing.ImageIcon)
	      (.getHeight (.getImage icon))
	      (.getIconHeight icon))
	    width
	    (if (isa? (.getClass icon) javax.swing.ImageIcon)
	      (.getWidth (.getImage icon))
	      (.getIconWidth icon))]
	(.setSize win width height)
	(.setSize lbl width height)))
    (example.MouseAdapter/alter-action
     @adapter
     :right-click-action
     (fn [evt]
       (.show popup (.getComponent evt) (.getX evt) (.getY evt))))
    (example.MouseAdapter/alter-action
     @adapter
     :press-action
     (fn [evt]
       (swap! point-map assoc :press-point (.getPoint evt))))
    (example.MouseAdapter/alter-action
     @adapter
     :drag-action
     (fn [evt]
       (swap! point-map assoc :location (.getLocation win))
       (let [{p :press-point loc :location} @point-map
	     x (-
		(+ (.x loc)
		   (.getX evt))
		(.getX p))
	     y (- (+ (.y loc) (.getY evt)) (.getY p))]
	 (.setLocation win x y))))
    (doto win
      (.addMouseListener @adapter)
      (.addMouseMotionListener @adapter)
      (.setSize (get-x @size) (get-y @size))
      (.setVisible true))
    (struct husen-window win lbl adapter popup item-map size)))