1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/clojure/contrib/swing_utils.clj	Sat Aug 21 06:25:44 2010 -0400
     1.3 @@ -0,0 +1,152 @@
     1.4 +;;  Copyright (c) Stephen C. Gilardi. All rights reserved.  The use and
     1.5 +;;  distribution terms for this software are covered by the Eclipse Public
     1.6 +;;  License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can
     1.7 +;;  be found in the file epl-v10.html at the root of this distribution.  By
     1.8 +;;  using this software in any fashion, you are agreeing to be bound by the
     1.9 +;;  terms of this license.  You must not remove this notice, or any other,
    1.10 +;;  from this software.
    1.11 +;;
    1.12 +;;  clojure.contrib.swing-utils
    1.13 +;;
    1.14 +;;  Useful functions for interfacing Clojure to Swing
    1.15 +;;
    1.16 +;;  scgilardi (gmail)
    1.17 +;;  Created 31 May 2009
    1.18 +
    1.19 +(ns clojure.contrib.swing-utils
    1.20 +  (:import (java.awt.event ActionListener KeyAdapter)
    1.21 +           (javax.swing AbstractAction Action 
    1.22 +                        JMenu JMenuBar JMenuItem
    1.23 +                        SwingUtilities))
    1.24 +  (:use [clojure.contrib.def :only (defvar)]))
    1.25 +
    1.26 +(defn add-action-listener
    1.27 +  "Adds an ActionLister to component. When the action fires, f will be
    1.28 +  invoked with the event as its first argument followed by args.
    1.29 +  Returns the listener."
    1.30 +  [component f & args]
    1.31 +  (let [listener (proxy [ActionListener] []
    1.32 +                   (actionPerformed [event] (apply f event args)))]
    1.33 +    (.addActionListener component listener)
    1.34 +    listener))
    1.35 +
    1.36 +(defn add-key-typed-listener
    1.37 +  "Adds a KeyListener to component that only responds to KeyTyped events.
    1.38 +  When a key is typed, f is invoked with the KeyEvent as its first argument
    1.39 +  followed by args. Returns the listener."
    1.40 +  [component f & args]
    1.41 +  (let [listener (proxy [KeyAdapter] []
    1.42 +                   (keyTyped [event] (apply f event args)))]
    1.43 +    (.addKeyListener component listener)
    1.44 +    listener))
    1.45 +
    1.46 +;; ----------------------------------------------------------------------
    1.47 +;; Meikel Brandmeyer
    1.48 +
    1.49 +(defn do-swing*
    1.50 +  "Runs thunk in the Swing event thread according to schedule:
    1.51 +    - :later => schedule the execution and return immediately
    1.52 +    - :now   => wait until the execution completes."
    1.53 +  [schedule thunk]
    1.54 +  (cond
    1.55 +   (= schedule :later) (SwingUtilities/invokeLater thunk)
    1.56 +   (= schedule :now) (if (SwingUtilities/isEventDispatchThread)
    1.57 +                       (thunk)
    1.58 +                       (SwingUtilities/invokeAndWait thunk)))
    1.59 +  nil)
    1.60 +
    1.61 +(defmacro do-swing
    1.62 +  "Executes body in the Swing event thread asynchronously. Returns
    1.63 +  immediately after scheduling the execution."
    1.64 +  [& body]
    1.65 +  `(do-swing* :later (fn [] ~@body)))
    1.66 +
    1.67 +(defmacro do-swing-and-wait
    1.68 +  "Executes body in the Swing event thread synchronously. Returns
    1.69 +  after the execution is complete."
    1.70 +  [& body]
    1.71 +  `(do-swing* :now (fn [] ~@body)))
    1.72 +
    1.73 +(defvar action-translation-table
    1.74 +  (atom {:name        Action/NAME
    1.75 +         :accelerator Action/ACCELERATOR_KEY
    1.76 +         :command-key Action/ACTION_COMMAND_KEY
    1.77 +         :long-desc   Action/LONG_DESCRIPTION
    1.78 +         :short-desc  Action/SHORT_DESCRIPTION
    1.79 +         :mnemonic    Action/MNEMONIC_KEY
    1.80 +         :icon        Action/SMALL_ICON})
    1.81 +  "Translation table for the make-action constructor.")
    1.82 +
    1.83 +(defn make-action
    1.84 +  "Create an Action proxy from the given action spec. The standard keys
    1.85 +  recognised are: :name, :accelerator, :command-key, :long-desc,
    1.86 +  :short-desc, :mnemonic and :icon - corresponding to the similar named
    1.87 +  Action properties.  The :handler value is used in the actionPerformed
    1.88 +  method of the proxy to pass on the event."
    1.89 +  [spec]
    1.90 +  (let [t-table @action-translation-table
    1.91 +        handler (:handler spec)
    1.92 +        spec    (dissoc spec :handler)
    1.93 +        spec    (map (fn [[k v]] [(t-table k) v]) spec)
    1.94 +        action  (proxy [AbstractAction] []
    1.95 +                  (actionPerformed [evt] (handler evt)))]
    1.96 +    (doseq [[k v] spec]
    1.97 +      (.putValue action k v))
    1.98 +    action))
    1.99 +
   1.100 +(defvar menu-constructor-dispatch
   1.101 +  (atom #{:action :handler :items})
   1.102 +  "An atom containing the dispatch set for the add-menu-item method.")
   1.103 +
   1.104 +(defmulti add-menu-item
   1.105 +  "Adds a menu item to the parent according to the item description.
   1.106 +   The item description is a map of the following structure.
   1.107 +
   1.108 + Either:
   1.109 +   - one single :action specifying a javax.swing.Action to be associated
   1.110 +     with the item.
   1.111 +   - a specification suitable for make-action
   1.112 +   - a set of :name, :mnemonic and :items keys, specifying a submenu with
   1.113 +     the given sequence of item entries.
   1.114 +   - an empty map specifying a separator."
   1.115 +  {:arglists '([parent item])}
   1.116 +  (fn add-menu-item-dispatch [_ item]
   1.117 +    (some @menu-constructor-dispatch (keys item))))
   1.118 +
   1.119 +(defmethod add-menu-item :action
   1.120 +  add-menu-item-action
   1.121 +  [parent {:keys [action]}]
   1.122 +  (let [item (JMenuItem. action)]
   1.123 +    (.add parent item)))
   1.124 +
   1.125 +(defmethod add-menu-item :handler
   1.126 +  add-menu-item-handler
   1.127 +  [parent spec]
   1.128 +  (add-menu-item parent {:action (make-action spec)}))
   1.129 +
   1.130 +(defmethod add-menu-item :items
   1.131 +  add-menu-item-submenu
   1.132 +  [parent {:keys [items mnemonic name]}]
   1.133 +  (let [menu (JMenu. name)]
   1.134 +    (when mnemonic
   1.135 +      (.setMnemonic menu mnemonic))
   1.136 +    (doseq [item items]
   1.137 +      (add-menu-item menu item))
   1.138 +    (.add parent menu)))
   1.139 +
   1.140 +(defmethod add-menu-item nil ; nil meaning separator
   1.141 +  add-menu-item-separator
   1.142 +  [parent _]
   1.143 +  (.addSeparator parent))
   1.144 +
   1.145 +(defn make-menubar
   1.146 +  "Create a menubar containing the given sequence of menu items. The menu
   1.147 +  items are described by a map as is detailed in the docstring of the
   1.148 +  add-menu-item function."
   1.149 +  [menubar-items]
   1.150 +  (let [menubar (JMenuBar.)]
   1.151 +    (doseq [item menubar-items]
   1.152 +      (add-menu-item menubar item))
   1.153 +    menubar))
   1.154 +
   1.155 +;; ----------------------------------------------------------------------