From 500d7b5331dae72d63b901f5da56eefb465128ca Mon Sep 17 00:00:00 2001 From: slava Date: Sun, 19 Mar 2006 05:30:57 +0000 Subject: [PATCH] Start refactoring hand, add new get-global word --- library/collections/namespaces.factor | 1 + library/threads.factor | 4 +-- library/ui/buttons.factor | 9 +++-- library/ui/editors.factor | 3 +- library/ui/hand.factor | 51 +++++++++++++++------------ library/ui/hierarchy.factor | 4 +-- library/ui/layouts.factor | 2 +- library/ui/menus.factor | 2 +- library/ui/panes.factor | 2 +- library/ui/sliders.factor | 2 +- library/ui/timers.factor | 2 +- library/vocabularies.factor | 2 +- 12 files changed, 48 insertions(+), 36 deletions(-) diff --git a/library/collections/namespaces.factor b/library/collections/namespaces.factor index b950a3392a..3b0859fc68 100644 --- a/library/collections/namespaces.factor +++ b/library/collections/namespaces.factor @@ -15,6 +15,7 @@ sequences strings vectors words ; : set ( value variable -- ) namespace set-hash ; : on ( var -- ) t swap set ; inline : off ( var -- ) f swap set ; inline +: get-global ( var -- value ) global hash ; inline : set-global ( value var -- ) global set-hash ; inline : nest ( variable -- hash ) diff --git a/library/threads.factor b/library/threads.factor index d3a0a21365..a9a901c819 100644 --- a/library/threads.factor +++ b/library/threads.factor @@ -7,11 +7,11 @@ namespaces queues sequences vectors ; ! Co-operative multitasker. -: run-queue ( -- queue ) \ run-queue global hash ; +: run-queue ( -- queue ) \ run-queue get-global ; : schedule-thread ( continuation -- ) run-queue enque ; -: sleep-queue ( -- vec ) \ sleep-queue global hash ; +: sleep-queue ( -- vec ) \ sleep-queue get-global ; : sleep-queue* ( -- vec ) sleep-queue dup [ 2car swap - ] nsort ; diff --git a/library/ui/buttons.factor b/library/ui/buttons.factor index dc974bd383..3cdc875241 100644 --- a/library/ui/buttons.factor +++ b/library/ui/buttons.factor @@ -7,11 +7,14 @@ styles threads ; TUPLE: button rollover? pressed? ; -: button-down? ( -- ? ) hand get hand-buttons empty? not ; +: button-down? ( -- ? ) + hand-buttons get-global empty? not ; -: mouse-over? ( gadget -- ? ) hand get hand-gadget child? ; +: mouse-over? ( gadget -- ? ) + hand-gadget get-global child? ; -: mouse-clicked? ( gadget -- ? ) hand get hand-clicked child? ; +: mouse-clicked? ( gadget -- ? ) + hand-clicked get-global child? ; : button-update ( button -- ) dup mouse-over? over set-button-rollover? diff --git a/library/ui/editors.factor b/library/ui/editors.factor index dcf34b8834..f22072992b 100644 --- a/library/ui/editors.factor +++ b/library/ui/editors.factor @@ -68,7 +68,8 @@ TUPLE: editor line caret font color ; ] with-editor ; : click-editor ( editor -- ) - dup hand get relative first over set-caret-x request-focus ; + dup hand get rect-loc relative-loc + first over set-caret-x request-focus ; : popup-location ( editor -- loc ) dup screen-loc swap editor-caret rect-extent nip v+ ; diff --git a/library/ui/hand.factor b/library/ui/hand.factor index 395fda453a..38ecf75de7 100644 --- a/library/ui/hand.factor +++ b/library/ui/hand.factor @@ -4,6 +4,16 @@ IN: gadgets USING: gadgets-labels gadgets-layouts kernel math namespaces queues sequences ; +! Hand state + +SYMBOL: hand-gadget + +SYMBOL: hand-clicked +SYMBOL: hand-click-loc + +SYMBOL: hand-buttons +V{ } clone hand-buttons set-global + ! The hand is a special gadget that holds mouse position and ! mouse button click state. @@ -11,53 +21,50 @@ queues sequences ; ! - hand-gadget is the gadget under the mouse position ! - hand-clicked is the most recently clicked gadget ! - hand-focus is the gadget holding keyboard focus -TUPLE: hand click-loc click-rel clicked buttons gadget focus ; +TUPLE: hand focus ; C: hand ( -- hand ) - dup delegate>gadget V{ } clone over set-hand-buttons ; + dup delegate>gadget ; hand set-global : button-gesture ( buttons gesture -- ) #! Send a gesture like [ button-down 2 ]; if nobody #! handles it, send [ button-down ]. - swap hand get hand-clicked 3dup >r add r> handle-gesture + swap hand-clicked get-global 3dup >r add r> handle-gesture [ nip handle-gesture drop ] [ 3drop ] if ; : update-clicked ( -- ) - hand get - dup hand-gadget over set-hand-clicked - dup screen-loc over set-hand-click-loc - dup hand-gadget over relative swap set-hand-click-rel ; + hand-gadget get-global hand-clicked set-global + hand get rect-loc hand-click-loc set-global ; : send-button-down ( event -- ) update-clicked - dup hand get hand-buttons push + dup hand-buttons get-global push [ button-down ] button-gesture ; : send-button-up ( event -- ) - dup hand get hand-buttons delete + dup hand-buttons get-global delete [ button-up ] button-gesture ; : send-scroll-wheel ( up/down -- ) [ wheel-up ] [ wheel-down ] ? - hand get hand-gadget handle-gesture drop ; + hand-gadget get-global handle-gesture drop ; : drag-gesture ( -- ) #! Send a gesture like [ drag 2 ]; if nobody handles it, #! send [ drag ]. - hand get hand-buttons first [ drag ] button-gesture ; + hand-buttons get-global first [ drag ] button-gesture ; -: fire-motion ( hand -- ) +: fire-motion ( -- ) #! Fire a motion gesture to the gadget underneath the hand, #! and if a mouse button is down, fire a drag gesture to the #! gadget that was clicked. - [ motion ] over hand-gadget handle-gesture drop - hand-buttons empty? [ drag-gesture ] unless ; + [ motion ] hand-gadget get-global handle-gesture drop + hand-buttons get-global empty? [ drag-gesture ] unless ; : send-user-input ( string -- ) - dup empty? - [ hand get hand-focus user-input ] unless drop ; + dup empty? [ hand get hand-focus user-input ] unless drop ; : each-gesture ( gesture seq -- ) [ handle-gesture* drop ] each-with ; @@ -65,7 +72,7 @@ C: hand ( -- hand ) : hand-gestures ( new old -- ) drop-prefix reverse-slice [ mouse-leave ] swap each-gesture - hand get fire-motion + fire-motion [ mouse-enter ] swap each-gesture ; : focus-gestures ( new old -- ) @@ -73,7 +80,7 @@ C: hand ( -- hand ) [ lose-focus ] swap each-gesture [ gain-focus ] swap each-gesture ; -: focused-ancestors ( hand -- seq ) +: focused-ancestors ( -- seq ) hand get hand-focus parents reverse-slice ; : request-focus ( gadget -- ) @@ -82,7 +89,7 @@ C: hand ( -- hand ) r> focus-gestures ; : drag-loc ( gadget -- loc ) - hand get [ relative ] keep hand-click-rel v- ; + hand get rect-loc relative-loc hand-click-rel v- ; : relevant-help ( seq -- help ) [ gadget-help ] map [ ] find nip ; @@ -93,19 +100,19 @@ C: hand ( -- hand ) : update-help ( -- string ) #! Update mouse-over help message. - hand get hand-gadget parents [ relevant-help ] keep + hand-gadget get-global parents [ relevant-help ] keep dup empty? [ 2drop ] [ peek show-message ] if ; : under-hand ( -- seq ) #! A sequence whose first element is the world and last is #! the current gadget, with all parents in between. - hand get hand-gadget parents reverse-slice ; + hand-gadget get-global parents reverse-slice ; : hand-grab ( world -- gadget ) hand get rect-loc swap pick-up ; : update-hand-gadget ( world -- ) - hand-grab hand get set-hand-gadget ; + hand-grab hand-gadget set-global ; : move-hand ( loc world -- ) swap under-hand >r hand get set-rect-loc diff --git a/library/ui/hierarchy.factor b/library/ui/hierarchy.factor index 4a9caeb2ae..577727427a 100644 --- a/library/ui/hierarchy.factor +++ b/library/ui/hierarchy.factor @@ -78,10 +78,10 @@ M: gadget remove-notify* drop ; #! { 1 1 0 } - bottom right corner >r dup screen-loc swap rect-dim r> v* v+ ; -: relative ( g1 g2 -- g2-g1 ) screen-loc swap screen-loc v- ; +: relative-loc ( g1 point -- point-g1 ) swap screen-loc v- ; : relative-rect ( g1 g2 -- rect ) - [ relative ] keep rect-dim ; + [ screen-loc relative-loc ] keep rect-dim ; : child? ( parent child -- ? ) parents memq? ; diff --git a/library/ui/layouts.factor b/library/ui/layouts.factor index 04130b99e7..f8dc4d19e9 100644 --- a/library/ui/layouts.factor +++ b/library/ui/layouts.factor @@ -10,7 +10,7 @@ IN: gadgets-layouts : invalidate* ( gadget -- ) dup invalidate forget-pref-dim ; -: invalid ( -- queue ) \ invalid global hash ; +: invalid ( -- queue ) \ invalid get-global ; \ invalid set-global diff --git a/library/ui/menus.factor b/library/ui/menus.factor index da2c9cb440..db8f848c9a 100644 --- a/library/ui/menus.factor +++ b/library/ui/menus.factor @@ -26,7 +26,7 @@ namespaces sequences ; : show-menu ( loc menu gadget -- ) find-world 2dup show-glass - dup world-glass dup menu-actions hand get set-hand-clicked + dup world-glass dup menu-actions hand-clicked set-global over >r menu-loc r> set-rect-loc ; : show-hand-menu ( menu gadget -- ) diff --git a/library/ui/panes.factor b/library/ui/panes.factor index c7d3d754ed..40a78e69e4 100644 --- a/library/ui/panes.factor +++ b/library/ui/panes.factor @@ -40,7 +40,7 @@ SYMBOL: structured-input : pane-call ( quot pane -- ) "<< command >>" over stream-print >r structured-input set-global - "\"structured-input\" \"gadgets-panes\" lookup global hash call" + "\"structured-input\" \"gadgets-panes\" lookup get-global call" r> pane-eval ; : editor-commit ( editor -- line ) diff --git a/library/ui/sliders.factor b/library/ui/sliders.factor index de86df3639..db56de9df1 100644 --- a/library/ui/sliders.factor +++ b/library/ui/sliders.factor @@ -70,7 +70,7 @@ SYMBOL: slider-changed [ slider-page * ] keep slide-by ; : elevator-click ( elevator -- ) - dup hand get relative >r find-slider r> + dup hand get rect-loc relative-loc >r find-slider r> over gadget-orientation v. over screen>slider over slider-value - sgn swap slide-by-page ; diff --git a/library/ui/timers.factor b/library/ui/timers.factor index da007807b9..8fef1735c0 100644 --- a/library/ui/timers.factor +++ b/library/ui/timers.factor @@ -14,7 +14,7 @@ C: timer ( object delay -- timer ) GENERIC: tick ( ms object -- ) -: timers \ timers global hash ; +: timers \ timers get-global ; H{ } clone \ timers set-global diff --git a/library/vocabularies.factor b/library/vocabularies.factor index 77e8c91b67..69dd607ade 100644 --- a/library/vocabularies.factor +++ b/library/vocabularies.factor @@ -8,7 +8,7 @@ SYMBOL: bootstrapping? SYMBOL: vocabularies -: word ( -- word ) \ word global hash ; +: word ( -- word ) \ word get-global ; : set-word ( word -- ) \ word set-global ;