Mercurial > lasercutter
comparison src/clojure/contrib/swing_utils.clj @ 10:ef7dbbd6452c
added clojure source goodness
author | Robert McIntyre <rlm@mit.edu> |
---|---|
date | Sat, 21 Aug 2010 06:25:44 -0400 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
9:35cf337adfcf | 10:ef7dbbd6452c |
---|---|
1 ;; Copyright (c) Stephen C. Gilardi. All rights reserved. The use and | |
2 ;; distribution terms for this software are covered by the Eclipse Public | |
3 ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can | |
4 ;; be found in the file epl-v10.html at the root of this distribution. By | |
5 ;; using this software in any fashion, you are agreeing to be bound by the | |
6 ;; terms of this license. You must not remove this notice, or any other, | |
7 ;; from this software. | |
8 ;; | |
9 ;; clojure.contrib.swing-utils | |
10 ;; | |
11 ;; Useful functions for interfacing Clojure to Swing | |
12 ;; | |
13 ;; scgilardi (gmail) | |
14 ;; Created 31 May 2009 | |
15 | |
16 (ns clojure.contrib.swing-utils | |
17 (:import (java.awt.event ActionListener KeyAdapter) | |
18 (javax.swing AbstractAction Action | |
19 JMenu JMenuBar JMenuItem | |
20 SwingUtilities)) | |
21 (:use [clojure.contrib.def :only (defvar)])) | |
22 | |
23 (defn add-action-listener | |
24 "Adds an ActionLister to component. When the action fires, f will be | |
25 invoked with the event as its first argument followed by args. | |
26 Returns the listener." | |
27 [component f & args] | |
28 (let [listener (proxy [ActionListener] [] | |
29 (actionPerformed [event] (apply f event args)))] | |
30 (.addActionListener component listener) | |
31 listener)) | |
32 | |
33 (defn add-key-typed-listener | |
34 "Adds a KeyListener to component that only responds to KeyTyped events. | |
35 When a key is typed, f is invoked with the KeyEvent as its first argument | |
36 followed by args. Returns the listener." | |
37 [component f & args] | |
38 (let [listener (proxy [KeyAdapter] [] | |
39 (keyTyped [event] (apply f event args)))] | |
40 (.addKeyListener component listener) | |
41 listener)) | |
42 | |
43 ;; ---------------------------------------------------------------------- | |
44 ;; Meikel Brandmeyer | |
45 | |
46 (defn do-swing* | |
47 "Runs thunk in the Swing event thread according to schedule: | |
48 - :later => schedule the execution and return immediately | |
49 - :now => wait until the execution completes." | |
50 [schedule thunk] | |
51 (cond | |
52 (= schedule :later) (SwingUtilities/invokeLater thunk) | |
53 (= schedule :now) (if (SwingUtilities/isEventDispatchThread) | |
54 (thunk) | |
55 (SwingUtilities/invokeAndWait thunk))) | |
56 nil) | |
57 | |
58 (defmacro do-swing | |
59 "Executes body in the Swing event thread asynchronously. Returns | |
60 immediately after scheduling the execution." | |
61 [& body] | |
62 `(do-swing* :later (fn [] ~@body))) | |
63 | |
64 (defmacro do-swing-and-wait | |
65 "Executes body in the Swing event thread synchronously. Returns | |
66 after the execution is complete." | |
67 [& body] | |
68 `(do-swing* :now (fn [] ~@body))) | |
69 | |
70 (defvar action-translation-table | |
71 (atom {:name Action/NAME | |
72 :accelerator Action/ACCELERATOR_KEY | |
73 :command-key Action/ACTION_COMMAND_KEY | |
74 :long-desc Action/LONG_DESCRIPTION | |
75 :short-desc Action/SHORT_DESCRIPTION | |
76 :mnemonic Action/MNEMONIC_KEY | |
77 :icon Action/SMALL_ICON}) | |
78 "Translation table for the make-action constructor.") | |
79 | |
80 (defn make-action | |
81 "Create an Action proxy from the given action spec. The standard keys | |
82 recognised are: :name, :accelerator, :command-key, :long-desc, | |
83 :short-desc, :mnemonic and :icon - corresponding to the similar named | |
84 Action properties. The :handler value is used in the actionPerformed | |
85 method of the proxy to pass on the event." | |
86 [spec] | |
87 (let [t-table @action-translation-table | |
88 handler (:handler spec) | |
89 spec (dissoc spec :handler) | |
90 spec (map (fn [[k v]] [(t-table k) v]) spec) | |
91 action (proxy [AbstractAction] [] | |
92 (actionPerformed [evt] (handler evt)))] | |
93 (doseq [[k v] spec] | |
94 (.putValue action k v)) | |
95 action)) | |
96 | |
97 (defvar menu-constructor-dispatch | |
98 (atom #{:action :handler :items}) | |
99 "An atom containing the dispatch set for the add-menu-item method.") | |
100 | |
101 (defmulti add-menu-item | |
102 "Adds a menu item to the parent according to the item description. | |
103 The item description is a map of the following structure. | |
104 | |
105 Either: | |
106 - one single :action specifying a javax.swing.Action to be associated | |
107 with the item. | |
108 - a specification suitable for make-action | |
109 - a set of :name, :mnemonic and :items keys, specifying a submenu with | |
110 the given sequence of item entries. | |
111 - an empty map specifying a separator." | |
112 {:arglists '([parent item])} | |
113 (fn add-menu-item-dispatch [_ item] | |
114 (some @menu-constructor-dispatch (keys item)))) | |
115 | |
116 (defmethod add-menu-item :action | |
117 add-menu-item-action | |
118 [parent {:keys [action]}] | |
119 (let [item (JMenuItem. action)] | |
120 (.add parent item))) | |
121 | |
122 (defmethod add-menu-item :handler | |
123 add-menu-item-handler | |
124 [parent spec] | |
125 (add-menu-item parent {:action (make-action spec)})) | |
126 | |
127 (defmethod add-menu-item :items | |
128 add-menu-item-submenu | |
129 [parent {:keys [items mnemonic name]}] | |
130 (let [menu (JMenu. name)] | |
131 (when mnemonic | |
132 (.setMnemonic menu mnemonic)) | |
133 (doseq [item items] | |
134 (add-menu-item menu item)) | |
135 (.add parent menu))) | |
136 | |
137 (defmethod add-menu-item nil ; nil meaning separator | |
138 add-menu-item-separator | |
139 [parent _] | |
140 (.addSeparator parent)) | |
141 | |
142 (defn make-menubar | |
143 "Create a menubar containing the given sequence of menu items. The menu | |
144 items are described by a map as is detailed in the docstring of the | |
145 add-menu-item function." | |
146 [menubar-items] | |
147 (let [menubar (JMenuBar.)] | |
148 (doseq [item menubar-items] | |
149 (add-menu-item menubar item)) | |
150 menubar)) | |
151 | |
152 ;; ---------------------------------------------------------------------- |