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

working on hand gadget

cvs
Slava Pestov 2005-02-02 01:14:03 +00:00
parent 3453ac0e04
commit cd286eeff7
10 changed files with 139 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -157,6 +157,7 @@ cpu "x86" = [
"/library/ui/gadgets.factor"
"/library/ui/boxes.factor"
"/library/ui/gestures.factor"
"/library/ui/hand.factor"
"/library/ui/world.factor"
] [
dup print

1
library/sdl/sdl-utils.factor
View File

@ -55,6 +55,7 @@ SYMBOL: surface
: with-screen ( width height bpp flags quot -- )
#! Set up SDL graphics and call the quotation.
SDL_INIT_EVERYTHING SDL_Init drop TTF_Init
[ >r init-screen r> call SDL_Quit ] with-scope ; inline
: rgb ( r g b -- n )

2
library/stack.factor
View File

@ -10,7 +10,7 @@ IN: kernel
: -rot ( x y z -- z x y ) swap >r swap r> ; inline
: dupd ( x y -- x x y ) >r dup r> ; inline
: swapd ( x y z -- y x z ) >r swap r> ; inline
: 2swap ( x y z t -- z t x y ) >r rot r> rot ; inline
: 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline
: nip ( x y -- y ) swap drop ; inline
: 2nip ( x y z -- z ) >r drop drop r> ; inline
: tuck ( x y -- y x y ) dup >r swap r> ; inline

17
library/ui/boxes.factor
View File

@ -15,8 +15,9 @@ M: general-list draw ( list -- )
M: box draw ( box -- )
dup [
dup [
dup box-contents draw
dup
box-delegate draw
box-contents draw
] with-gadget
] with-translation ;
@ -49,10 +50,18 @@ M: box pick-up* ( point box -- gadget )
] with-translation ;
: box- ( gadget box -- )
2dup box-contents remove swap set-box-contents
2dup box-contents remove swap tuck set-box-contents redraw
f swap set-gadget-parent ;
: (box+) ( gadget box -- )
[ box-contents cons ] keep set-box-contents ;
: unparent ( gadget -- )
dup gadget-parent dup [ box- ] [ 2drop ] ifte ;
: box+ ( gadget box -- )
#! Add a gadget to a box.
over gadget-parent [ pick swap box- ] when*
[ box-contents cons ] keep set-box-contents ;
over unparent
dup pick set-gadget-parent
tuck (box+)
redraw ;

12
library/ui/gadgets.factor
View File

@ -4,7 +4,6 @@ IN: gadgets
USING: generic hashtables kernel lists namespaces ;
! Gadget protocol.
GENERIC: pick-up* ( point gadget -- gadget/t )
GENERIC: handle-gesture* ( gesture gadget -- ? )
@ -40,8 +39,17 @@ M: gadget pick-up* inside? ;
M: gadget handle-gesture* 2drop t ;
GENERIC: redraw ( gadget -- )
: move-gadget ( x y gadget -- )
[ move-shape ] keep set-gadget-delegate ;
[ move-shape ] keep
[ set-gadget-delegate ] keep
redraw ;
: resize-gadget ( w h gadget -- )
[ resize-shape ] keep
[ set-gadget-delegate ] keep
redraw ;
! An invisible gadget.
WRAPPER: ghost

6
library/ui/gestures.factor
View File

@ -16,3 +16,9 @@ USING: generic kernel lists sdl-event ;
] [
2drop
] ifte ;
TUPLE: redraw-gesture ;
C: redraw-gesture ;
M: object redraw ( gadget -- )
<redraw-gesture> swap handle-gesture ;

40
library/ui/hand.factor Normal file
View File

@ -0,0 +1,40 @@
! 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
sdl-video ;
! The hand is a special gadget that holds mouse position and
! mouse button click state. The hand's parent is the world, but
! it is special in that the world does not list it as part of
! its contents.
TUPLE: hand click-pos clicked buttons delegate ;
C: hand ( -- hand )
0 <gadget> <ghost> <box>
over set-hand-delegate ;
GENERIC: hand-gesture ( hand gesture -- )
M: object 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-click-pos
button-event-button swap button/ ;
M: button-up-event hand-gesture ( hand gesture -- )
button-event-button swap button\ ;
M: motion-event hand-gesture ( hand gesture -- )
dup motion-event-x swap motion-event-y rot move-gadget ;
M: hand redraw ( hand -- )
drop world get redraw ;

8
library/ui/paint.factor
View File

@ -21,7 +21,13 @@ SYMBOL: filled ! is the interior of the shape filled?
GENERIC: draw ( obj -- )
M: rect draw ( rect -- )
M: ghost draw ( ghost -- )
drop ;
M: number draw ( point -- )
>r surface get r> >rect rgb-color pixelColor ;
M: rectangle draw ( rect -- )
>r surface get r> shape>screen rgb-color
filled get [ boxColor ] [ rectangleColor ] ifte ;

54
library/ui/shapes.factor
View File

