diff --git a/library/ui/borders.factor b/library/ui/borders.factor index 4b0c7e74cf..28b3f9edf1 100644 --- a/library/ui/borders.factor +++ b/library/ui/borders.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets-borders -USING: errors gadgets generic hashtables kernel lists math -namespaces sdl vectors ; +USING: errors gadgets gadgets-layouts generic hashtables kernel +math namespaces vectors ; TUPLE: border size ; diff --git a/library/ui/buttons.factor b/library/ui/buttons.factor index 76520d2999..a2897f8376 100644 --- a/library/ui/buttons.factor +++ b/library/ui/buttons.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets-buttons -USING: gadgets gadgets-borders generic io kernel lists math -namespaces sdl sequences sequences styles threads ; +USING: gadgets gadgets-borders gadgets-layouts generic io kernel +lists math namespaces sdl sequences sequences styles threads ; : button-down? ( n -- ? ) hand hand-buttons member? ; diff --git a/library/ui/editors.factor b/library/ui/editors.factor index 8878f0c3b0..a5ce33cd73 100644 --- a/library/ui/editors.factor +++ b/library/ui/editors.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets-editors -USING: gadgets gadgets-labels gadgets-scrolling generic kernel -math namespaces sdl sequences strings styles threads vectors ; +USING: gadgets gadgets-labels gadgets-layouts gadgets-scrolling +generic kernel math namespaces sdl sequences strings styles +threads vectors ; ! A blinking caret TUPLE: caret ; diff --git a/library/ui/events.factor b/library/ui/events.factor index 92e9a3f923..7cca968236 100644 --- a/library/ui/events.factor +++ b/library/ui/events.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: alien generic kernel lists math namespaces prettyprint -sdl sequences vectors ; +USING: alien gadgets-layouts generic kernel lists math +namespaces sdl sequences vectors ; GENERIC: handle-event ( event -- ) diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index a67175f105..61460ce911 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -43,31 +43,34 @@ C: gadget ( -- gadget ) { 0 0 0 } dup over set-delegate t over set-gadget-visible? ; -DEFER: add-invalid +GENERIC: user-input* ( ch gadget -- ? ) + +M: gadget user-input* 2drop t ; : invalidate ( gadget -- ) t swap set-gadget-relayout? ; -: relayout ( gadget -- ) - #! Relayout and redraw a gadget and its parent before the - #! next iteration of the event loop. - dup gadget-relayout? [ - drop - ] [ - dup invalidate - dup gadget-root? - [ add-invalid ] - [ gadget-parent [ relayout ] when* ] ifte - ] ifte ; +DEFER: add-invalid -: relayout-down ( gadget -- ) - #! Relayout a gadget and its children. - dup add-invalid invalidate ; +GENERIC: children-on ( rect/point gadget -- list ) -: set-gadget-dim ( dim gadget -- ) - 2dup rect-dim = - [ 2drop ] [ [ set-rect-dim ] keep relayout-down ] ifte ; +M: gadget children-on ( rect/point gadget -- list ) + nip gadget-children ; -GENERIC: user-input* ( ch gadget -- ? ) +: inside? ( bounds gadget -- ? ) + dup gadget-visible? + [ >absolute intersects? ] [ 2drop f ] ifte ; -M: gadget user-input* 2drop t ; +: pick-up-list ( rect/point gadget -- gadget/f ) + dupd children-on reverse-slice [ inside? ] find-with nip ; + +: translate ( rect/point -- ) + rect-loc origin [ v+ ] change ; + +: pick-up ( rect/point gadget -- gadget ) + 2dup inside? [ + [ + dup translate 2dup pick-up-list dup + [ nip pick-up ] [ rot 2drop ] ifte + ] with-scope + ] [ 2drop f ] ifte ; diff --git a/library/ui/hierarchy.factor b/library/ui/hierarchy.factor index 71d42be963..8b83b1ec95 100644 --- a/library/ui/hierarchy.factor +++ b/library/ui/hierarchy.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: generic hashtables kernel lists math matrices namespaces -sequences vectors ; +USING: gadgets-layouts generic hashtables kernel lists math +namespaces sequences vectors ; : remove-gadget ( gadget parent -- ) 2dup gadget-children remove over set-gadget-children @@ -77,26 +77,3 @@ M: gadget focusable-child* drop t ; : focusable-child ( gadget -- gadget ) dup focusable-child* dup t = [ drop ] [ nip focusable-child ] ifte ; - -GENERIC: children-on ( rect/point gadget -- list ) - -M: gadget children-on ( rect/point gadget -- list ) - nip gadget-children ; - -: inside? ( bounds gadget -- ? ) - dup gadget-visible? - [ >absolute intersects? ] [ 2drop f ] ifte ; - -: pick-up-list ( rect/point gadget -- gadget/f ) - dupd children-on reverse-slice [ inside? ] find-with nip ; - -: translate ( rect/point -- ) - rect-loc origin [ v+ ] change ; - -: pick-up ( rect/point gadget -- gadget ) - 2dup inside? [ - [ - dup translate 2dup pick-up-list dup - [ nip pick-up ] [ rot 2drop ] ifte - ] with-scope - ] [ 2drop f ] ifte ; diff --git a/library/ui/labels.factor b/library/ui/labels.factor index 999cf9aaef..03eae35aab 100644 --- a/library/ui/labels.factor +++ b/library/ui/labels.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets-labels -USING: gadgets generic hashtables io kernel lists math +USING: gadgets gadgets-layouts generic hashtables io kernel math namespaces sdl sequences styles vectors ; ! A label gadget draws a string. diff --git a/library/ui/layouts.factor b/library/ui/layouts.factor index f1ac6bb797..1ebef13621 100644 --- a/library/ui/layouts.factor +++ b/library/ui/layouts.factor @@ -4,6 +4,25 @@ IN: gadgets-layouts USING: errors gadgets generic hashtables kernel lists math matrices namespaces sdl sequences ; +: relayout ( gadget -- ) + #! Relayout and redraw a gadget and its parent before the + #! next iteration of the event loop. + dup gadget-relayout? [ + drop + ] [ + dup invalidate + dup gadget-root? + [ add-invalid ] + [ gadget-parent [ relayout ] when* ] ifte + ] ifte ; + +: set-gadget-dim ( dim gadget -- ) + 2dup rect-dim = [ + 2drop + ] [ + [ set-rect-dim ] keep dup add-invalid invalidate + ] ifte ; + GENERIC: pref-dim ( gadget -- dim ) M: gadget pref-dim rect-dim ; diff --git a/library/ui/load.factor b/library/ui/load.factor index 3eae74475c..28cab2bcfe 100644 --- a/library/ui/load.factor +++ b/library/ui/load.factor @@ -1,12 +1,12 @@ USING: kernel parser sequences io ; [ "/library/ui/gadgets.factor" + "/library/ui/layouts.factor" "/library/ui/hierarchy.factor" "/library/ui/paint.factor" "/library/ui/fonts.factor" "/library/ui/text.factor" "/library/ui/gestures.factor" - "/library/ui/layouts.factor" "/library/ui/borders.factor" "/library/ui/frames.factor" "/library/ui/world.factor" diff --git a/library/ui/scrolling.factor b/library/ui/scrolling.factor index d7316cc79a..2ef1abe698 100644 --- a/library/ui/scrolling.factor +++ b/library/ui/scrolling.factor @@ -1,14 +1,14 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets-scrolling -USING: gadgets gadgets-layouts generic kernel lists math -namespaces sequences threads vectors styles ; +USING: gadgets gadgets-books gadgets-layouts generic kernel +lists math namespaces sequences styles threads vectors ; ! A viewport can be scrolled. -TUPLE: viewport ; +TUPLE: viewport bottom? ; ! A scroller combines a viewport with two x and y sliders. -TUPLE: scroller viewport x y bottom? ; +TUPLE: scroller viewport x y ; : scroller-origin ( scroller -- { x y 0 } ) dup scroller-x slider-value @@ -17,6 +17,8 @@ TUPLE: scroller viewport x y bottom? ; : find-scroller [ scroller? ] find-parent ; +: find-viewport [ viewport? ] find-parent ; + : viewport-dim gadget-child pref-dim ; C: viewport ( content -- viewport ) @@ -44,8 +46,12 @@ M: viewport pref-dim gadget-child pref-dim ; : update-scroller ( scroller -- ) dup scroller-origin scroll ; : update-viewport ( viewport scroller -- ) - scroller-origin vneg - swap gadget-child dup prefer set-rect-loc ; + over viewport-bottom? [ + f pick set-viewport-bottom? + over viewport-dim + ] [ + dup scroller-origin + ] ifte vneg nip swap gadget-child dup prefer set-rect-loc ; M: viewport layout* ( viewport -- ) dup find-scroller dup update-scroller update-viewport ; @@ -60,8 +66,8 @@ M: viewport focusable-child* ( viewport -- gadget ) : add-y-slider 2dup set-scroller-y add-right ; : scroll>bottom ( gadget -- ) - find-scroller - [ t over set-scroller-bottom? relayout ] when* ; + find-viewport + [ t over set-viewport-bottom? relayout ] when* ; : scroll-up-line scroller-y -1 swap slide-by-line ; @@ -82,10 +88,3 @@ C: scroller ( gadget -- scroller ) M: scroller focusable-child* ( scroller -- viewport ) scroller-viewport ; - -M: scroller layout* ( scroller -- ) - dup scroller-bottom? [ - f over set-scroller-bottom? - dup dup scroller-viewport viewport-dim - { 0 1 0 } v* scroll - ] when delegate layout* ; diff --git a/library/ui/ui.factor b/library/ui/ui.factor index 360ac9c82d..07371e0fb8 100644 --- a/library/ui/ui.factor +++ b/library/ui/ui.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: gadgets-listener generic help io kernel listener lists -math namespaces prettyprint sdl sequences shells styles threads -words ; +USING: gadgets-layouts gadgets-listener generic help io kernel +listener lists math namespaces prettyprint sdl sequences shells +styles threads words ; : world-theme {{ @@ -19,6 +19,7 @@ words ; }} ; : init-world + ttf-init global [ world set { 600 800 0 } world get set-gadget-dim