diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 5d6416341a..385fa2a008 100644 --- a/TODO.FACTOR.txt +++ b/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: diff --git a/factor/DefaultVocabularyLookup.java b/factor/DefaultVocabularyLookup.java index fd18adb2e9..3561609c92 100644 --- a/factor/DefaultVocabularyLookup.java +++ b/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 diff --git a/factor/parser/Tuple.java b/factor/parser/Tuple.java new file mode 100644 index 0000000000..a8e5fac8a5 --- /dev/null +++ b/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); + } + } + } +} diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 1267aec8b9..e75e4fc963 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/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 diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index 5ef4aa927e..a6f4ddecd6 100644 --- a/library/generic/tuple.factor +++ b/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 [ - >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 [ -rot copy-array ] keep ; diff --git a/library/test/gadgets.factor b/library/test/gadgets.factor new file mode 100644 index 0000000000..322eba4137 --- /dev/null +++ b/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 inside? + ] with-scope +] unit-test +[ f ] [ + [ + 2000 x set + 2000 y set + 2500 2040 rect> 10 20 300 400 inside? + ] with-scope +] unit-test +[ t ] [ + [ + -10 x set + -20 y set + 0 0 rect> 10 20 300 400 inside? + ] with-scope +] unit-test +[ 11 11 41 41 ] [ + default-paint [ + [ + 1 x set + 1 y set + 10 10 30 30 shape>screen + ] with-scope + ] bind +] unit-test +[ t ] [ + default-paint [ + 0 0 rect> -10 -10 20 20 [ pick-up ] keep = + ] bind +] unit-test + +: funny-rect ( x -- rect ) + 10 10 30 + 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 + [ set-box-contents ] keep + pick-up shape-x + ] bind +] unit-test diff --git a/library/test/test.factor b/library/test/test.factor index f613759779..9eaa372868 100644 --- a/library/test/test.factor +++ b/library/test/test.factor @@ -103,6 +103,7 @@ USE: unparser "hsv" "alien" "line-editor" + "gadgets" ] [ test ] each diff --git a/library/ui/boxes.factor b/library/ui/boxes.factor new file mode 100644 index 0000000000..bd75533982 --- /dev/null +++ b/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 ; diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 9206e0d804..78fbf32333 100644 --- a/library/ui/gadgets.factor +++ b/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 ; diff --git a/library/ui/gestures.factor b/library/ui/gestures.factor new file mode 100644 index 0000000000..0840ec0eeb --- /dev/null +++ b/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 ; diff --git a/library/ui/shapes.factor b/library/ui/shapes.factor index 0ff0cc5dca..10de50cb36 100644 --- a/library/ui/shapes.factor +++ b/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 - 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 ; diff --git a/library/ui/world.factor b/library/ui/world.factor new file mode 100644 index 0000000000..114f0868e9 --- /dev/null +++ b/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 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* ; + +: ( -- box ) + 0 0 1000 1000 ; + +C: world ( -- world ) + over set-world-delegate + t over set-world-running? + 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? [ + dup SDL_WaitEvent 1 = [ + my-hand handle-gesture run-world + ] [ + drop + ] ifte + ] when ; + +global [ world set ] bind