diff --git a/library/collections/lists.factor b/library/collections/lists.factor index 853d0f649f..08c4469d7a 100644 --- a/library/collections/lists.factor +++ b/library/collections/lists.factor @@ -160,8 +160,5 @@ M: general-list nth ( n list -- element ) 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* ; diff --git a/library/test/lists/queues.factor b/library/test/lists/queues.factor index bc6f445153..51d12a7169 100644 --- a/library/test/lists/queues.factor +++ b/library/test/lists/queues.factor @@ -1,7 +1,13 @@ IN: temporary -USING: kernel lists test ; +USING: kernel lists math sequences test ; [ [ 1 2 3 4 5 ] ] [ [ 1 2 3 4 5 ] [ swap enque ] each 5 [ drop deque swap ] project nip ] unit-test + +[ [ 1 4 9 16 25 ] ] [ + [ 1 2 3 4 5 ] [ swap enque ] each + [ sq ] que-map + 5 [ drop deque swap ] project nip +] unit-test diff --git a/library/test/test.factor b/library/test/test.factor index c70544a636..8f501ff365 100644 --- a/library/test/test.factor +++ b/library/test/test.factor @@ -76,7 +76,8 @@ SYMBOL: failures : 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" diff --git a/library/ui/borders.factor b/library/ui/borders.factor index 900e8473fa..545d36b41d 100644 --- a/library/ui/borders.factor +++ b/library/ui/borders.factor @@ -15,7 +15,7 @@ C: border ( child delegate size -- border ) 0 0 0 0 { 5 5 0 } ; : 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- diff --git a/library/ui/editors.factor b/library/ui/editors.factor index f114215629..7348e046e9 100644 --- a/library/ui/editors.factor +++ b/library/ui/editors.factor @@ -76,11 +76,12 @@ C: editor ( text -- ) : 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 @@ -90,8 +91,8 @@ M: editor pref-dim ( editor -- dim ) 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 diff --git a/library/ui/events.factor b/library/ui/events.factor index 9065935226..254c4b84a7 100644 --- a/library/ui/events.factor +++ b/library/ui/events.factor @@ -2,7 +2,7 @@ ! 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 -- ) @@ -14,7 +14,7 @@ M: quit-event 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 ; diff --git a/library/ui/frames.factor b/library/ui/frames.factor index aba0a72f09..03aff69aab 100644 --- a/library/ui/frames.factor +++ b/library/ui/frames.factor @@ -83,7 +83,7 @@ SYMBOL: frame-bottom-run 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 diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index b48ba5553d..d3f407d2ee 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -7,30 +7,28 @@ sequences vectors ; ! 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 - [ swap set-gadget-paint ] keep - [ swap set-gadget-gestures ] keep - [ t swap set-gadget-relayout? ] keep - [ t swap set-gadget-redraw? ] keep ; + over set-gadget-paint + over set-gadget-gestures ; : ( -- gadget ) 0 0 0 0 ; : ( -- gadget ) 0 0 0 0 ; -: 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 @@ -38,28 +36,23 @@ C: gadget ( shape -- gadget ) 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 [ diff --git a/library/ui/incremental.factor b/library/ui/incremental.factor index f9ebd47f3e..e5c42a08a2 100644 --- a/library/ui/incremental.factor +++ b/library/ui/incremental.factor @@ -31,8 +31,10 @@ C: incremental ( pack -- incremental ) : 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 ; diff --git a/library/ui/layouts.factor b/library/ui/layouts.factor index 9b7ebfa851..0aaa504a9d 100644 --- a/library/ui/layouts.factor +++ b/library/ui/layouts.factor @@ -54,7 +54,7 @@ TUPLE: pack align fill vector ; : 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 ; diff --git a/library/ui/menus.factor b/library/ui/menus.factor index 0c98419a7a..0e5a4f9cb9 100644 --- a/library/ui/menus.factor +++ b/library/ui/menus.factor @@ -3,16 +3,9 @@ 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 ) @@ -24,7 +17,7 @@ USING: generic kernel lists math namespaces sequences ; 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. diff --git a/library/ui/paint.factor b/library/ui/paint.factor index 4056c6d183..3fd785ac93 100644 --- a/library/ui/paint.factor +++ b/library/ui/paint.factor @@ -4,6 +4,16 @@ IN: gadgets 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 diff --git a/library/ui/panes.factor b/library/ui/panes.factor index 7b660ad37a..12e170e52e 100644 --- a/library/ui/panes.factor +++ b/library/ui/panes.factor @@ -73,9 +73,9 @@ M: pane focusable-child* ( pane -- editor ) [ 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 ; diff --git a/library/ui/scrolling.factor b/library/ui/scrolling.factor index 876e78f52b..5c41dcfb51 100644 --- a/library/ui/scrolling.factor +++ b/library/ui/scrolling.factor @@ -22,7 +22,8 @@ TUPLE: viewport origin ; [ fix-scroll ] keep [ set-viewport-origin ] keep relayout ; C: viewport ( content -- viewport ) - [ swap set-delegate ] keep + over set-delegate + t over set-gadget-root? [ add-gadget ] keep { 0 0 0 } over set-viewport-origin ; @@ -30,7 +31,7 @@ M: viewport pref-dim gadget-child pref-dim ; 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 ; @@ -73,6 +74,7 @@ TUPLE: slider viewport thumb vector ; : ( -- thumb ) + t over set-gadget-root? dup gray background set-paint-prop dup thumb-actions ; @@ -105,7 +107,7 @@ M: slider pref-dim drop slider-dim ; 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 ; diff --git a/library/ui/world.factor b/library/ui/world.factor index c5abb56925..d75445436c 100644 --- a/library/ui/world.factor +++ b/library/ui/world.factor @@ -7,24 +7,40 @@ threads sequences ; ! 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 over set-delegate t over set-world-running? + t over set-gadget-root? dup 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 [ add-gadget ] keep - r> 2dup set-world-glass add-gadget ; +: show-glass ( 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 ; @@ -32,18 +48,16 @@ M: world inside? ( point world -- ? ) 2drop t ; : draw-world ( world -- ) dup gadget-redraw? [ - [ draw-gadget ] with-surface + [ + dup 0 0 width get height get clip set-paint-prop + draw-gadget + ] with-surface ] [ drop ] ifte ; DEFER: handle-event -: layout-world ( world -- ) - dup - 0 0 width get height get clip set-paint-prop - layout ; - : world-step ( world -- ? ) world get dup world-running? [ dup layout-world draw-world t