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

removed boxes; all gadgets can contain children now

cvs
Slava Pestov 2005-02-03 23:18:47 +00:00
parent 5791ae2e42
commit 3e4d15c835
7 changed files with 105 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -153,9 +153,8 @@ cpu "x86" = [
"/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/paint.factor"
"/library/ui/gestures.factor"
"/library/ui/hand.factor"
"/library/ui/world.factor"

60
library/ui/boxes.factor
View File

@ -1,60 +0,0 @@
! 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 children delegate ;
C: box ( gadget -- box )
[ set-box-delegate ] keep ;
M: box gadget-children box-children ;
M: box draw-shape ( box -- )
dup box-delegate draw-gadget
dup [ box-children [ draw-gadget ] each ] 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.
2dup inside? [
2dup [ translate ] keep box-children pick-up dup [
2nip
] [
drop box-delegate pick-up*
] ifte
] [
2drop f
] ifte ;
: box- ( gadget box -- )
[ 2dup box-children remq swap set-box-children ] keep
relayout
f swap set-gadget-parent ;
: (box+) ( gadget box -- )
[ box-children cons ] keep set-box-children ;
: unparent ( gadget -- )
dup gadget-parent dup [ box- ] [ 2drop ] ifte ;
: box+ ( gadget box -- )
#! Add a gadget to a box.
over unparent
dup pick set-gadget-parent
tuck (box+)
relayout ;

72
library/ui/gadgets.factor
View File

@ -6,34 +6,10 @@ USING: generic hashtables kernel lists namespaces ;
! A gadget is a shape, a paint, a mapping of gestures to
! actions, and a reference to the gadget's parent. A gadget
! delegates to its shape.
TUPLE: gadget paint gestures parent relayout? redraw? delegate ;
! Gadget protocol.
GENERIC: pick-up* ( point gadget -- gadget/t )
: pick-up ( point gadget -- gadget )
#! pick-up* returns t to mean 'this gadget', avoiding the
#! exposed facade issue.
tuck pick-up* dup t = [ drop ] [ nip ] ifte ;
GENERIC: gadget-children ( gadget -- list )
M: gadget gadget-children drop f ;
GENERIC: layout* ( gadget -- )
M: gadget layout* drop ;
: 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*
] [
drop
] ifte ;
TUPLE: gadget
paint gestures
relayout? redraw?
parent children delegate ;
C: gadget ( shape -- gadget )
[ set-gadget-delegate ] keep
@ -54,30 +30,26 @@ C: gadget ( shape -- gadget )
: set-action ( gadget quot gesture -- )
rot gadget-gestures set-hash ;
: draw-gadget ( gadget -- )
#! All drawing done inside draw-shape is done with the
#! gadget's paint. If the gadget does not have any custom
#! paint, just call the quotation.
dup gadget-paint [ draw-shape ] bind ;
M: gadget pick-up* inside? ;
: 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 ;
: resize-gadget ( w h gadget -- )
[ resize-shape ] keep redraw ;
: box- ( gadget box -- )
[ 2dup gadget-children remq swap set-gadget-children ] keep
relayout
f swap set-gadget-parent ;
: (box+) ( gadget box -- )
[ gadget-children cons ] keep set-gadget-children ;
: unparent ( gadget -- )
dup gadget-parent dup [ box- ] [ 2drop ] ifte ;
: box+ ( gadget box -- )
#! Add a gadget to a box.
over unparent
dup pick set-gadget-parent
tuck (box+)
relayout ;

38
library/ui/hand.factor
View File

@ -4,7 +4,41 @@ IN: gadgets
USING: alien generic kernel lists math namespaces sdl sdl-event
sdl-video ;
SYMBOL: world
DEFER: pick-up*
: pick-up-list ( point list -- gadget )
dup [
2dup car pick-up dup [
2nip
] [
drop cdr pick-up-list
] ifte
] [
2drop f
] ifte ;
: pick-up* ( point gadget -- gadget/t )
#! 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.
2dup inside? [
2dup [ translate ] keep
gadget-children pick-up-list dup [
2nip
] [
drop inside?
] ifte
] [
2drop f
] ifte ;
: pick-up ( point gadget -- gadget )
#! pick-up* returns t to mean 'this gadget', avoiding the
#! exposed facade issue.
tuck pick-up* dup t = [ drop ] [ nip ] ifte ;
DEFER: world
! The hand is a special gadget that holds mouse position and
! mouse button click state. The hand's parent is the world, but
@ -13,7 +47,7 @@ SYMBOL: world
TUPLE: hand click-pos clicked buttons delegate ;
C: hand ( world -- hand )
0 0 <point> <gadget> <box>
0 0 <point> <gadget>
over set-hand-delegate
[ set-gadget-parent ] keep ;

32
library/ui/layouts.factor
View File

@ -3,11 +3,14 @@
IN: gadgets
USING: generic hashtables kernel lists math namespaces ;
GENERIC: layout* ( gadget -- )
M: gadget layout* drop ;
! A pile is a box that lays out its contents vertically.
TUPLE: pile delegate ;
C: pile ( gadget -- pile )
[ >r <box> r> set-pile-delegate ] keep ;
C: pile ( shape -- pile )
[ >r <gadget> r> set-pile-delegate ] keep ;
M: pile layout* ( pile -- )
dup gadget-children run-heights >r >r
@ -19,8 +22,8 @@ M: pile layout* ( pile -- )
! A shelf is a box that lays out its contents horizontally.
TUPLE: shelf delegate ;
C: shelf ( gadget -- pile )
[ >r <box> r> set-shelf-delegate ] keep ;
C: shelf ( shape -- pile )
[ >r <gadget> r> set-shelf-delegate ] keep ;
M: shelf layout* ( pile -- )
dup gadget-children run-widths >r >r
@ -28,3 +31,24 @@ M: shelf layout* ( pile -- )
gadget-children r> zip [
uncons 0 rot move-gadget
] each ;
: 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*
] [
drop
] ifte ;

17
library/ui/paint.factor
View File

@ -84,3 +84,20 @@ M: bevel-rect draw-shape ( rect -- )
[[ 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
#! paint, just call the quotation.
dup gadget-paint [
dup draw-shape
dup [
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* ;

3
library/ui/world.factor
View File

@ -11,8 +11,7 @@ TUPLE: world running? hand delegate ;
: <world-box> ( -- box )
0 0 0 0 <plain-rect> <everywhere> <gadget>
dup [ 216 216 216 ] color set-paint-property
<box> ;
dup [ 216 216 216 ] color set-paint-property ;
C: world ( -- world )
<world-box> over set-world-delegate