[snow-cvs] r33 - in trunk: . lib src/java/org/armedbear/lisp src/java/snow/binding src/java/snow/list src/java/snow/swing src/java/snow/tree src/lisp/snow src/lisp/snow/showcase src/lisp/snow/swing
Alessio Stalla
astalla at common-lisp.net
Mon Nov 30 22:44:36 UTC 2009
Author: astalla
Date: Mon Nov 30 17:44:36 2009
New Revision: 33
Log:
Updated to latest abcl
Initial Mouse Listener support
Refactoring in snow.lisp: introduced &common-widget-args meta-argument,
moved actual widget definitions in another file (widgets.lisp), some more
macrology with dynamic environments
Added:
trunk/src/java/snow/swing/MouseInputListener.java
trunk/src/lisp/snow/widgets.lisp
Modified:
trunk/changelog
trunk/lib/abcl.jar
trunk/src/java/org/armedbear/lisp/Callback.java
trunk/src/java/snow/binding/AccessorBinding.java
trunk/src/java/snow/binding/BeanPropertyPathBinding.java
trunk/src/java/snow/binding/Converter.java
trunk/src/java/snow/list/ConsListCellRenderer.java
trunk/src/java/snow/list/ConsListModel.java
trunk/src/java/snow/swing/ConsoleDocument.java
trunk/src/java/snow/swing/WindowListener.java
trunk/src/java/snow/tree/ConsTreeCellRenderer.java
trunk/src/java/snow/tree/ConsTreeModel.java
trunk/src/lisp/snow/showcase/showcase.lisp
trunk/src/lisp/snow/snow.asd
trunk/src/lisp/snow/snow.lisp
trunk/src/lisp/snow/swing/swing.lisp
trunk/src/lisp/snow/utils.lisp
Modified: trunk/changelog
==============================================================================
--- trunk/changelog (original)
+++ trunk/changelog Mon Nov 30 17:44:36 2009
@@ -1,7 +1,16 @@
-2009-10-06
- Rationalized widget construction in macros define-widget and
- define-container-widget. Now code is more functional instead of
- procedural.
+Snow version 0.2 (2009-11-28)
+
+This is an alpha release, focused on stabilizing the core engine, providing
+user-friendly data binding, GUI REPL, debugger and inspector, and a showcase
+application.
+
+Features:
+- Basic framework: widget macros, data binding, possibility of multiple backends coexisting at runtime (e.g. Swing and SWT).
+- Supported widgets: most Swing widgets are very minimally supported.
+
+Bug fixes:
+- Several Windows-specific bugs were fixed.
+
-----------------------
old svn repo log below:
Modified: trunk/lib/abcl.jar
==============================================================================
Binary files. No diff available.
Modified: trunk/src/java/org/armedbear/lisp/Callback.java
==============================================================================
--- trunk/src/java/org/armedbear/lisp/Callback.java (original)
+++ trunk/src/java/org/armedbear/lisp/Callback.java Mon Nov 30 17:44:36 2009
@@ -33,6 +33,8 @@
package org.armedbear.lisp;
+import static org.armedbear.lisp.Lisp.error;
+
import java.util.concurrent.Callable;
public abstract class Callback extends Function {
@@ -42,41 +44,29 @@
}
@Override
- public LispObject execute() throws ConditionThrowable {
- try {
- return JavaObject.getInstance(call());
- } catch(Throwable e) {
- throw new ConditionThrowable(new JavaException(e));
- }
+ public LispObject execute() {
+ return JavaObject.getInstance(call());
}
- protected Object call() throws Throwable {
+ protected Object call() {
return error(new WrongNumberOfArgumentsException(this));
}
@Override
- public LispObject execute(LispObject arg0) throws ConditionThrowable {
- try {
- return JavaObject.getInstance(call(arg0.javaInstance()));
- } catch(Exception e) {
- throw new ConditionThrowable(new JavaException(e));
- }
+ public LispObject execute(LispObject arg0) {
+ return JavaObject.getInstance(call(arg0.javaInstance()));
}
- protected Object call(Object arg0) throws Exception, ConditionThrowable {
+ protected Object call(Object arg0) {
return error(new WrongNumberOfArgumentsException(this));
}
@Override
- public LispObject execute(LispObject arg0, LispObject arg1) throws ConditionThrowable {
- try {
- return JavaObject.getInstance(call(arg0.javaInstance(), arg1.javaInstance()));
- } catch(Exception e) {
- throw new ConditionThrowable(new JavaException(e));
- }
+ public LispObject execute(LispObject arg0, LispObject arg1) {
+ return JavaObject.getInstance(call(arg0.javaInstance(), arg1.javaInstance()));
}
- protected Object call(Object arg0, Object arg1) throws Exception, ConditionThrowable {
+ protected Object call(Object arg0, Object arg1) {
return error(new WrongNumberOfArgumentsException(this));
}
@@ -93,8 +83,12 @@
public static Callback fromCallable(final Callable<?> c) {
return new Callback() {
- protected Object call() throws Exception {
- return c.call();
+ protected Object call() {
+ try {
+ return c.call();
+ } catch(Exception e) {
+ return error(new JavaException(e));
+ }
}
};
}
Modified: trunk/src/java/snow/binding/AccessorBinding.java
==============================================================================
--- trunk/src/java/snow/binding/AccessorBinding.java (original)
+++ trunk/src/java/snow/binding/AccessorBinding.java Mon Nov 30 17:44:36 2009
@@ -32,7 +32,6 @@
package snow.binding;
-import org.armedbear.lisp.ConditionThrowable;
import org.armedbear.lisp.JavaObject;
import org.armedbear.lisp.LispObject;
@@ -55,35 +54,27 @@
}
- @Override
- public Object getValue() {
- try {
- return reader.execute(place).javaInstance();
- } catch (ConditionThrowable e) {
- throw new RuntimeException(e);
- }
- }
-
- @Override
- public void setValue(Object value) {
- try {
- writer.execute(JavaObject.getInstance(value, true), place);
- } catch (ConditionThrowable e) {
- throw new RuntimeException(e);
- }
- }
+ @Override
+ public Object getValue() {
+ return reader.execute(place).javaInstance();
+ }
+
+ @Override
+ public void setValue(Object value) {
+ writer.execute(JavaObject.getInstance(value, true), place);
+ }
/**
* Called from Lisp to notify a value change without invoking the writer.
*/
- public void valueChanged(Object value) {
- fireValueChange(oldValue, value, false);
- oldValue = value;
- }
-
- public LispObject getPlace() {
- return place;
- }
+ public void valueChanged(Object value) {
+ fireValueChange(oldValue, value, false);
+ oldValue = value;
+ }
+
+ public LispObject getPlace() {
+ return place;
+ }
public void setPlace(LispObject place) {
Modified: trunk/src/java/snow/binding/BeanPropertyPathBinding.java
==============================================================================
--- trunk/src/java/snow/binding/BeanPropertyPathBinding.java (original)
+++ trunk/src/java/snow/binding/BeanPropertyPathBinding.java Mon Nov 30 17:44:36 2009
@@ -32,7 +32,6 @@
package snow.binding;
-import org.armedbear.lisp.ConditionThrowable;
import org.armedbear.lisp.JavaObject;
import org.armedbear.lisp.LispObject;
import java.beans.*;
Modified: trunk/src/java/snow/binding/Converter.java
==============================================================================
--- trunk/src/java/snow/binding/Converter.java (original)
+++ trunk/src/java/snow/binding/Converter.java Mon Nov 30 17:44:36 2009
@@ -32,7 +32,6 @@
package snow.binding;
-import org.armedbear.lisp.ConditionThrowable;
import org.armedbear.lisp.JavaObject;
import org.armedbear.lisp.LispObject;
@@ -53,30 +52,22 @@
}
- @Override
- public Object getValue() {
- Object value = valueModel.getValue();
- try {
- return converterTo.execute(JavaObject.getInstance(value, true)).javaInstance();
- } catch (ConditionThrowable e) {
- throw new RuntimeException(e);
- }
- }
-
- @Override
- public void setValue(Object obj) {
- try {
- Object value = converterFrom.execute(JavaObject.getInstance(obj, true)).javaInstance();
- valueModel.setValue(value);
- } catch (ConditionThrowable e) {
- throw new RuntimeException(e);
- }
- }
-
- public ValueModel getValueModel() {
- return valueModel;
- }
-
+ @Override
+ public Object getValue() {
+ Object value = valueModel.getValue();
+ return converterTo.execute(JavaObject.getInstance(value, true)).javaInstance();
+ }
+
+ @Override
+ public void setValue(Object obj) {
+ Object value = converterFrom.execute(JavaObject.getInstance(obj, true)).javaInstance();
+ valueModel.setValue(value);
+ }
+
+ public ValueModel getValueModel() {
+ return valueModel;
+ }
+
public void setValueModel(ValueModel valueModel) {
this.valueModel = valueModel;
Modified: trunk/src/java/snow/list/ConsListCellRenderer.java
==============================================================================
--- trunk/src/java/snow/list/ConsListCellRenderer.java (original)
+++ trunk/src/java/snow/list/ConsListCellRenderer.java Mon Nov 30 17:44:36 2009
@@ -54,14 +54,10 @@
int index, boolean selected,
boolean cellHasFocus) {
Object retVal;
- try {
- retVal = function != null && value instanceof LispObject ? function.execute((LispObject) value) : value;
- if(retVal instanceof LispObject) {
- retVal = ((LispObject) retVal).writeToString();
- }
- } catch (ConditionThrowable e) {
- throw new RuntimeException(e);
- }
+ retVal = function != null && value instanceof LispObject ? function.execute((LispObject) value) : value;
+ if(retVal instanceof LispObject) {
+ retVal = ((LispObject) retVal).writeToString();
+ }
return super.getListCellRendererComponent(list, retVal, index, selected, cellHasFocus);
}
Modified: trunk/src/java/snow/list/ConsListModel.java
==============================================================================
--- trunk/src/java/snow/list/ConsListModel.java (original)
+++ trunk/src/java/snow/list/ConsListModel.java Mon Nov 30 17:44:36 2009
@@ -34,7 +34,6 @@
import javax.swing.AbstractListModel;
-import org.armedbear.lisp.ConditionThrowable;
import org.armedbear.lisp.Cons;
import org.armedbear.lisp.Fixnum;
import org.armedbear.lisp.Lisp;
@@ -53,23 +52,15 @@
}
}
- @Override
- public Object getElementAt(int index) {
- try {
- LispObject o = Symbol.NTH.execute(Fixnum.getInstance(index), cons);
- return o.javaInstance();
- } catch (ConditionThrowable e) {
- throw new RuntimeException(e);
- }
- }
-
- @Override
- public int getSize() {
- try {
- return Symbol.LENGTH.execute(cons).intValue();
- } catch(ConditionThrowable e) {
- throw new RuntimeException(e);
- }
- }
+ @Override
+ public Object getElementAt(int index) {
+ LispObject o = Symbol.NTH.execute(Fixnum.getInstance(index), cons);
+ return o.javaInstance();
+ }
+
+ @Override
+ public int getSize() {
+ return Symbol.LENGTH.execute(cons).intValue();
+ }
}
Modified: trunk/src/java/snow/swing/ConsoleDocument.java
==============================================================================
--- trunk/src/java/snow/swing/ConsoleDocument.java (original)
+++ trunk/src/java/snow/swing/ConsoleDocument.java Mon Nov 30 17:44:36 2009
@@ -51,17 +51,17 @@
import javax.swing.text.DefaultStyledDocument;
import javax.swing.text.JTextComponent;
-import org.armedbear.lisp.ConditionThrowable;
import org.armedbear.lisp.Function;
import org.armedbear.lisp.Interpreter;
import org.armedbear.lisp.LispObject;
import org.armedbear.lisp.LispThread;
-import org.armedbear.lisp.Package;
-import org.armedbear.lisp.SpecialBinding;
+import org.armedbear.lisp.SpecialBindingsMark;
import org.armedbear.lisp.Stream;
import org.armedbear.lisp.Symbol;
import org.armedbear.lisp.TwoWayStream;
+import static org.armedbear.lisp.Lisp.*;
+
public class ConsoleDocument extends DefaultStyledDocument {
private int lastEditableOffset = 0;
@@ -122,24 +122,20 @@
private boolean disposed = false;
private final Thread replThread;
- public ConsoleDocument(LispObject replFunction) {
- final LispObject replWrapper = makeReplWrapper(new StreamEx(new BufferedReader(reader)),
- new StreamEx(new BufferedWriter(writer)),
- replFunction);
- replThread = new Thread("REPL-thread-" + System.identityHashCode(this)) {
- public void run() {
- try {
- while(true) {
- replWrapper.execute();
- yield();
- }
- } catch (ConditionThrowable e) {
- throw new RuntimeException(e);
- }
- }
- };
- replThread.start();
- }
+ public ConsoleDocument(LispObject replFunction) {
+ final LispObject replWrapper = makeReplWrapper(new StreamEx(new BufferedReader(reader)),
+ new StreamEx(new BufferedWriter(writer)),
+ replFunction);
+ replThread = new Thread("REPL-thread-" + System.identityHashCode(this)) {
+ public void run() {
+ while(true) {
+ replWrapper.execute();
+ yield();
+ }
+ }
+ };
+ replThread.start();
+ }
@Override
public void insertString(int offs, String str, AttributeSet a)
@@ -253,69 +249,67 @@
replThread.interrupt(); //really?
}
- private final LispObject debuggerHook = new Function() {
-
- @Override
- public LispObject execute(LispObject condition, LispObject debuggerHook)
- throws ConditionThrowable {
- if(disposed) {
- return Package.PACKAGE_SYS.findSymbol("%DEBUGGER-HOOK-FUNCTION").execute(condition, debuggerHook);
- } else {
- return NIL;
- }
+ private final LispObject debuggerHook = new Function() {
+
+ @Override
+ public LispObject execute(LispObject condition, LispObject debuggerHook) {
+ if(disposed) {
+ return PACKAGE_SYS.findSymbol("%DEBUGGER-HOOK-FUNCTION").execute(condition, debuggerHook);
+ } else {
+ return NIL;
}
-
+ }
+
};
- public LispObject makeReplWrapper(final Stream in, final Stream out, final LispObject fn) {
- return new Function() {
- @Override
- public LispObject execute()
- throws ConditionThrowable {
- SpecialBinding lastSpecialBinding = LispThread.currentThread().lastSpecialBinding;
- try {
- TwoWayStream ioStream = new TwoWayStream(in, out);
- LispThread.currentThread().bindSpecial(Symbol.DEBUGGER_HOOK, debuggerHook);
- LispThread.currentThread().bindSpecial(Symbol.STANDARD_INPUT, in);
- LispThread.currentThread().bindSpecial(Symbol.STANDARD_OUTPUT, out);
- LispThread.currentThread().bindSpecial(Symbol.TERMINAL_IO, ioStream);
- LispThread.currentThread().bindSpecial(Symbol.DEBUG_IO, ioStream);
- LispThread.currentThread().bindSpecial(Symbol.QUERY_IO, ioStream);
- return fn.execute();
- } finally {
- LispThread.currentThread().lastSpecialBinding = lastSpecialBinding;
- }
- }
-
- };
- }
+ public LispObject makeReplWrapper(final Stream in, final Stream out, final LispObject fn) {
+ return new Function() {
+ @Override
+ public LispObject execute() {
+ SpecialBindingsMark lastSpecialBinding = LispThread.currentThread().markSpecialBindings();
+ try {
+ TwoWayStream ioStream = new TwoWayStream(in, out);
+ LispThread.currentThread().bindSpecial(Symbol.DEBUGGER_HOOK, debuggerHook);
+ LispThread.currentThread().bindSpecial(Symbol.STANDARD_INPUT, in);
+ LispThread.currentThread().bindSpecial(Symbol.STANDARD_OUTPUT, out);
+ LispThread.currentThread().bindSpecial(Symbol.TERMINAL_IO, ioStream);
+ LispThread.currentThread().bindSpecial(Symbol.DEBUG_IO, ioStream);
+ LispThread.currentThread().bindSpecial(Symbol.QUERY_IO, ioStream);
+ return fn.execute();
+ } finally {
+ LispThread.currentThread().resetSpecialBindings(lastSpecialBinding);
+ }
+ }
+
+ };
+ }
- public void disposeOnClose(Window parent) {
- parent.addWindowListener(new WindowAdapter() {
- @Override
- public void windowClosing(WindowEvent e) {
- dispose();
- }
- });
- }
+ public void disposeOnClose(Window parent) {
+ parent.addWindowListener(new WindowAdapter() {
+ @Override
+ public void windowClosing(WindowEvent e) {
+ dispose();
+ }
+ });
+ }
- public static void main(String[] args) {
- LispObject repl = null;
- try {
- repl = Interpreter.createInstance().eval("#'top-level::top-level-loop");
- } catch (Throwable e) {
- e.printStackTrace();
- System.exit(1);
- }
- final ConsoleDocument d = new ConsoleDocument(repl);
- final JTextComponent txt = new JTextArea(d);
- d.setupTextComponent(txt);
- JFrame f = new JFrame();
- f.add(new JScrollPane(txt));
- d.disposeOnClose(f);
- f.setDefaultCloseOperation(f.EXIT_ON_CLOSE);
- f.pack();
- f.setVisible(true);
- }
+ public static void main(String[] args) {
+ LispObject repl = null;
+ try {
+ repl = Interpreter.createInstance().eval("#'top-level::top-level-loop");
+ } catch (Throwable e) {
+ e.printStackTrace();
+ System.exit(1);
+ }
+ final ConsoleDocument d = new ConsoleDocument(repl);
+ final JTextComponent txt = new JTextArea(d);
+ d.setupTextComponent(txt);
+ JFrame f = new JFrame();
+ f.add(new JScrollPane(txt));
+ d.disposeOnClose(f);
+ f.setDefaultCloseOperation(f.EXIT_ON_CLOSE);
+ f.pack();
+ f.setVisible(true);
+ }
}
Added: trunk/src/java/snow/swing/MouseInputListener.java
==============================================================================
--- (empty file)
+++ trunk/src/java/snow/swing/MouseInputListener.java Mon Nov 30 17:44:36 2009
@@ -0,0 +1,92 @@
+/*
+ * WindowListener.java
+ *
+ * Copyright (C) 2008-2009 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, 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.
+ */
+
+package snow.swing;
+
+import java.awt.event.MouseEvent;
+
+import org.armedbear.lisp.JavaObject;
+import org.armedbear.lisp.LispObject;
+
+public class MouseInputListener implements javax.swing.event.MouseInputListener {
+
+ private LispObject mouseClicked, mouseEntered, mouseExited, mousePressed, mouseReleased;
+ private LispObject mouseDragged, mouseMoved;
+
+ public MouseInputListener(LispObject mouseClicked, LispObject mousePressed, LispObject mouseReleased, LispObject mouseEntered, LispObject mouseExited, LispObject mouseDragged, LispObject mouseMoved) {
+ super();
+ this.mouseClicked = mouseClicked;
+ this.mousePressed = mousePressed;
+ this.mouseReleased = mouseReleased;
+
+ this.mouseEntered = mouseEntered;
+ this.mouseExited = mouseExited;
+
+ this.mouseDragged = mouseDragged;
+ this.mouseMoved = mouseMoved;
+ }
+
+ private static final void invokeDelegate(LispObject delegate, MouseEvent e) {
+ if(delegate != null) {
+ delegate.execute(new JavaObject(e));
+ }
+ }
+
+ public void mouseClicked(MouseEvent e) {
+ invokeDelegate(mouseClicked, e);
+ }
+
+ public void mouseEntered(MouseEvent e) {
+ invokeDelegate(mouseEntered, e);
+ }
+
+ public void mouseExited(MouseEvent e) {
+ invokeDelegate(mouseExited, e);
+ }
+
+ public void mousePressed(MouseEvent e) {
+ invokeDelegate(mousePressed, e);
+ }
+
+ public void mouseReleased(MouseEvent e) {
+ invokeDelegate(mouseReleased, e);
+ }
+
+ public void mouseDragged(MouseEvent e) {
+ invokeDelegate(mouseDragged, e);
+ }
+
+ public void mouseMoved(MouseEvent e) {
+ invokeDelegate(mouseMoved, e);
+ }
+
+}
Modified: trunk/src/java/snow/swing/WindowListener.java
==============================================================================
--- trunk/src/java/snow/swing/WindowListener.java (original)
+++ trunk/src/java/snow/swing/WindowListener.java Mon Nov 30 17:44:36 2009
@@ -34,77 +34,72 @@
import java.awt.event.WindowEvent;
-import org.armedbear.lisp.ConditionThrowable;
import org.armedbear.lisp.JavaObject;
import org.armedbear.lisp.LispObject;
public class WindowListener implements java.awt.event.WindowListener {
- private LispObject windowActivated;
- private LispObject windowClosed;
- private LispObject windowClosing;
- private LispObject windowDeactivated;
- private LispObject windowDeiconified;
- private LispObject windowIconified;
- private LispObject windowOpened;
+ private LispObject windowActivated;
+ private LispObject windowClosed;
+ private LispObject windowClosing;
+ private LispObject windowDeactivated;
+ private LispObject windowDeiconified;
+ private LispObject windowIconified;
+ private LispObject windowOpened;
- public WindowListener(LispObject windowActivated, LispObject windowClosed,
- LispObject windowClosing, LispObject windowDeactivated,
- LispObject windowDeiconified, LispObject windowIconified,
- LispObject windowOpened) {
- super();
- this.windowActivated = windowActivated;
- this.windowClosed = windowClosed;
- this.windowClosing = windowClosing;
- this.windowDeactivated = windowDeactivated;
- this.windowDeiconified = windowDeiconified;
- this.windowIconified = windowIconified;
- this.windowOpened = windowOpened;
- }
+ public WindowListener(LispObject windowActivated, LispObject windowClosed,
+ LispObject windowClosing, LispObject windowDeactivated,
+ LispObject windowDeiconified, LispObject windowIconified,
+ LispObject windowOpened) {
+ super();
+ this.windowActivated = windowActivated;
+ this.windowClosed = windowClosed;
+ this.windowClosing = windowClosing;
+ this.windowDeactivated = windowDeactivated;
+ this.windowDeiconified = windowDeiconified;
+ this.windowIconified = windowIconified;
+ this.windowOpened = windowOpened;
+ }
- private static final void invokeDelegate(LispObject delegate, WindowEvent e) {
- if(delegate != null) {
- try {
- delegate.execute(new JavaObject(e));
- } catch (ConditionThrowable e1) {
- throw new RuntimeException(e1);
- }
- }
+ private static final void invokeDelegate(LispObject delegate, WindowEvent e) {
+ if(delegate != null) {
+ delegate.execute(new JavaObject(e));
}
+ }
- @Override
- public void windowActivated(WindowEvent e) {
- invokeDelegate(windowActivated, e);
- }
-
- @Override
- public void windowClosed(WindowEvent e) {
- invokeDelegate(windowClosed, e);
- }
-
- @Override
- public void windowClosing(WindowEvent e) {
- invokeDelegate(windowClosing, e);
- }
-
- @Override
- public void windowDeactivated(WindowEvent e) {
- invokeDelegate(windowDeactivated, e);
- }
-
- @Override
- public void windowDeiconified(WindowEvent e) {
- invokeDelegate(windowDeiconified, e);
- }
-
- @Override
- public void windowIconified(WindowEvent e) {
- invokeDelegate(windowIconified, e);
- }
-
- @Override
- public void windowOpened(WindowEvent e) {
- invokeDelegate(windowOpened, e);
- }
+ @Override
+ public void windowActivated(WindowEvent e) {
+ invokeDelegate(windowActivated, e);
+ }
+
+ @Override
+ public void windowClosed(WindowEvent e) {
+ invokeDelegate(windowClosed, e);
+ }
+
+ @Override
+ public void windowClosing(WindowEvent e) {
+ invokeDelegate(windowClosing, e);
+ }
+
+ @Override
+ public void windowDeactivated(WindowEvent e) {
+ invokeDelegate(windowDeactivated, e);
+ }
+
+ @Override
+ public void windowDeiconified(WindowEvent e) {
+ invokeDelegate(windowDeiconified, e);
+ }
+
+ @Override
+ public void windowIconified(WindowEvent e) {
+ invokeDelegate(windowIconified, e);
+ }
+
+ @Override
+ public void windowOpened(WindowEvent e) {
+ invokeDelegate(windowOpened, e);
+ }
}
Modified: trunk/src/java/snow/tree/ConsTreeCellRenderer.java
==============================================================================
--- trunk/src/java/snow/tree/ConsTreeCellRenderer.java (original)
+++ trunk/src/java/snow/tree/ConsTreeCellRenderer.java Mon Nov 30 17:44:36 2009
@@ -37,34 +37,29 @@
import javax.swing.JTree;
import javax.swing.tree.DefaultTreeCellRenderer;
-import org.armedbear.lisp.ConditionThrowable;
import org.armedbear.lisp.Cons;
import org.armedbear.lisp.LispObject;
public class ConsTreeCellRenderer extends DefaultTreeCellRenderer {
- @Override
- public Component getTreeCellRendererComponent(JTree tree, Object value,
- boolean sel, boolean expanded, boolean leaf, int row,
- boolean hasFocus) {
- if(value instanceof LispObject) {
- LispObject obj = (LispObject) value;
- try {
- if(obj instanceof Cons) {
- return super.getTreeCellRendererComponent(tree, ((Cons) obj).car.writeToString(), sel, expanded, leaf,
- row, hasFocus);
- } else {
- return super.getTreeCellRendererComponent(tree, obj.writeToString(), sel, expanded, leaf,
- row, hasFocus);
- }
- } catch(ConditionThrowable t) {
- //Should never happen
- throw new RuntimeException(t);
- }
- } else {
- return super.getTreeCellRendererComponent(tree, value, sel, expanded, leaf,
- row, hasFocus);
- }
+ @Override
+ public Component getTreeCellRendererComponent(JTree tree, Object value,
+ boolean sel, boolean expanded,
+ boolean leaf, int row,
+ boolean hasFocus) {
+ if(value instanceof LispObject) {
+ LispObject obj = (LispObject) value;
+ if(obj instanceof Cons) {
+ return super.getTreeCellRendererComponent(tree, ((Cons) obj).car.writeToString(), sel, expanded, leaf,
+ row, hasFocus);
+ } else {
+ return super.getTreeCellRendererComponent(tree, obj.writeToString(), sel, expanded, leaf,
+ row, hasFocus);
+ }
+
+ } else {
+ return super.getTreeCellRendererComponent(tree, value, sel, expanded, leaf,
+ row, hasFocus);
}
-
+ }
}
Modified: trunk/src/java/snow/tree/ConsTreeModel.java
==============================================================================
--- trunk/src/java/snow/tree/ConsTreeModel.java (original)
+++ trunk/src/java/snow/tree/ConsTreeModel.java Mon Nov 30 17:44:36 2009
@@ -39,7 +39,6 @@
import javax.swing.tree.TreeModel;
import javax.swing.tree.TreePath;
-import org.armedbear.lisp.ConditionThrowable;
import org.armedbear.lisp.Cons;
import org.armedbear.lisp.Fixnum;
import org.armedbear.lisp.Lisp;
@@ -56,81 +55,66 @@
this.cons = cons;
}
- @Override
- public Object getChild(Object parent, int index) {
- if(parent instanceof Cons) {
- try {
- return Symbol.NTH.execute(Fixnum.getInstance(index + 1), (Cons) parent);
- } catch (ConditionThrowable e) {
- return null;
- }
- } else {
- return null;
- }
- }
-
- @Override
- public int getChildCount(Object parent) {
- if(parent instanceof Cons) {
- try {
- return ((Fixnum) Symbol.LENGTH.execute((Cons) parent)).value - 1;
- } catch (ConditionThrowable e) {
- return 0;
- }
- } else {
- return 0;
- }
- }
-
- @Override
- public int getIndexOfChild(Object parent, Object child) {
- if(parent == null || child == null) {
- return -1;
- }
- try {
- if(Symbol.MEMBER.execute((LispObject) parent, cons) != Lisp.NIL) {
- Object pos = Symbol.POSITION.execute((LispObject) child, (LispObject) parent);
- if(pos instanceof Fixnum) {
- return ((Fixnum) pos).value - 1;
- } else {
- return -1;
- }
- } else {
- return -1;
- }
- } catch (ConditionThrowable e) {
- return -1;
- }
- }
-
- @Override
- public Object getRoot() {
- return cons;
- }
-
- @Override
- public boolean isLeaf(Object node) {
- try {
- return Symbol.ATOM.execute((LispObject) node) != Lisp.NIL;
- } catch (ConditionThrowable e) {
- return true;
- }
- }
-
- @Override
- public void addTreeModelListener(TreeModelListener l) {
- listeners.add(l);
- }
+ @Override
+ public Object getChild(Object parent, int index) {
+ if(parent instanceof Cons) {
+ return Symbol.NTH.execute(Fixnum.getInstance(index + 1), (Cons) parent);
+
+ } else {
+ return null;
+ }
+ }
+
+ @Override
+ public int getChildCount(Object parent) {
+ if(parent instanceof Cons) {
+ return ((Fixnum) Symbol.LENGTH.execute((Cons) parent)).value - 1;
+ } else {
+ return 0;
+ }
+ }
+
+ @Override
+ public int getIndexOfChild(Object parent, Object child) {
+ if(parent == null || child == null) {
+ return -1;
+ }
+ if(Symbol.MEMBER.execute((LispObject) parent, cons) != Lisp.NIL) {
+ Object pos = Symbol.POSITION.execute((LispObject) child, (LispObject) parent);
+ if(pos instanceof Fixnum) {
+ return ((Fixnum) pos).value - 1;
+ } else {
+ return -1;
+ }
+ } else {
+ return -1;
+ }
+ }
+
+ @Override
+ public Object getRoot() {
+ return cons;
+ }
+
+ @Override
+ public boolean isLeaf(Object node) {
+ return Symbol.ATOM.execute((LispObject) node) != Lisp.NIL;
+ }
+
+ @Override
+ public void addTreeModelListener(TreeModelListener l) {
+ listeners.add(l);
+ }
+
+ @Override
+ public void removeTreeModelListener(TreeModelListener l) {
+ listeners.remove(l);
+ }
+
+ @Override
+ public void valueForPathChanged(TreePath path, Object newValue) {
+ // TODO Auto-generated method stub
- @Override
- public void removeTreeModelListener(TreeModelListener l) {
- listeners.remove(l);
- }
-
- @Override
- public void valueForPathChanged(TreePath path, Object newValue) {
- // TODO Auto-generated method stub
-
- }
+ }
}
Modified: trunk/src/lisp/snow/showcase/showcase.lisp
==============================================================================
--- trunk/src/lisp/snow/showcase/showcase.lisp (original)
+++ trunk/src/lisp/snow/showcase/showcase.lisp Mon Nov 30 17:44:36 2009
@@ -1,6 +1,3 @@
-#-snow-cells
-(error "This showcase needs Snow built with Cells support")
-
(defpackage :snow-showcase
(:use :common-lisp :snow :java :ext :named-readtables :cells)
(:shadowing-import-from :snow #:make-dialog-prompt-stream #:*gui-backend*))
@@ -54,6 +51,46 @@
(defvar *variable* (make-var "42"))
(defvar *cells-object* (make-instance 'my-model))
+(define-example "Data Binding"
+ (panel ()
+ (label :text "bean binding")
+ (label :binding ${*bean*.property1}
+ :layout "wrap")
+ (label :text "EL binding")
+ (label :binding ${*bean*.nested.property1}
+ :layout "wrap")
+ (label :text "cells bindings: aaa and bbb")
+ (label :binding $(c? (aaa *cells-object*)))
+ (label :binding $(cell (c? (bbb *cells-object*)))
+ :layout "wrap")
+ (label :text "simple binding to a variable")
+ (label :binding $*variable*
+ :layout "wrap")
+ (button :text "another one" :layout "wrap")
+ (label :text "set property1")
+ (text-field :binding ${*bean*.property1}
+ :layout "growx, wrap")
+ (label :text "set nested.property1")
+ (text-field :binding ${*bean*.nested.property1}
+ :layout "growx, wrap")
+ (button :text "Test!"
+ :layout "wrap"
+ :on-action (lambda (event)
+ (declare (ignore event))
+ (setf (jproperty-value *bean* "property1")
+ "Test property")
+ (setf (jproperty-value
+ (jproperty-value *bean* "nested")
+ "property1")
+ "Nested property")
+ (setf (var *variable*) "Test var")
+ (setf (aaa *cells-object*) "Test cell")))))
+
+(define-example "Mouse Events"
+ (panel (:layout "grow"
+ :on-mouse-click (lambda (evt) (format t "Click! ~A~%" evt)))
+ (label :text "Click here!")))
+
(define-example "Lists and trees"
(scroll (:layout "grow")
(list-widget :model (make-list-model '(1 2 (c (a b)) 3))
@@ -75,48 +112,12 @@
(princ "Thanks for pushing me! ")
(finish-output))))
-(define-example "Data Binding"
- (scroll ()
- (panel ()
- (label :text "bean binding")
- (label :binding ${*bean*.property1}
- :layout "wrap")
- (label :text "EL binding")
- (label :binding ${*bean*.nested.property1}
- :layout "wrap")
- (label :text "cells bindings: aaa and bbb")
- (label :binding $(c? (aaa *cells-object*)))
- (label :binding $(cell (c? (bbb *cells-object*)))
- :layout "wrap")
- (label :text "simple binding to a variable")
- (label :binding $*variable*
- :layout "wrap")
- (button :text "another one" :layout "wrap")
- (label :text "set property1")
- (text-field :binding ${*bean*.property1}
- :layout "growx, wrap")
- (label :text "set nested.property1")
- (text-field :binding ${*bean*.nested.property1}
- :layout "growx, wrap")
- (button :text "Test!"
- :layout "wrap"
- :on-action (lambda (event)
- (declare (ignore event))
- (setf (jproperty-value *bean* "property1")
- "Test property")
- (setf (jproperty-value
- (jproperty-value *bean* "nested")
- "property1")
- "Nested property")
- (setf (var *variable*) "Test var")
- (setf (aaa *cells-object*) "Test cell"))))))
-
(defun showcase ()
(with-gui (:swing)
(frame (:id frame :title "Sample JFrame" :visible-p t :size #C(800 600)
:layout-manager '(:mig "fill"))
(tabs (:layout "grow")
- (dolist (x *examples*)
+ (dolist (x (reverse *examples*))
(tab (car x) (funcall (cadr x))))))))
#||
Modified: trunk/src/lisp/snow/snow.asd
==============================================================================
--- trunk/src/lisp/snow/snow.asd (original)
+++ trunk/src/lisp/snow/snow.asd Mon Nov 30 17:44:36 2009
@@ -38,6 +38,7 @@
(:file "utils")
(:file "cx-dynamic-environments")
(:file "snow")
+ (:file "widgets")
(:file "repl")
(:file "data-binding")
#+snow-cells
Modified: trunk/src/lisp/snow/snow.lisp
==============================================================================
--- trunk/src/lisp/snow/snow.lisp (original)
+++ trunk/src/lisp/snow/snow.lisp Mon Nov 30 17:44:36 2009
@@ -30,9 +30,71 @@
(in-package :snow)
+;;Common Interfaces
+(defvar *gui-backend* :swing "Variable used to determine the GUI backend, and thus interface implementation, to use. Defaults to :swing.")
+
+(definterface add-child *gui-backend* (child &optional (parent *parent*) layout-constraints))
+
+(definterface widget-enabled-p *gui-backend* (widget))
+
+(definterface (setf widget-enabled-p) *gui-backend* (value widget))
+
+(definterface widget-visible-p *gui-backend* (widget))
+
+(definterface (setf widget-visible-p) *gui-backend* (value widget))
+
+(definterface (setf widget-location) *gui-backend* (value widget))
+
+(definterface (setf widget-size) *gui-backend* (value widget))
+
+(definterface dispose *gui-backend* (obj))
+
+(definterface show *gui-backend* (obj))
+
+(definterface hide *gui-backend* (obj))
+
+(definterface pack *gui-backend* (window))
+
(defvar *parent* nil)
+(definterface call-in-gui-thread *gui-backend* (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).")
+
+(defvar *dynamic-environment* nil)
+
+(defmacro with-snow-dynamic-environment (&body body)
+ (with-unique-names (gui-backend-var package-var terminal-io-var)
+ `(if *dynamic-environment*
+ (with-dynamic-environment (*dynamic-environment*)
+ , at body)
+ (let* ((,gui-backend-var *gui-backend*)
+ (,package-var *package*)
+ (,terminal-io-var *terminal-io*)) ;;Etc...
+ (dynamic-wind
+ (let ((*gui-backend* ,gui-backend-var)
+ (*package* ,package-var)
+ (*debugger-hook* *graphical-debugger-hook*)
+ (*terminal-io* ,terminal-io-var))
+ (proceed
+ (let ((*dynamic-environment* (capture-dynamic-environment)))
+ (with-dynamic-environment (*dynamic-environment*)
+ , at body)))))))))
+
+(defmacro lambda/dynamic-environment (args &body body)
+ (with-unique-names (dynamic-environment)
+ `(with-snow-dynamic-environment
+ (let ((,dynamic-environment *dynamic-environment*))
+ (lambda ,args (with-dynamic-environment (,dynamic-environment)
+ (let ((*dynamic-environment* ,dynamic-environment))
+ , at body)))))))
+
+(defmacro with-gui ((&optional (gui-backend '*gui-backend*)) &body body)
+ (declare (ignore gui-backend))
+ `(call-in-gui-thread
+ (lambda/dynamic-environment () , at body)))
+
(defun dashed->camelcased (string-designator)
+ "Transforms a name (string designator) from the Lisp naming convention of separating multiple words with dashes to the Java camelCase convention."
(let ((str (string string-designator))
(last-was-dash-p nil))
(with-output-to-string (out)
@@ -76,6 +138,7 @@
(nreverse result)))))
(defmacro set-widget-properties (widget &rest props)
+ "Convenience macro to set a number of widget properties in bulk."
(with-unique-names (widget-var)
`(let ((,widget-var ,widget))
,@(map-keys (lambda (key value)
@@ -85,16 +148,20 @@
(defgeneric bind-widget (widget binding)
(:documentation "Connects a widget to a data binding. The framework automatically chooses which property of the widget to connect."))
-(definterface make-layout-manager *gui-backend* (widget type &rest args))
+(definterface make-layout-manager *gui-backend* (widget type &rest args)
+ "Creates a backed-specific object used to layout components.")
-(definterface (setf layout-manager) *gui-backend* (lm widget))
+(definterface (setf layout-manager) *gui-backend* (lm widget)
+ "Sets the layout manager for a given (container) widget.")
(defun setup-container-widget (self &key (layout-manager :default) &allow-other-keys)
+ "Common setup for all container widgets."
(setf (layout-manager self)
(apply #'make-layout-manager self
(ensure-list (or layout-manager :default)))))
(defun generate-default-children-processing-code (id children)
+ "Can be used inside a macro defining a container widget to generate the code to process its body, adding children to it."
(let ((code
(loop
:for form :in children
@@ -111,36 +178,60 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun common-widget-args ()
- '(layout binding (enabled-p t) (visible-p t) location size))
+ '(layout binding (enabled-p t) (visible-p t) location size
+ on-mouse-click on-mouse-press on-mouse-release
+ on-mouse-enter on-mouse-exit
+ on-mouse-drag on-mouse-move))
+ (defun common-container-widget-args ()
+ '(id (layout-manager :default)))
(defun common-widget-args-declarations ()
(let ((arg-names (mapcar (lambda (x) (if (atom x) x (car x)))
(common-widget-args))))
`((declare (ignorable , at arg-names)))))
(defun filter-arglist (args filtered-keys)
+ "Eliminates :key value pairs in args where key is a member of filtered-keys. Returns a new list without the removed pairs."
(loop
:for key :in args :by #'cddr
:for value :in (cdr args) by #'cddr
:when (not (member key filtered-keys))
:collect key :and
- :collect value))
- (defun filter-widget-args (args)
- "Eliminates widget arguments processed by common-widget-setup; else, they would be evaluated twice in the macro expansion."
- (filter-arglist args '(:id :layout :binding :enabled-p :visible-p :location
- :layout-manager :size))))
-
-(defun common-widget-setup (self layout binding enabled-p visible-p
- location size)
- (setup-widget self :layout layout :binding binding :enabled-p enabled-p
- :visible-p visible-p :location location :size size))
+ :collect value)))
+
+(definterface setup-mouse-listeners *gui-backend*
+ (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.")
(defun setup-widget (self &key layout binding (enabled-p t) (visible-p t)
- location size &allow-other-keys)
- (when *parent* (add-child self *parent* layout))
- (setf (widget-enabled-p self) enabled-p)
- (setf (widget-visible-p self) visible-p)
- (when location (setf (widget-location self) location))
- (when binding (bind-widget self binding))
- (when size (setf (widget-size self) size)))
+ location size
+ ;;mouse event handling
+ on-mouse-click on-mouse-press on-mouse-release
+ on-mouse-enter on-mouse-exit
+ on-mouse-drag on-mouse-move
+ &allow-other-keys)
+ "Performs the common setup of any widget."
+ (macrolet ((wrap-event-callback (fn) ;;Pay attention to double evaluation
+ `(when ,fn
+ (lambda/dynamic-environment (evt)
+ (funcall ,fn evt)))))
+ (when *parent* (add-child self *parent* layout))
+ (setf (widget-enabled-p self) enabled-p)
+ (setf (widget-visible-p self) visible-p)
+ (when (or on-mouse-click on-mouse-press on-mouse-release
+ on-mouse-enter on-mouse-exit
+ on-mouse-drag on-mouse-move)
+ (setup-mouse-listeners
+ self
+ (wrap-event-callback on-mouse-click)
+ (wrap-event-callback on-mouse-press)
+ (wrap-event-callback on-mouse-release)
+ (wrap-event-callback on-mouse-enter)
+ (wrap-event-callback on-mouse-exit)
+ (wrap-event-callback on-mouse-drag)
+ (wrap-event-callback on-mouse-move)))
+ (when location (setf (widget-location self) location))
+ (when binding (bind-widget self binding))
+ (when size (setf (widget-size self) size))))
#+emacs (put 'define-widget-macro 'lisp-indent-function 3)
#+emacs (put 'define-widget 'lisp-indent-function 3)
@@ -148,33 +239,22 @@
(defmacro define-widget-macro (name arglist constructor &body body)
`(progn
- (defmacro ,name (, at arglist)
- `(let ((self ,,constructor)) ;The lexical variable self is always bound to the current widget.
- ,, at body
- self))
- (setf (get ',name 'widget-p) t)))
-
-;;Experimental - not working right now
-(defmacro define-widget-function (name arglist constructor &body body)
- `(progn
- (defun ,name (, at arglist)
+ (defmacro ,name ,(splice-into (common-widget-args) '&common-widget-args
+ arglist)
`(let ((self ,,constructor)) ;The lexical variable self is always bound to the current widget.
,, at body
self))
(setf (get ',name 'widget-p) t)))
(define-widget-macro with-widget
- ((widget &rest args &key id layout binding (enabled-p t) (visible-p t)
- location size)
- &body body)
+ ((widget &rest args &key id &common-widget-args) &body body)
`(dont-add ,widget)
`(progn
,@(generate-default-children-processing-code id body)
- (common-widget-setup self ,layout ,binding ,enabled-p ,visible-p ,location ,size)))
+ (setup-widget self ,@(filter-arglist args '(:id)))))
(define-widget-macro child
- (widget &rest args &key layout binding (enabled-p t) (visible-p t)
- location size)
+ (widget &rest args &key &common-widget-args)
widget
`(setup-widget , at args))
@@ -182,7 +262,7 @@
"Convenience macro for defining a widget."
(with-unique-names (args)
`(define-widget-macro ,name
- (&rest ,args &key ,@(common-widget-args) , at keys)
+ (&rest ,args &key &common-widget-args , at keys)
`(funcall (lambda (&rest args) ;;to evaluate args only once
(let ((self (apply (function ,',constructor) args)))
(apply #'setup-widget self args)
@@ -195,7 +275,7 @@
"Convenience macro for defining a container widget."
(with-unique-names (args macro-body)
`(define-widget-macro ,name
- ((&rest ,args &key id ,@(common-widget-args) layout-manager , at keys)
+ ((&rest ,args &key &common-widget-args id layout-manager , at keys)
&body ,macro-body)
`(funcall (lambda (&rest args) ;;to evaluate args only once
(let ((self (apply (function ,',constructor) args)))
@@ -215,24 +295,17 @@
(defmacro dont-add (&body body)
`(let ((*parent* nil))
, at body))
-
-(definterface call-in-gui-thread *gui-backend* (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).")
-
-(defvar *dynamic-environment* nil)
-
-(defmacro with-gui ((&optional (gui-backend '*gui-backend*)) &body body)
- (with-unique-names (gui-backend-var package-var debugger-hook-var
+
+#|| (with-unique-names (gui-backend-var package-var
dynamic-environment terminal-io-var)
`(let* ((,gui-backend-var ,gui-backend)
(*gui-backend* ,gui-backend-var)
(,package-var *package*)
- (,debugger-hook-var *debugger-hook*)
(,terminal-io-var *terminal-io*)) ;;Etc...
(dynamic-wind
(let ((*gui-backend* ,gui-backend-var)
(*package* ,package-var)
- (*debugger-hook* ,debugger-hook-var)
+ (*debugger-hook* *graphical-debugger-hook*)
(*terminal-io* ,terminal-io-var))
(proceed
(let ((,dynamic-environment (capture-dynamic-environment)))
@@ -240,155 +313,4 @@
(lambda ()
(with-dynamic-environment (,dynamic-environment)
(let ((*dynamic-environment* ,dynamic-environment))
- , at body)))))))))))
-
-;;Common Interfaces
-(defvar *gui-backend* :swing "Variable used to determine the GUI backend, and thus interface implementation, to use. Defaults to :swing.")
-
-(definterface add-child *gui-backend* (child &optional (parent *parent*) layout-constraints))
-
-(definterface widget-enabled-p *gui-backend* (widget))
-
-(definterface (setf widget-enabled-p) *gui-backend* (value widget))
-
-(definterface widget-visible-p *gui-backend* (widget))
-
-(definterface (setf widget-visible-p) *gui-backend* (value widget))
-
-(definterface (setf widget-location) *gui-backend* (value widget))
-
-(definterface (setf widget-size) *gui-backend* (value widget))
-
-(definterface dispose *gui-backend* (obj))
-
-(definterface show *gui-backend* (obj))
-
-(definterface hide *gui-backend* (obj))
-
-(definterface pack *gui-backend* (window))
-
-;;Windows
-(definterface make-frame *gui-backend* (&key menu-bar title on-close
- &allow-other-keys))
-
-(define-container-widget frame (menu-bar title on-close) make-frame)
-
-(definterface make-dialog *gui-backend*
- (&key parent title modal-p visible-p &allow-other-keys))
-
-(define-widget-macro dialog
- ((&rest args &key id layout binding (enabled-p t) (visible-p t) location
- size 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 , at 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)))
-
-#|
-(define-container-widget dialog (parent title modal-p)
- make-dialog)|#
-
-;;Menus
-(definterface make-menu-bar *gui-backend* (&key &allow-other-keys))
-
-(define-container-widget menu-bar () make-menu-bar)
-
-(definterface make-menu *gui-backend* (&key text &allow-other-keys))
-
-(define-container-widget menu (text) make-menu)
-
-(definterface make-menu-item *gui-backend*
- (&key text on-action &allow-other-keys))
-
-(define-widget menu-item (text on-action) make-menu-item)
-
-;;Panels
-(definterface make-panel *gui-backend* (&key &allow-other-keys))
-
-(define-container-widget panel () make-panel)
-
-(defvar *tabs*)
-
-(definterface make-tabs *gui-backend* (&key (wrap t) (tab-placement :top)
- &allow-other-keys))
-
-(define-widget-macro tabs
- ((&rest args
- &key id layout binding (enabled-p t) (visible-p t) location size (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))
- , at body))
- body))
- (common-widget-setup self ,layout ,binding ,enabled-p ,visible-p
- ,location ,size)))
-
-(defmacro tab (name &body body)
- `(if *tabs*
- (add-child (progn , at body) *tabs* ,name)
- (error "tab outside tabset: ~A" ,name)))
-
-(definterface make-scroll-panel *gui-backend* (view))
-
-(definterface scroll-panel-view *gui-backend* (self))
-
-(definterface (setf scroll-panel-view) *gui-backend* (view self))
-
-(define-widget-macro scroll
- ((&rest args &key layout binding (enabled-p t) (visible-p t) location size) body)
- `(make-scroll-panel (dont-add ,body))
- `(setup-widget self , at args))
-
-(definterface make-split-panel *gui-backend*
- (child1 child2 &key (orientation :horizontal) smoothp))
-
-(define-widget-macro split
- ((&rest args &key layout binding (enabled-p t) (visible-p t) location size orientation smoothp)
- child1 child2)
- `(make-split-panel (dont-add ,child1) (dont-add ,child2)
- :orientation ,orientation :smoothp ,smoothp)
- `(common-widget-setup self ,layout ,binding ,enabled-p ,visible-p ,location ,size))
-
-(defmacro defwidget (name &rest args)
- (let* ((maker-sym (intern (concatenate 'string "MAKE-" (symbol-name name)))))
- `(progn
- (definterface ,maker-sym *gui-backend* (&key , at args &allow-other-keys))
- (define-widget ,name (, at args &allow-other-keys) ,maker-sym))))
-
-;;Buttons and similar
-
-(defwidget button text on-action)
-
-(defwidget check-box text selected-p)
-
-;;Misc
-
-(defwidget progress-bar value orientation (paint-border t) progress-string)
-
-;;Text
-
-(defwidget label text)
-
-(defwidget text-field text)
-
-(defwidget text-area text)
-
-;;Lists
-
-(defwidget list-widget model selected-index)
-
-;;Trees
-
-(defwidget tree model)
\ No newline at end of file
+ , at body)))))))))))||#
\ No newline at end of file
Modified: trunk/src/lisp/snow/swing/swing.lisp
==============================================================================
--- trunk/src/lisp/snow/swing/swing.lisp (original)
+++ trunk/src/lisp/snow/swing/swing.lisp Mon Nov 30 17:44:36 2009
@@ -69,6 +69,20 @@
(defimpl (setf layout-manager) (lm widget)
(setf (widget-property widget :layout) lm))
+(defimpl snow::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)
+ (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"))
Modified: trunk/src/lisp/snow/utils.lisp
==============================================================================
--- trunk/src/lisp/snow/utils.lisp (original)
+++ trunk/src/lisp/snow/utils.lisp Mon Nov 30 17:44:36 2009
@@ -60,6 +60,23 @@
obj
(list obj)))
+(defun splice-if (item predicate tree)
+ (let ((list-item (reverse (ensure-list item))))
+ (labels
+ ((aux (tree acc)
+ (if tree
+ (if (listp (car tree))
+ (aux (cdr tree)
+ (cons (splice-if item predicate (car tree)) acc))
+ (if (funcall predicate (car tree))
+ (aux (cdr tree) (append list-item acc))
+ (aux (cdr tree) (cons (car tree) acc))))
+ (nreverse acc))))
+ (aux tree nil))))
+
+(defun splice-into (item olditem tree)
+ (splice-if item #'(lambda (x) (eq x olditem)) tree))
+
;;Interface/implementation
(defstruct interface name lambda-list (implementations (list)))
Added: trunk/src/lisp/snow/widgets.lisp
==============================================================================
--- (empty file)
+++ trunk/src/lisp/snow/widgets.lisp Mon Nov 30 17:44:36 2009
@@ -0,0 +1,149 @@
+;;; widgets.lisp
+;;;
+;;; Copyright (C) 2008-2009 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)
+
+;;Windows
+(definterface make-frame *gui-backend* (&key menu-bar title on-close
+ &allow-other-keys))
+
+(define-container-widget frame (menu-bar title on-close) make-frame)
+
+(definterface make-dialog *gui-backend*
+ (&key parent title modal-p visible-p &allow-other-keys))
+
+(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 , at 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)))
+
+;;Menus
+(definterface make-menu-bar *gui-backend* (&key &allow-other-keys))
+
+(define-container-widget menu-bar () make-menu-bar)
+
+(definterface make-menu *gui-backend* (&key text &allow-other-keys))
+
+(define-container-widget menu (text) make-menu)
+
+(definterface make-menu-item *gui-backend*
+ (&key text on-action &allow-other-keys))
+
+(define-widget menu-item (text on-action) make-menu-item)
+
+;;Panels
+(definterface make-panel *gui-backend* (&key &allow-other-keys))
+
+(define-container-widget panel () make-panel)
+
+(defvar *tabs*)
+
+(definterface make-tabs *gui-backend* (&key (wrap t) (tab-placement :top)
+ &allow-other-keys))
+
+(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))
+ , at body))
+ body))
+ (setup-widget self ,@(filter-arglist args '(:id)))))
+
+(defmacro tab (name &body body)
+ `(if *tabs*
+ (add-child (progn , at body) *tabs* ,name)
+ (error "tab outside tabset: ~A" ,name)))
+
+(definterface make-scroll-panel *gui-backend* (view))
+
+(definterface scroll-panel-view *gui-backend* (self))
+
+(definterface (setf scroll-panel-view) *gui-backend* (view self))
+
+(define-widget-macro scroll
+ ((&rest args &key &common-widget-args) body)
+ `(make-scroll-panel (dont-add ,body))
+ `(setup-widget self , at args))
+
+(definterface make-split-panel *gui-backend*
+ (child1 child2 &key (orientation :horizontal) smoothp))
+
+(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))))
+
+(defmacro defwidget (name &rest args)
+ (let* ((maker-sym (intern (concatenate 'string "MAKE-" (symbol-name name)))))
+ `(progn
+ (definterface ,maker-sym *gui-backend* (&key , at args &allow-other-keys))
+ (define-widget ,name (, at args &allow-other-keys) ,maker-sym))))
+
+;;Buttons and similar
+(defwidget button text on-action)
+
+(defwidget check-box text selected-p)
+
+;;Misc
+
+(defwidget progress-bar value orientation (paint-border t) progress-string)
+
+;;Text
+
+(defwidget label text)
+
+(defwidget text-field text)
+
+(defwidget text-area text)
+
+;;Lists
+
+(defwidget list-widget model selected-index)
+
+;;Trees
+
+(defwidget tree model)
\ No newline at end of file
More information about the snow-cvs
mailing list