more UI work

TODO.FACTOR.txt

@@ -15,6 +15,7 @@
 - make see work with union, builtin, predicate
 - doc comments of generics
 - proper ordering for classes
+- tuples: in/out syntax
 
 + ffi:
 

factor/DefaultVocabularyLookup.java

@@ -3,7 +3,7 @@
 /*
  * $Id$
  *
- * Copyright (C) 2004 Slava Pestov.
+ * Copyright (C) 2004, 2005 Slava Pestov.
  *
  * Redistribution and use in source and binary forms, with or without
  * modification, are permitted provided that the following conditions are met:
@@ -133,6 +133,8 @@ public class DefaultVocabularyLookup implements VocabularyLookup
 		beginPredicate.parsing = new BeginPredicate(beginPredicate);
 		FactorWord beginUnion = define("generic","UNION:");
 		beginUnion.parsing = new BeginUnion(beginUnion);
+		FactorWord tuple = define("generic","TUPLE:");
+		tuple.parsing = new Tuple(tuple);
 	} //}}}
 
 	//{{{ getVocabulary() method

factor/parser/Tuple.java

@@ -0,0 +1,69 @@
+/* :folding=explicit:collapseFolds=1: */
+
+/*
+ * $Id$
+ *
+ * Copyright (C) 2005 Slava Pestov.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright notice,
+ *    this list of conditions and the following disclaimer.
+ *
+ * 2. Redistributions in binary form must reproduce the above copyright notice,
+ *    this list of conditions and the following disclaimer in the documentation
+ *    and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+ * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+ * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+ * DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+ * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+ * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+ * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+ * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
+
+package factor.parser;
+
+import factor.*;
+
+public class Tuple extends FactorParsingDefinition
+{
+	public Tuple(FactorWord word)
+	{
+		super(word);
+	}
+
+	public void eval(FactorReader reader)
+		throws Exception
+	{
+		Object next = reader.nextNonEOL(false,false);
+		if(!(next instanceof String))
+		{
+			reader.getScanner().error("Missing tuple name");
+			return;
+		}
+
+		String tupleName = (String)next;
+		reader.intern(tupleName,true);
+		reader.intern("<" + tupleName + ">",true);
+
+		for(;;)
+		{
+			next = reader.next(false,false);
+			if(next == FactorScanner.EOF)
+				reader.getScanner().error("Expected ;");
+			if(next.equals(";"))
+				break;
+			else if(next instanceof String)
+			{
+				reader.intern(tupleName + "-" + next,true);
+				reader.intern("set-" + tupleName + "-" + next,true);
+			}
+		}
+	}
+}

library/bootstrap/boot-stage2.factor

@@ -106,12 +106,6 @@ USING: kernel lists parser stdio words namespaces ;
     "/library/sdl/sdl-utils.factor"
     "/library/sdl/hsv.factor"
 
-    "/library/ui/line-editor.factor"
-    "/library/ui/console.factor"
-    "/library/ui/shapes.factor"
-    "/library/ui/paint.factor"
-    "/library/ui/gadgets.factor"
-
     "/library/bootstrap/image.factor"
 
     "/library/httpd/url-encoding.factor"
@@ -155,6 +149,15 @@ cpu "x86" = [
          "/library/compiler/x86/stack.factor"
          "/library/compiler/x86/generator.factor"
          "/library/compiler/x86/fixnum.factor"
+
+        "/library/ui/line-editor.factor"
+        "/library/ui/console.factor"
+        "/library/ui/shapes.factor"
+        "/library/ui/paint.factor"
+        "/library/ui/gadgets.factor"
+        "/library/ui/boxes.factor"
+        "/library/ui/gestures.factor"
+        "/library/ui/world.factor"
     ] [
         dup print
         run-resource

library/generic/tuple.factor

@@ -77,26 +77,29 @@ kernel-internals math hashtables errors ;
     scan-word [ tuple-constructor ] f ; parsing
 
 : tuple-delegate ( tuple -- obj )
-    >tuple dup class "delegate-field" word-property dup [
+    dup tuple? [
-        >fixnum slot
+        dup class "delegate-field" word-property dup [
+            >fixnum slot
+        ] [
+            2drop f
+        ] ifte
     ] [
-        2drop f
+        drop f
     ] ifte ; inline
 
-: tuple-dispatch ( object selector -- object quot )
+: tuple-dispatch ( object selector -- )
     over class over "methods" word-property hash* [
-        cdr ( method is defined )
+        cdr call ( method is defined )
     ] [
         over tuple-delegate [
-            rot drop swap tuple-dispatch ( check delegate )
+            rot drop swap execute ( check delegate )
         ] [
-            [ undefined-method ] ( no delegate )
+            undefined-method ( no delegate )
         ] ifte*
     ] ?ifte ;
 
 : add-tuple-dispatch ( word vtable -- )
-    >r unit [ car tuple-dispatch call ] cons tuple r>
+    >r unit [ car tuple-dispatch ] cons tuple r> set-vtable ;
-    set-vtable ;
 
 M: tuple clone ( tuple -- tuple )
     dup array-capacity dup <tuple> [ -rot copy-array ] keep ;

library/test/gadgets.factor

@@ -0,0 +1,61 @@
+IN: scratchpad
+USING: gadgets kernel lists math namespaces test ;
+
+[ t ] [
+    [
+        2000 x set
+        2000 y set
+        2030 2040 rect> 10 20 300 400 <rect> inside?
+    ] with-scope
+] unit-test
+[ f ] [
+    [
+        2000 x set
+        2000 y set
+        2500 2040 rect> 10 20 300 400 <rect> inside?
+    ] with-scope
+] unit-test
+[ t ] [
+    [
+        -10 x set
+        -20 y set
+        0 0 rect> 10 20 300 400 <rect> inside?
+    ] with-scope
+] unit-test
+[ 11 11 41 41 ] [
+    default-paint [
+        [
+            1 x set
+            1 y set
+            10 10 30 30 <rect> <gadget> shape>screen
+        ] with-scope
+    ] bind
+] unit-test
+[ t ] [
+    default-paint [
+        0 0 rect> -10 -10 20 20 <rect> <gadget> [ pick-up ] keep =
+    ] bind
+] unit-test
+
+: funny-rect ( x -- rect )
+    10 10 30 <rect> <gadget>
+    dup [ 255 0 0 ] color set-paint-property
+    dup t filled set-paint-property ;
+    
+[ f ] [
+    default-paint [
+        35 0 rect>
+        [ 10 30 50 70 ] [ funny-rect ] map
+        pick-up
+    ] bind
+] unit-test
+    
+[ 30 ] [
+    default-paint [
+        35 10 rect>
+        [ 10 30 50 70 ] [ funny-rect ] map
+        0 0 200 200 <rect> <gadget> <ghost> <box>
+        [ set-box-contents ] keep
+        pick-up shape-x
+    ] bind
+] unit-test

library/test/test.factor

@@ -103,6 +103,7 @@ USE: unparser
         "hsv"
         "alien"
         "line-editor"
+        "gadgets"
     ] [
         test
     ] each

library/ui/boxes.factor

@@ -0,0 +1,58 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: generic hashtables kernel lists namespaces ;
+
+! A box is a gadget holding other gadgets.
+TUPLE: box contents delegate ;
+
+C: box ( gadget -- box )
+    [ set-box-delegate ] keep ;
+
+M: general-list draw ( list -- )
+    [ draw ] each ;
+
+M: box draw ( box -- )
+    dup [
+        dup [
+            dup box-contents draw
+            box-delegate draw
+        ] with-gadget
+    ] with-translation ;
+
+M: general-list pick-up ( point list -- gadget )
+    dup [
+        2dup car pick-up dup [
+            2nip
+        ] [
+            drop cdr pick-up
+        ] ifte
+    ] [
+        2drop f
+    ] ifte ;
+
+M: box pick-up ( point box -- gadget )
+    #! The logic is thus. If the point is definately outside the
+    #! box, return f. Otherwise, see if the point is contained
+    #! in any subgadget. If not, see if it is contained in the
+    #! box delegate.
+    dup [
+        2dup gadget-delegate inside? [
+            2dup box-contents pick-up dup [
+                2nip
+            ] [
+                drop box-delegate pick-up
+            ] ifte
+        ] [
+            2drop f
+        ] ifte
+    ] with-translation ;
+
+: box- ( gadget box -- )
+    2dup box-contents remove swap set-box-contents
+    f swap set-gadget-parent ;
+
+: box+ ( gadget box -- )
+    #! Add a gadget to a box.
+    swap dup gadget-parent dup [ box- ] [ 2drop ] ifte
+    [ box-contents cons ] keep set-box-contents ;

library/ui/gadgets.factor

@@ -5,6 +5,7 @@ USING: generic hashtables kernel lists namespaces ;
 
 ! Gadget protocol.
 GENERIC: pick-up ( point gadget -- gadget )
+GENERIC: handle-gesture* ( gesture gadget -- ? )
 
 ! A gadget is a shape together with paint, and a reference to
 ! the gadget's parent. A gadget delegates to its shape.
@@ -31,52 +32,9 @@ M: gadget draw ( gadget -- )
 
 M: gadget pick-up tuck inside? [ drop f ] unless ;
 
+M: gadget handle-gesture* 2drop t ;
+
 ! An invisible gadget.
 WRAPPER: ghost
 M: ghost draw drop ;
 M: ghost pick-up 2drop f ;
-
-! A box is a gadget holding other gadgets.
-TUPLE: box contents delegate ;
-
-C: box ( gadget -- box )
-    [ set-box-delegate ] keep ;
-
-M: general-list draw ( list -- )
-    [ draw ] each ;
-
-M: box draw ( box -- )
-    dup [
-        dup [
-            dup box-contents draw
-            box-delegate draw
-        ] with-gadget
-    ] with-translation ;
-
-M: general-list pick-up ( point list -- gadget )
-    dup [
-        2dup car pick-up dup [
-            2nip
-        ] [
-            drop cdr pick-up
-        ] ifte
-    ] [
-        2drop f
-    ] ifte ;
-
-M: box pick-up ( point box -- )
-    #! The logic is thus. If the point is definately outside the
-    #! box, return f. Otherwise, see if the point is contained
-    #! in any subgadget. If not, see if it is contained in the
-    #! box delegate.
-    dup [
-        2dup gadget-delegate inside? [
-            2dup box-contents pick-up dup [
-                2nip
-            ] [
-                drop box-delegate pick-up
-            ] ifte
-        ] [
-            2drop f
-        ] ifte
-    ] with-translation ;

library/ui/gestures.factor

@@ -0,0 +1,18 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: generic kernel lists sdl-event ;
+
+: handle-gesture ( gesture gadget -- )
+    #! If a gadget's handle-gesture* generic returns t, the
+    #! event was not consumed and is passed on to the gadget's
+    #! parent.
+    2dup handle-gesture* [
+        gadget-parent dup [
+            handle-gesture
+        ] [
+            2drop
+        ] ifte
+    ] [
+        2drop
+    ] ifte ;

library/ui/shapes.factor

@@ -62,5 +62,5 @@ C: rect ( x y w h -- rect )
     dup rect-y y get + swap rect-h dupd + ;
 
 M: rect inside? ( point rect -- ? )
-    over real over rect-x-extents between? >r
+    over shape-x over rect-x-extents between? >r
-    swap imaginary swap rect-y-extents between? r> and ;
+    swap shape-y swap rect-y-extents between? r> and ;

library/ui/world.factor

@@ -0,0 +1,69 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: alien generic kernel lists math namespaces sdl sdl-event ;
+
+! The hand is a special gadget that holds mouse position and
+! mouse button click state.
+TUPLE: hand clicked buttons delegate ;
+
+C: hand ( -- hand ) 0 <gadget> over set-hand-delegate ;
+
+GENERIC: hand-gesture ( hand gesture -- )
+
+M: alien hand-gesture ( hand gesture -- ) 2drop ;
+
+: button/ ( n hand -- )
+    [ hand-buttons unique ] keep set-hand-buttons ;
+
+: button\ ( n hand -- )
+    [ hand-buttons remove ] keep set-hand-buttons ;
+
+M: button-down-event hand-gesture ( hand gesture -- )
+    2dup
+    dup button-event-x swap button-event-y rect>
+    swap set-hand-clicked
+    button-event-button swap button/ ;
+
+M: button-up-event hand-gesture ( hand gesture -- )
+    button-event-button swap button\ ;
+
+! The world gadget is the top level gadget that all (visible)
+! gadgets are contained in. The current world is stored in the
+! world variable.
+TUPLE: world running? hand delegate ;
+
+M: hand handle-gesture* ( gesture hand -- ? )
+    2dup swap hand-gesture
+    world get pick-up handle-gesture* ;
+
+: <world-box> ( -- box )
+    0 0 1000 1000 <rect> <gadget> <box> ;
+
+C: world ( -- world )
+    <world-box> over set-world-delegate
+    t over set-world-running?
+    <hand> over set-world-hand ;
+
+GENERIC: world-gesture ( world gesture -- )
+
+M: alien world-gesture ( world gesture -- ) 2drop ;
+
+M: quit-event world-gesture ( world gesture -- )
+    drop f swap set-world-running? ;
+
+M: world handle-gesture* ( gesture world -- ? )
+    swap world-gesture f ;
+
+: my-hand ( -- hand ) world get world-hand ;
+
+: run-world ( -- )
+    world get world-running? [
+        <event> dup SDL_WaitEvent 1 = [
+            my-hand handle-gesture run-world
+        ] [
+            drop
+        ] ifte
+    ] when ;
+
+global [ <world> world set ] bind