diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index baa352b993..d53f2ca57c 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -2,15 +2,14 @@ --- - i/o: don't keep creating new sbufs -- rollovers broken with menus -- menu dragging -- fix up the min thumb size hack -- gaps in pack layout - fix listener prompt display after presentation commands invoked - theme abstraction in ui + ui: +- menu dragging +- fix up the min thumb size hack +- gaps in pack layout - find out why so many small bignums get consed - repaint only dirty regions of the screen - faster mouse tracking diff --git a/library/help/tutorial.factor b/library/help/tutorial.factor index 2b93f7e1d2..04d2a9d546 100644 --- a/library/help/tutorial.factor +++ b/library/help/tutorial.factor @@ -333,4 +333,4 @@ M: general-list tutorial-line ; : tutorial ( -- ) - ensure-ui gadget. ; + gadget. ; diff --git a/library/ui/gestures.factor b/library/ui/gestures.factor index 723ecf6b81..5aa5f8cc97 100644 --- a/library/ui/gestures.factor +++ b/library/ui/gestures.factor @@ -35,42 +35,8 @@ SYMBOL: motion SYMBOL: drag SYMBOL: button-up SYMBOL: button-down +SYMBOL: mouse-enter +SYMBOL: mouse-leave -: hierarchy-gesture ( gadget ? gesture -- ? ) - swap [ 2drop f ] [ swap handle-gesture* drop t ] ifte ; - -: mouse-enter ( point gadget -- ) - #! If the old point is inside the new gadget, do not fire an - #! enter gesture, since the mouse did not enter. Otherwise, - #! fire an enter gesture and go on to the parent. - [ - [ rectangle-loc v+ ] keep - 2dup inside? [ mouse-enter ] hierarchy-gesture - ] each-parent 2drop ; - -: mouse-leave ( point gadget -- ) - #! If the new point is inside the old gadget, do not fire a - #! leave gesture, since the mouse did not leave. Otherwise, - #! fire a leave gesture and go on to the parent. - [ - [ rectangle-loc v+ ] keep - 2dup inside? [ mouse-leave ] hierarchy-gesture - ] each-parent 2drop ; - -: lose-focus ( new old -- ) - #! If the old focus owner is a child of the new owner, do - #! not fire a focus lost gesture, since the focus was not - #! lost. Otherwise, fire a focus lost gesture and go to the - #! parent. - [ - 2dup child? [ lose-focus ] hierarchy-gesture - ] each-parent 2drop ; - -: gain-focus ( old new -- ) - #! If the old focus owner is a child of the new owner, do - #! not fire a focus gained gesture, since the focus was not - #! gained. Otherwise, fire a focus gained gesture and go on - #! to the parent. - [ - 2dup child? [ gain-focus ] hierarchy-gesture - ] each-parent 2drop ; +SYMBOL: lose-focus +SYMBOL: gain-focus diff --git a/library/ui/hand.factor b/library/ui/hand.factor index 0d25f5ec7e..5ae0926f8d 100644 --- a/library/ui/hand.factor +++ b/library/ui/hand.factor @@ -46,16 +46,7 @@ C: hand ( world -- hand ) : button\ ( n hand -- ) [ hand-buttons remove ] keep set-hand-buttons ; -: fire-leave ( hand gadget -- ) - [ swap rectangle-loc swap screen-loc v- ] keep mouse-leave ; - -: fire-enter ( oldpos hand -- ) - hand-gadget [ screen-loc v- ] keep mouse-enter ; - -: update-hand-gadget ( hand -- ) - [ rectangle-loc world get pick-up ] keep set-hand-gadget ; - -: motion-gesture ( hand gadget gesture -- ) +: drag-gesture ( hand gadget gesture -- ) #! Send a gesture like [ drag 2 ]. rot hand-buttons car add swap handle-gesture drop ; @@ -65,24 +56,36 @@ C: hand ( world -- hand ) #! gadget that was clicked. [ motion ] over hand-gadget handle-gesture drop dup hand-buttons - [ dup hand-clicked [ drag ] motion-gesture ] [ drop ] ifte ; + [ dup hand-clicked [ drag ] drag-gesture ] [ drop ] ifte ; + +: drop-prefix ( l1 l2 -- l1 l2 ) + 2dup and [ 2dup 2car eq? [ 2cdr drop-prefix ] when ] when ; + +: each-gesture ( gesture seq -- ) + [ handle-gesture* drop ] each-with ; + +: hand-gestures ( hand new old -- ) + drop-prefix + reverse [ mouse-leave ] swap each-gesture + swap fire-motion + [ mouse-enter ] swap each-gesture ; : move-hand ( loc hand -- ) - dup rectangle-loc >r - [ set-rectangle-loc ] keep - dup hand-gadget >r - dup update-hand-gadget - dup r> fire-leave - dup fire-motion - r> swap fire-enter ; + dup hand-gadget parents-down >r + 2dup set-rectangle-loc + [ >r world get pick-up r> set-hand-gadget ] keep + dup hand-gadget parents-down r> hand-gestures ; : update-hand ( hand -- ) #! Called when a gadget is removed or added. dup rectangle-loc swap move-hand ; +: focus-gestures ( new old -- ) + drop-prefix + reverse [ lose-focus ] swap each-gesture + [ gain-focus ] swap each-gesture ; + : request-focus ( gadget -- ) focusable-child - hand hand-focus - 2dup lose-focus - swap dup hand set-hand-focus - gain-focus ; + hand dup hand-focus parents-down >r + dupd set-hand-focus parents-down r> focus-gestures ; diff --git a/library/ui/hierarchy.factor b/library/ui/hierarchy.factor index 7fe2d8f21d..e57bf5717c 100644 --- a/library/ui/hierarchy.factor +++ b/library/ui/hierarchy.factor @@ -35,27 +35,31 @@ sequences vectors ; #! Add a gadget to a parent gadget. [ (add-gadget) ] keep relayout ; -: parents ( gadget -- list ) +: (parents-down) ( list gadget -- list ) + [ [ swons ] keep gadget-parent (parents-down) ] when* ; + +: parents-down ( gadget -- list ) + #! A list of all parents of the gadget, the last element + #! is the gadget itself. + f swap (parents-down) ; + +: parents-up ( gadget -- list ) #! A list of all parents of the gadget, the first element #! is the gadget itself. - dup [ dup gadget-parent parents cons ] when ; + dup [ dup gadget-parent parents-up cons ] when ; : each-parent ( gadget quot -- ? ) - >r parents r> all? ; inline + >r parents-up r> all? ; inline : find-parent ( gadget quot -- ? ) - >r parents r> find nip ; inline + >r parents-up r> find nip ; inline : screen-loc ( gadget -- point ) #! The position of the gadget on the screen. - parents { 0 0 0 } [ rectangle-loc v+ ] reduce ; + parents-up { 0 0 0 } [ rectangle-loc v+ ] reduce ; : relative ( g1 g2 -- g2-g1 ) screen-loc swap screen-loc v- ; : child? ( parent child -- ? ) - dup [ - 2dup eq? [ 2drop t ] [ gadget-parent child? ] ifte - ] [ - 2drop f - ] ifte ; + parents-down memq? ; diff --git a/library/ui/presentations.factor b/library/ui/presentations.factor index 5dc9e3e2bd..4b785ac644 100644 --- a/library/ui/presentations.factor +++ b/library/ui/presentations.factor @@ -43,14 +43,15 @@ global [ 100 commands set ] bind [ 2nip ] [ drop dup init-commands ] ifte ; : gadget. ( gadget -- ) - gadget swons unit "" swap write-attr terpri ; + gadget swons unit + "This stream does not support live gadgets" + swap write-attr terpri ; [ drop t ] "Prettyprint" [ prettyprint ] define-command [ drop t ] "Inspect" [ inspect ] define-command [ drop t ] "References" [ references inspect ] define-command [ word? ] "See" [ see ] define-command -[ word? ] "Execute" [ execute ] define-command [ word? ] "Usage" [ usage . ] define-command [ word? ] "jEdit" [ jedit ] define-command diff --git a/library/ui/scrolling.factor b/library/ui/scrolling.factor index 929fdd4cb4..3fa081b316 100644 --- a/library/ui/scrolling.factor +++ b/library/ui/scrolling.factor @@ -5,9 +5,14 @@ USING: generic kernel lists math matrices namespaces sequences threads vectors styles ; ! A viewport can be scrolled. - TUPLE: viewport origin bottom? ; +! A slider scrolls a viewport. +TUPLE: slider thumb vector ; + +! A scroller combines a viewport with two x and y sliders. +TUPLE: scroller viewport x y ; + : viewport-dim gadget-child pref-dim ; : fix-scroll ( origin viewport -- origin ) @@ -46,12 +51,6 @@ M: viewport focusable-child* ( viewport -- gadget ) swap viewport-dim { 1 1 1 } vmax v/ { 1 1 1 } vmin ; -! A slider scrolls a viewport. - -! The offset slot is the y co-ordinate of the mouse relative to -! the thumb when it was clicked. -TUPLE: slider thumb vector ; - : slider-scroller ( slider -- scroller ) [ scroller? ] find-parent ; @@ -128,8 +127,6 @@ M: slider layout* ( slider -- ) dup thumb-dim over slider-vector v* slider-dim vmax swap slider-thumb set-gadget-dim ; -TUPLE: scroller viewport x y ; - : add-viewport 2dup set-scroller-viewport add-center ; : add-x-slider 2dup set-scroller-x add-bottom ; diff --git a/library/ui/world.factor b/library/ui/world.factor index cb46e1d402..dbf61c7001 100644 --- a/library/ui/world.factor +++ b/library/ui/world.factor @@ -12,10 +12,10 @@ vectors ; TUPLE: world running? hand glass invalid ; DEFER: +DEFER: update-hand C: world ( -- world ) f over set-delegate - t over set-world-running? t over set-gadget-root? dup over set-world-hand ; @@ -54,7 +54,7 @@ DEFER: handle-event : world-step ( -- ? ) world get dup world-invalid >r layout-world r> - [ hand update-hand draw-world ] [ drop ] ifte ; + [ dup world-hand update-hand draw-world ] [ drop ] ifte ; : next-event ( -- event ? ) dup SDL_PollEvent ; @@ -69,11 +69,5 @@ DEFER: handle-event world get world-running? [ yield run-world ] when ] ifte ; -: ensure-ui ( -- ) - #! Raise an error if the UI is not running. - world get dup [ world-running? ] when [ - "UI not running." throw - ] unless ; - : start-world ( -- ) world get t over set-world-running? relayout ;