@ -45,38 +45,48 @@ M: number shape-h drop 0 ;
M: number move-shape ( x y point -- point ) drop rect> ;
! A rectangle maps trivially to the shape protocol.
TUPLE: rect x y w h ;
M: rect shape-x rect-x ;
M: rect shape-y rect-y ;
M: rect shape-w rect-w ;
M: rect shape-h rect-h ;
TUPLE: rectangle x y w h ;
M: rectangle shape-x rectangle-x ;
M: rectangle shape-y rectangle-y ;
M: rectangle shape-w rectangle-w ;
M: rectangle shape-h rectangle-h ;
: fix-neg ( a b c -- a+c b -c )
dup 0 < [ neg tuck >r >r + r> r> ] when ;
C: rect ( x y w h -- rect )
C: rectangle ( x y w h -- rect )
#! We handle negative w/h for convinience.
>r fix-neg >r fix-neg r> r>
[ set-rect-h ] keep
[ set-rect-w ] keep
[ set-rect-y ] keep
[ set-rect-x ] keep ;
[ set-rectangle-h ] keep
[ set-rectangle-w ] keep
[ set-rectangle-y ] keep
[ set-rectangle-x ] keep ;
M: number resize-shape ( w h point -- rect )
>rect 2swap <rect> ;
>rect 2swap <rectangle> ;
M: rect move-shape ( x y rect -- rect )
[ rect-w ] keep rect-h <rect> ;
M: rectangle move-shape ( x y rect -- rect )
[ rectangle-w ] keep rectangle-h <rectangle> ;
M: rect resize-shape ( w h rect -- rect )
[ rect-x ] keep rect-y 2swap <rect> ;
M: rectangle resize-shape ( w h rect -- rect )
[ rectangle-x ] keep rectangle-y 2swap <rectangle> ;
: rect-x-extents ( rect -- x1 x2 )
dup rect-x x get + swap rect-w dupd + ;
: rectangle-x-extents ( rect -- x1 x2 )
dup rectangle-x x get + swap rectangle-w dupd + ;
: rect-y-extents ( rect -- x1 x2 )
dup rect-y y get + swap rect-h dupd + ;
: rectangle-y-extents ( rect -- x1 x2 )
dup rectangle-y y get + swap rectangle-h dupd + ;
M: rect inside? ( point rect -- ? )
over shape-x over rect-x-extents between? >r
swap shape-y swap rect-y-extents between? r> and ;
M: rectangle inside? ( point rect -- ? )
over shape-x over rectangle-x-extents between? >r
swap shape-y swap rectangle-y-extents between? r> and ;
! Delegates to a bounded shape, but absorbs all points.
WRAPPER: everywhere
M: everywhere inside? ( point world -- ? ) 2drop t ;
M: everywhere move-shape ( x y everywhere -- )
everywhere-delegate move-shape <everywhere> ;
M: everywhere resize-shape ( w h everywhere -- )
everywhere-delegate resize-shape <everywhere> ;

65
library/ui/world.factor
View File

@ -1,53 +1,23 @@
! 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\ ;
M: motion-event hand-gesture ( hand gesture -- )
dup motion-event-x swap motion-event-y rot move-gadget ;
USING: alien generic kernel lists math namespaces sdl sdl-event
sdl-video ;
! 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 redraw? ;
TUPLE: redraw-gesture ;
C: redraw-gesture ;
: redraw ( gadget -- )
<redraw-gesture> swap handle-gesture ;
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> ;
0 0 0 0 <rectangle> <everywhere> <gadget>
dup blue 3list color set-paint-property
dup t filled set-paint-property
<box> ;
C: world ( -- world )
<world-box> over set-world-delegate
@ -62,7 +32,14 @@ M: alien world-gesture ( world gesture -- ) 2drop ;
M: quit-event world-gesture ( world gesture -- )
drop f swap set-world-running? ;
M: resize-event world-gesture ( world gesture -- ? )
dup resize-event-w swap resize-event-h
[ rot resize-gadget ] 2keep
0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen
world get redraw ;
M: redraw-gesture world-gesture ( world gesture -- )
drop t swap set-world-redraw? ;
M: world handle-gesture* ( gesture world -- ? )
@ -74,7 +51,8 @@ M: world handle-gesture* ( gesture world -- ? )
world get dup world-redraw? [
[
f over set-world-redraw?
draw
dup draw
world-hand draw
] with-surface
] [
drop
@ -89,4 +67,17 @@ M: world handle-gesture* ( gesture world -- ? )
] ifte
] when ;
: init-world ( w h -- )
t world get set-world-running?
t world get set-world-redraw?
world get resize-gadget ;
: world-flags SDL_HWSURFACE SDL_RESIZABLE bitor ;
: start-world ( w h -- )
#! Start the Factor graphics subsystem with the given screen
#! dimensions.
2dup init-world 0 world-flags
default-paint [ [ run-world ] with-screen ] bind ;
global [ <world> world set ] bind