buttons now update their appearance when pressed
Slava Pestov
parent
68c98205bc
commit
3ba50f6665
|
|
@ -157,9 +157,9 @@ cpu "x86" = [
|
|||
"/library/ui/paint.factor"
|
||||
"/library/ui/gestures.factor"
|
||||
"/library/ui/hand.factor"
|
||||
"/library/ui/layouts.factor"
|
||||
"/library/ui/world.factor"
|
||||
"/library/ui/labels.factor"
|
||||
"/library/ui/layouts.factor"
|
||||
"/library/ui/events.factor"
|
||||
] [
|
||||
dup print
|
||||
|
|
|
|||
|
|
@ -234,8 +234,8 @@ BEGIN-UNION: event
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -59,7 +59,8 @@ SYMBOL: surface
|
|||
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
|
||||
|
|
@ -73,11 +74,11 @@ SYMBOL: surface
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,17 @@
|
|||
! 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 ;
|
||||
|
|
@ -121,11 +121,11 @@ SYMBOL: redraw-console
|
|||
|
||||
: 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 [
|
||||
|
|
@ -142,7 +142,7 @@ SYMBOL: redraw-console
|
|||
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 ;
|
||||
|
|
@ -169,7 +169,7 @@ SYMBOL: redraw-console
|
|||
scrollbar-top
|
||||
width get
|
||||
scrollbar-bottom
|
||||
black rgb boxColor ;
|
||||
black 3list rgb boxColor ;
|
||||
|
||||
: draw-console ( -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -30,6 +30,20 @@ C: gadget ( shape -- gadget )
|
|||
: 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ IN: gadgets
|
|||
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 [
|
||||
|
|
@ -27,7 +27,7 @@ DEFER: pick-up*
|
|||
gadget-children pick-up-list dup [
|
||||
2nip
|
||||
] [
|
||||
drop inside?
|
||||
3drop t
|
||||
] ifte
|
||||
] [
|
||||
2drop f
|
||||
|
|
|
|||
|
|
@ -23,5 +23,5 @@ M: label draw-shape ( label -- )
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -6,23 +6,17 @@ USING: generic hashtables kernel lists math namespaces ;
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -7,7 +7,14 @@ USING: generic kernel lists math namespaces sdl sdl-gfx ;
|
|||
! 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 )
|
||||
|
|
@ -16,15 +23,13 @@ SYMBOL: font ! a list of two elements, a font name and size.
|
|||
[ 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 ;
|
||||
|
||||
|
|
@ -32,7 +37,8 @@ C: hollow-rect ( x y w h -- rect )
|
|||
[ >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 ;
|
||||
|
||||
|
|
@ -40,7 +46,8 @@ C: plain-rect ( x y w h -- rect )
|
|||
[ >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 ;
|
||||
|
|
@ -54,11 +61,17 @@ M: plain-rect draw-shape ( rect -- )
|
|||
: 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 ;
|
||||
|
|
@ -77,14 +90,6 @@ C: bevel-rect ( bevel x y w h -- rect )
|
|||
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
|
||||
|
|
@ -95,9 +100,3 @@ M: bevel-rect draw-shape ( rect -- )
|
|||
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* ;
|
||||
|
|
|
|||
|
|
@ -105,7 +105,3 @@ M: rectangle resize-shape ( w h rect -- )
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -10,14 +10,15 @@ sdl-video ;
|
|||
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 ( -- )
|
||||
|
|
@ -25,7 +26,7 @@ C: world ( -- world )
|
|||
[
|
||||
f over set-gadget-redraw?
|
||||
dup draw-gadget
|
||||
world-hand draw-gadget
|
||||
dup gadget-paint [ world-hand draw-gadget ] bind
|
||||
] with-surface
|
||||
] [
|
||||
drop
|
||||
|
|
@ -35,25 +36,45 @@ DEFER: handle-event
|
|||
|
||||
: 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
|
||||
|
|
|
|||
Loading…
Reference in New Issue