steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

more UI work

cvs
Slava Pestov 2005-02-01 03:32:06 +00:00
parent c35f6f9f44
commit 8a42466cf2
12 changed files with 306 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
TODO.FACTOR.txt
View File

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

4
factor/DefaultVocabularyLookup.java
View File

@ -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

69
factor/parser/Tuple.java Normal file
View File

@ -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);
}
}
}
}

15
library/bootstrap/boot-stage2.factor
View File

@ -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

21
library/generic/tuple.factor
View File

@ -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 <tuple> [ -rot copy-array ] keep ;

61
library/test/gadgets.factor Normal file
View File

@ -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

1
library/test/test.factor
View File

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

58
library/ui/boxes.factor Normal file
View File

@ -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 ;

48
library/ui/gadgets.factor
View File

@ -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 ;

18
library/ui/gestures.factor Normal file
View File

@ -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 ;

4
library/ui/shapes.factor
View File

@ -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 ;

69
library/ui/world.factor Normal file
View File

@ -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