uncons >r cons r> cons ;
: deque ( queue -- obj queue )
- uncons [
- uncons swapd cons
- ] [
- reverse uncons f swons
- ] ifte* ;
+ uncons
+ [ uncons swapd cons ] [ reverse uncons f swons ] ifte* ;
IN: temporary
-USING: kernel lists test ;
+USING: kernel lists math sequences test ;
[ [ 1 2 3 4 5 ] ] [
<queue> [ 1 2 3 4 5 ] [ swap enque ] each
5 [ drop deque swap ] project nip
] unit-test
+
+[ [ 1 4 9 16 25 ] ] [
+ <queue> [ 1 2 3 4 5 ] [ swap enque ] each
+ [ sq ] que-map
+ 5 [ drop deque swap ] project nip
+] unit-test
: tests
[
"lists/cons" "lists/lists" "lists/assoc"
- "lists/namespaces" "lists/combinators" "combinators"
+ "lists/namespaces" "lists/combinators" "lists/queues"
+ "combinators"
"continuations" "errors" "hashtables" "strings"
"namespaces" "generic" "tuple" "files" "parser"
"parse-number" "image" "init" "io/io"
0 0 0 0 <etched-rect> <gadget> { 5 5 0 } <border> ;
: layout-border-loc ( border -- )
- dup border-size swap gadget-child set-gadget-loc ;
+ dup border-size swap gadget-child set-shape-loc ;
: layout-border-dim ( border -- )
dup shape-dim over border-size 2 v*n v-
: offset>x ( gadget offset str -- x )
head >r gadget-font r> size-string drop ;
-: caret-pos ( editor -- x y )
- dup editor-line [ caret get line-text get ] bind offset>x 0 ;
+: caret-loc ( editor -- x y )
+ dup editor-line [ caret get line-text get ] bind offset>x
+ 0 0 3vector ;
-: caret-size ( editor -- w h )
- 1 swap shape-h ;
+: caret-dim ( editor -- w h )
+ shape-dim { 0 1 1 } v* { 1 0 0 } v+ ;
M: editor user-input* ( ch editor -- ? )
[ [ insert-char ] with-editor ] keep
dup editor-text label-size { 1 0 0 } v+ ;
M: editor layout* ( editor -- )
- dup editor-caret over caret-size rot resize-gadget
- dup editor-caret swap caret-pos rot move-gadget ;
+ dup editor-caret over caret-dim swap set-gadget-dim
+ dup editor-caret swap caret-loc swap set-shape-loc ;
M: editor draw-shape ( editor -- )
[ dup gadget-font swap editor-text ] keep
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: alien generic kernel lists math namespaces prettyprint
-sdl sequences ;
+sdl sequences vectors ;
GENERIC: handle-event ( event -- )
M: resize-event handle-event ( event -- )
dup resize-event-w swap resize-event-h
- [ world get resize-gadget ] 2keep
+ [ 0 3vector world get set-gadget-dim ] 2keep
0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen
world get relayout ;
var-frame-bottom ;
: reshape-gadget ( x y w h gadget -- )
- [ resize-gadget ] keep move-gadget ;
+ [ >r 0 3vector r> set-gadget-dim ] keep move-gadget ;
: pos-frame-center
>r \ frame-left get \ frame-top get
! 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 relayout? redraw? parent children ;
+TUPLE: gadget
+ paint gestures
+ relayout? redraw? root?
+ parent children ;
: gadget-child gadget-children car ;
C: gadget ( shape -- gadget )
[ set-delegate ] keep
- [ <namespace> swap set-gadget-paint ] keep
- [ <namespace> swap set-gadget-gestures ] keep
- [ t swap set-gadget-relayout? ] keep
- [ t swap set-gadget-redraw? ] keep ;
+ <namespace> over set-gadget-paint
+ <namespace> over set-gadget-gestures ;
: <empty-gadget> ( -- gadget ) 0 0 0 0 <rectangle> <gadget> ;
: <plain-gadget> ( -- gadget ) 0 0 0 0 <plain-rect> <gadget> ;
-: redraw ( gadget -- )
- #! Redraw a gadget before the next iteration of the event
- #! loop.
- dup gadget-redraw? [
- drop
- ] [
- t over set-gadget-redraw?
- gadget-parent [ redraw ] when*
- ] ifte ;
+DEFER: relayout
+DEFER: add-invalid
+
+: invalidate ( gadget -- )
+ t over set-gadget-redraw?
+ t swap set-gadget-relayout? ;
: relayout ( gadget -- )
#! Relayout and redraw a gadget and its parent before the
dup gadget-relayout? [
drop
] [
- t over set-gadget-redraw?
- t over set-gadget-relayout?
- gadget-parent [ relayout ] when*
+ dup invalidate
+ dup gadget-root?
+ [ world get add-invalid ]
+ [ gadget-parent [ relayout ] when* ] ifte
] ifte ;
-: relayout* ( gadget -- )
+: relayout-down ( gadget -- )
#! Relayout a gadget and its children.
- dup relayout gadget-children [ relayout* ] each ;
-
-: set-gadget-loc ( loc gadget -- )
- 2dup shape-loc =
- [ 2drop ] [ [ set-shape-loc ] keep redraw ] ifte ;
+ dup world get add-invalid
+ dup invalidate gadget-children [ relayout-down ] each ;
: move-gadget ( x y gadget -- )
- >r 0 3vector r> set-gadget-loc ;
+ >r 0 3vector r> set-shape-loc ;
: set-gadget-dim ( dim gadget -- )
2dup shape-dim =
- [ 2drop ] [ [ set-shape-dim ] keep relayout* ] ifte ;
-
-: resize-gadget ( w h gadget -- )
- >r 0 3vector r> set-gadget-dim ;
+ [ 2drop ] [ [ set-shape-dim ] keep relayout-down ] ifte ;
: paint-prop ( gadget key -- value )
over [
: incremental-loc ( gadget incremental -- )
dup incremental-cursor dup rot pack-vector v* v-
- swap set-gadget-loc ;
+ swap set-shape-loc ;
: add-incremental ( gadget incremental -- )
- ( 2dup add-gadget ) ( over prefer ) f over set-gadget-relayout?
- ( 2dup incremental-loc ) ( update-cursor ) 2drop ;
+ 2dup add-gadget
+ >r dup dup pref-dim swap set-shape-dim r>
+ f over set-gadget-relayout?
+ 2dup incremental-loc update-cursor ;
: packed-locs ( gadget sizes -- )
over gadget-children >r (packed-locs) r>
- zip [ uncons set-gadget-loc ] each ;
+ zip [ uncons set-shape-loc ] each ;
: packed-layout ( gadget sizes -- )
2dup packed-locs packed-dims ;
IN: gadgets
USING: generic kernel lists math namespaces sequences ;
-: hide-menu ( -- )
- world get
- dup hide-glass
- [ world-menu unparent f ] keep set-world-menu ;
-
: show-menu ( menu -- )
- hide-menu
- world get
- 2dup set-world-menu
- 2dup world-hand screen-loc swap set-gadget-loc
+ hide-glass
+ hand screen-loc over set-shape-loc
show-glass ;
: menu-item-border ( child -- border )
TUPLE: menu ;
: menu-actions ( menu -- )
- [ drop hide-menu ] [ button-down 1 ] set-action ;
+ [ drop world get hide-glass ] [ button-down 1 ] set-action ;
: assoc>menu ( assoc menu -- )
#! Given an association list mapping labels to quotations.
USING: generic hashtables kernel lists math namespaces sdl
io strings sequences ;
+: redraw ( gadget -- )
+ #! Redraw a gadget before the next iteration of the event
+ #! loop.
+ dup gadget-redraw? [
+ drop
+ ] [
+ t over set-gadget-redraw?
+ gadget-parent [ redraw ] when*
+ ] ifte ;
+
! Clipping
SYMBOL: clip
[ over pane-terpri pane-write ] [ 3drop ] ifte ;
! Panes are streams.
-M: pane stream-flush ( stream -- ) relayout ;
+M: pane stream-flush ( stream -- ) drop ;
-M: pane stream-auto-flush ( stream -- ) stream-flush ;
+M: pane stream-auto-flush ( stream -- ) drop ;
M: pane stream-readln ( stream -- line )
[ over set-pane-continuation stop ] callcc1 nip ;
[ fix-scroll ] keep [ set-viewport-origin ] keep relayout ;
C: viewport ( content -- viewport )
- [ <empty-gadget> swap set-delegate ] keep
+ <empty-gadget> over set-delegate
+ t over set-gadget-root?
[ add-gadget ] keep
{ 0 0 0 } over set-viewport-origin ;
M: viewport layout* ( viewport -- )
dup viewport-origin
- swap gadget-child dup prefer set-gadget-loc ;
+ swap gadget-child dup prefer set-shape-loc ;
M: viewport focusable-child* ( viewport -- gadget )
gadget-child ;
: <thumb> ( -- thumb )
<plain-gadget>
+ t over set-gadget-root?
dup gray background set-paint-prop
dup thumb-actions ;
M: slider layout* ( slider -- )
dup thumb-loc over slider-vector v*
- over slider-thumb set-gadget-loc
+ over slider-thumb set-shape-loc
dup thumb-dim over slider-vector v* slider-dim vmax
swap slider-thumb set-gadget-dim ;
! The world gadget is the top level gadget that all (visible)
! gadgets are contained in. The current world is stored in the
-! world variable. The menu slot ensures that only one menu is
-! open at any one time.
-TUPLE: world running? hand menu glass ;
+! world variable. The invalid slot is a list of gadgets that
+! need to be layout.
+TUPLE: world running? hand glass invalid ;
C: world ( -- world )
f <stack> over set-delegate
t over set-world-running?
+ t over set-gadget-root?
dup <hand> over set-world-hand ;
+: add-invalid ( gadget world -- )
+ [ world-invalid cons ] keep set-world-invalid ;
+
+: pop-invalid ( world -- list )
+ [ world-invalid f ] keep set-world-invalid ;
+
+: layout-world ( world -- )
+ dup world-invalid [
+ dup pop-invalid [ layout ] each layout-world
+ ] [
+ drop
+ ] ifte ;
+
: add-layer ( gadget -- )
world get add-gadget ;
-: show-glass ( gadget world -- )
- >r <empty-gadget> [ add-gadget ] keep
- r> 2dup set-world-glass add-gadget ;
+: show-glass ( gadget -- )
+ <empty-gadget> dup
+ world get 2dup add-gadget set-world-glass
+ add-gadget ;
-: hide-glass ( world -- )
- [ world-glass unparent f ] keep set-world-glass ;
+: hide-glass ( -- )
+ world get world-glass unparent f
+ world get set-world-glass ;
M: world inside? ( point world -- ? ) 2drop t ;
: draw-world ( world -- )
dup gadget-redraw? [
- [ draw-gadget ] with-surface
+ [
+ dup 0 0 width get height get <rectangle> clip set-paint-prop
+ draw-gadget
+ ] with-surface
] [
drop
] ifte ;
DEFER: handle-event
-: layout-world ( world -- )
- dup
- 0 0 width get height get <rectangle> clip set-paint-prop
- layout ;
-
: world-step ( world -- ? )
world get dup world-running? [
dup layout-world draw-world t