"/library/ui/paint.factor"\r
"/library/ui/gestures.factor"\r
"/library/ui/hand.factor"\r
+ "/library/ui/layouts.factor"\r
"/library/ui/world.factor"\r
"/library/ui/labels.factor"\r
- "/library/ui/layouts.factor"\r
"/library/ui/events.factor"\r
] [\r
dup print\r
MEMBER: user-event
END-UNION
-: SDL_WaitEvent ( event -- )
- "int" "sdl" "SDL_WaitEvent" [ "event*" ] alien-invoke ;
+: SDL_WaitEvent ( event -- ? )
+ "bool" "sdl" "SDL_WaitEvent" [ "event*" ] alien-invoke ;
: SDL_PollEvent ( event -- ? )
"bool" "sdl" "SDL_PollEvent" [ "event*" ] alien-invoke ;
SDL_INIT_EVERYTHING SDL_Init drop TTF_Init
[ >r init-screen r> call SDL_Quit ] with-scope ; inline
-: rgb ( r g b -- n )
+: rgb ( [ r g b ] -- n )
+ 3unlist
255
swap 8 shift bitor
swap 16 shift bitor
swap 8 shift bitor
swap bitor ;
-: black 0 0 0 ;
-: white 255 255 255 ;
-: red 255 0 0 ;
-: green 0 255 0 ;
-: blue 0 0 255 ;
+: black [ 0 0 0 ] ;
+: white [ 255 255 255 ] ;
+: red [ 255 0 0 ] ;
+: green [ 0 255 0 ] ;
+: blue [ 0 0 255 ] ;
: clear-surface ( color -- )
>r surface get 0 0 width get height get r> boxColor ;
--- /dev/null
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: generic kernel lists math namespaces sdl ;
+
+: button-pressed ( button -- )
+ dup f bevel-up? set-paint-property redraw ;
+
+: button-released ( button -- )
+ dup t bevel-up? set-paint-property redraw ;
+
+: <button> ( label quot -- button )
+ >r <label> bevel-border
+ dup [ dup button-released ] r> append
+ [ button-up 1 ] set-action
+ dup [ button-pressed ]
+ [ button-down 1 ] set-action ;
: draw-line ( str -- )
>r x get y get console-font get r>
- foreground make-color background make-color draw-string
+ foreground make-color draw-string
x [ + ] change ;
: clear-display ( -- )
- surface get 0 0 width get height get background rgb boxColor ;
+ surface get 0 0 width get height get background 3list rgb boxColor ;
: draw-lines ( -- )
visible-lines available-lines min [
y get
over 1 +
y get line-height get +
- cursor rgb boxColor ;
+ cursor 3list rgb boxColor ;
: draw-current ( -- )
output-line get sbuf>str draw-line ;
scrollbar-top
width get
scrollbar-bottom
- black rgb boxColor ;
+ black 3list rgb boxColor ;
: draw-console ( -- )
[
: set-action ( gadget quot gesture -- )
rot gadget-gestures set-hash ;
+: redraw ( gadget -- )
+ #! Redraw a gadget before the next iteration of the event
+ #! loop.
+ t over set-gadget-redraw?
+ gadget-parent [ redraw ] when* ;
+
+: relayout ( gadget -- )
+ #! Relayout a gadget before the next iteration of the event
+ #! loop. Since relayout also implies the visual
+ #! representation changed, we redraw the gadget too.
+ t over set-gadget-redraw?
+ t over set-gadget-relayout?
+ gadget-parent [ relayout ] when* ;
+
: move-gadget ( x y gadget -- )
[ move-shape ] keep redraw ;
USING: alien generic kernel lists math namespaces sdl sdl-event
sdl-video ;
-DEFER: pick-up*
+DEFER: pick-up
: pick-up-list ( point list -- gadget )
dup [
gadget-children pick-up-list dup [
2nip
] [
- drop inside?
+ 3drop t
] ifte
] [
2drop f
over shape-y y get +
rot label-text
>r font get lookup-font r>
- color get 3unlist make-color
+ foreground get 3unlist make-color
draw-string drop ;
GENERIC: layout* ( gadget -- )
M: gadget layout* drop ;
-: relayout ( gadget -- )
- #! Relayout a gadget before the next iteration of the event
- #! loop. Since relayout also implies the visual
- #! representation changed, we redraw the gadget too.
- t over set-gadget-redraw?
- t over set-gadget-relayout?
- gadget-parent [ relayout ] when* ;
-
: layout ( gadget -- )
#! Set the gadget's width and height to its preferred width
#! and height. The gadget's children are laid out first.
#! Note that nothing is done if the gadget does not need to
#! be laid out.
dup gadget-relayout? [
- f over set-gadget-relayout?
- dup gadget-children [ layout ] each
- layout*
+ dup gadget-paint [
+ f over set-gadget-relayout?
+ dup gadget-children [ layout ] each
+ layout*
+ ] bind
] [
drop
] ifte ;
! dynamically-scoped variables.
! "Paint" is a namespace containing some or all of these values.
-SYMBOL: color ! a list of three integers, 0..255.
+
+! Colors are lists of three integers, 0..255.
+SYMBOL: foreground ! Used for text and outline shapes.
+SYMBOL: background ! Used for filled shapes.
+SYMBOL: bevel-1
+SYMBOL: bevel-2
+SYMBOL: bevel-up?
+
SYMBOL: font ! a list of two elements, a font name and size.
: shape>screen ( shape -- x1 y1 x2 y2 )
[ dup shape-x swap shape-w + x get + ] keep
dup shape-y swap shape-h + y get + ;
-: rgb-color ( -- rgba ) color get 3unlist rgb ;
-
GENERIC: draw-shape ( obj -- )
M: rectangle draw-shape drop ;
M: point draw-shape ( point -- )
>r surface get r> dup point-x swap point-y
- rgb-color pixelColor ;
+ foreground get rgb pixelColor ;
TUPLE: hollow-rect delegate ;
[ >r <rectangle> r> set-hollow-rect-delegate ] keep ;
M: hollow-rect draw-shape ( rect -- )
- >r surface get r> shape>screen rgb-color rectangleColor ;
+ >r surface get r> shape>screen foreground get rgb
+ rectangleColor ;
TUPLE: plain-rect delegate ;
[ >r <rectangle> r> set-plain-rect-delegate ] keep ;
M: plain-rect draw-shape ( rect -- )
- >r surface get r> shape>screen rgb-color boxColor ;
+ >r surface get r> shape>screen background get rgb
+ boxColor ;
: x1/x2/y1 ( #{ x1 y1 }# #{ x2 y2 }# -- x1 x2 y1 )
>r >rect r> real swap ;
: x2/y1/y2 ( #{ x1 y1 }# #{ x2 y2 }# -- x2 y1 y2 )
>r imaginary r> >rect >r swap r> ;
+: bevel-up ( -- rgb )
+ bevel-up? get [ bevel-1 get ] [ bevel-2 get ] ifte rgb ;
+
+: bevel-down ( -- rgb )
+ bevel-up? get [ bevel-2 get ] [ bevel-1 get ] ifte rgb ;
+
: (draw-bevel) ( #{ x1 y1 }# #{ x2 y2 }# -- )
- surface get pick pick x1/x2/y1 240 240 240 rgb hlineColor
- surface get pick pick x1/x2/y2 192 192 192 rgb hlineColor
- surface get pick pick x1/y1/y2 240 240 240 rgb vlineColor
- surface get pick pick x2/y1/y2 192 192 192 rgb vlineColor
+ surface get pick pick x1/x2/y1 bevel-up hlineColor
+ surface get pick pick x1/x2/y2 bevel-down hlineColor
+ surface get pick pick x1/y1/y2 bevel-up vlineColor
+ surface get pick pick x2/y1/y2 bevel-down vlineColor
2drop ;
TUPLE: bevel-rect delegate bevel ;
M: bevel-rect draw-shape ( rect -- )
shape>screen >r >r rect> r> r> rect> 3 draw-bevel ;
-: default-paint ( -- paint )
- {{
- [[ x 0 ]]
- [[ y 0 ]]
- [[ color [ 160 160 160 ] ]]
- [[ font [[ "Monospaced" 12 ]] ]]
- }} ;
-
: draw-gadget ( gadget -- )
#! All drawing done inside draw-shape is done with the
#! gadget's paint. If the gadget does not have any custom
gadget-children [ draw-gadget ] each
] with-translation
] bind ;
-
-: redraw ( gadget -- )
- #! Redraw a gadget before the next iteration of the event
- #! loop.
- t over set-gadget-redraw?
- gadget-parent [ redraw ] when* ;
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 ;
TUPLE: world running? hand delegate ;
: <world-box> ( -- box )
- 0 0 0 0 <plain-rect> <everywhere> <gadget>
- dup [ 216 216 216 ] color set-paint-property ;
+ 0 0 0 0 <plain-rect> <gadget> ;
C: world ( -- world )
<world-box> over set-world-delegate
t over set-world-running?
dup <hand> over set-world-hand ;
+M: world inside? ( point world -- ? ) 2drop t ;
+
: my-hand ( -- hand ) world get world-hand ;
: draw-world ( -- )
[
f over set-gadget-redraw?
dup draw-gadget
- world-hand draw-gadget
+ dup gadget-paint [ world-hand draw-gadget ] bind
] with-surface
] [
drop
: layout-world world get layout ;
+: eat-events ( event -- )
+ #! Keep polling for events until there are no more events in
+ #! the queue; then block for the next event.
+ dup SDL_PollEvent [
+ dup handle-event eat-events
+ ] [
+ SDL_WaitEvent
+ ] ifte ;
+
: run-world ( -- )
world get world-running? [
- <event> dup SDL_WaitEvent 1 = [
- handle-event layout-world draw-world run-world
+ layout-world draw-world
+ <event> dup eat-events [
+ handle-event run-world
] [
drop
] ifte
] when ;
-: init-world ( w h -- )
- t world get set-world-running?
- world get resize-gadget ;
-
-: world-flags SDL_HWSURFACE SDL_RESIZABLE bitor ;
-
-: start-world ( w h -- )
+: start-world ( -- )
#! Start the Factor graphics subsystem with the given screen
#! dimensions.
- 2dup init-world 0 world-flags
- default-paint [ [ run-world ] with-screen ] bind ;
+ t world get set-world-running?
+ world get shape-w world get shape-h 0 SDL_RESIZABLE
+ [
+ 0 x set
+ 0 y set
+ [ run-world ] with-screen
+ ] with-scope ;
-global [ <world> world set ] bind
+global [
+ <world> world set
+ 640 480 world get resize-gadget
+ {{
+ [[ background [ 216 216 216 ] ]]
+ [[ foreground [ 0 0 0 ] ]]
+ [[ bevel-1 [ 240 240 240 ] ]]
+ [[ bevel-2 [ 192 192 192 ] ]]
+ [[ bevel-up? t ]]
+ [[ font [[ "Monospaced" 12 ]] ]]
+ }} world get set-gadget-paint
+] bind
projects / factor.git / commitdiff