- make see work with union, builtin, predicate\r
- doc comments of generics\r
- proper ordering for classes\r
+- tuples: in/out syntax\r
\r
+ ffi:\r
\r
/*
* $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:
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
--- /dev/null
+/* :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/sdl/sdl-utils.factor"\r
"/library/sdl/hsv.factor"\r
\r
- "/library/ui/line-editor.factor"\r
- "/library/ui/console.factor"\r
- "/library/ui/shapes.factor"\r
- "/library/ui/paint.factor"\r
- "/library/ui/gadgets.factor"\r
-\r
"/library/bootstrap/image.factor"\r
\r
"/library/httpd/url-encoding.factor"\r
"/library/compiler/x86/stack.factor"\r
"/library/compiler/x86/generator.factor"\r
"/library/compiler/x86/fixnum.factor"\r
+\r
+ "/library/ui/line-editor.factor"\r
+ "/library/ui/console.factor"\r
+ "/library/ui/shapes.factor"\r
+ "/library/ui/paint.factor"\r
+ "/library/ui/gadgets.factor"\r
+ "/library/ui/boxes.factor"\r
+ "/library/ui/gestures.factor"\r
+ "/library/ui/world.factor"\r
] [\r
dup print\r
run-resource\r
scan-word [ tuple-constructor ] f ; parsing
: tuple-delegate ( tuple -- obj )
- >tuple dup class "delegate-field" word-property dup [
- >fixnum slot
+ dup tuple? [
+ 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>
- set-vtable ;
+ >r unit [ car tuple-dispatch ] cons tuple r> set-vtable ;
M: tuple clone ( tuple -- tuple )
dup array-capacity dup <tuple> [ -rot copy-array ] keep ;
--- /dev/null
+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
"hsv"
"alien"
"line-editor"
+ "gadgets"
] [
test
] each
--- /dev/null
+! 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 ;
! 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.
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 ;
--- /dev/null
+! 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 ;
dup rect-y y get + swap rect-h dupd + ;
M: rect inside? ( point rect -- ? )
- over real over rect-x-extents between? >r
- swap imaginary swap rect-y-extents between? r> and ;
+ over shape-x over rect-x-extents between? >r
+ swap shape-y swap rect-y-extents between? r> and ;
--- /dev/null
+! 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
projects / factor.git / commitdiff