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

buttons now update their appearance when pressed

cvs
Slava Pestov 2005-02-04 03:21:51 +00:00
parent 68c98205bc
commit 3ba50f6665
12 changed files with 112 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

4
library/sdl/sdl-event.factor
View File

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

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

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

17
library/ui/buttons.factor Normal file
View File

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

8
library/ui/console.factor
View File

@ -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 ( -- )
[

14
library/ui/gadgets.factor
View File

@ -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
library/ui/hand.factor
View File

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

2
library/ui/labels.factor
View File

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

10
library/ui/layouts.factor
View File

@ -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? [
dup gadget-paint [
f over set-gadget-relayout?
dup gadget-children [ layout ] each
layout*
] bind
] [
drop
] ifte ;

47
library/ui/paint.factor
View File

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

4
library/ui/shapes.factor
View File

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

51
library/ui/world.factor
View File

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