steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Hand cleanup

release
slava 2006-03-19 05:57:47 +00:00
parent 500d7b5331
commit ba471ee5bc
4 changed files with 11 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
library/ui/editors.factor
View File

@ -68,7 +68,7 @@ TUPLE: editor line caret font color ;
] with-editor ; ] with-editor ;
: click-editor ( editor -- ) : click-editor ( editor -- )
dup hand get rect-loc relative-loc dup hand-click-loc get-global relative-loc
first over set-caret-x request-focus ; first over set-caret-x request-focus ;
: popup-location ( editor -- loc ) : popup-location ( editor -- loc )

19
library/ui/hand.factor
View File

@ -14,13 +14,6 @@ SYMBOL: hand-click-loc
SYMBOL: hand-buttons SYMBOL: hand-buttons
V{ } clone hand-buttons set-global V{ } clone hand-buttons set-global
! The hand is a special gadget that holds mouse position and
! mouse button click state.
! Some comments on the slots:
! - 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 focus ; TUPLE: hand focus ;
C: hand ( -- hand ) C: hand ( -- hand )
@ -89,7 +82,7 @@ C: hand ( -- hand )
r> focus-gestures ; r> focus-gestures ;
: drag-loc ( gadget -- loc ) : drag-loc ( gadget -- loc )
hand get rect-loc relative-loc hand-click-rel v- ; hand get rect-loc hand-click-loc get-global v- ;
: relevant-help ( seq -- help ) : relevant-help ( seq -- help )
[ gadget-help ] map [ ] find nip ; [ gadget-help ] map [ ] find nip ;
@ -108,15 +101,9 @@ C: hand ( -- hand )
#! the current gadget, with all parents in between. #! the current gadget, with all parents in between.
hand-gadget get-global 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-gadget set-global ;
: move-hand ( loc world -- ) : move-hand ( loc world -- )
swap under-hand >r hand get set-rect-loc under-hand >r over hand get set-rect-loc
update-hand-gadget pick-up hand-gadget set-global
under-hand r> hand-gestures update-help ; under-hand r> hand-gestures update-help ;
: update-hand ( world -- ) : update-hand ( world -- )

13
library/ui/menus.factor
View File

@ -6,16 +6,15 @@ gadgets-labels gadgets-theme generic kernel lists math
namespaces sequences ; namespaces sequences ;
: retarget-drag ( gadget -- ) : retarget-drag ( gadget -- )
find-world hand get [ hand-gadget ] keep hand-gadget get-global hand-clicked get-global eq? [
2dup hand-clicked eq? [ drop
3drop
] [ ] [
set-hand-clicked update-hand hand-gadget get-global hand-clicked set-global
update-hand
] if ; ] if ;
: retarget-click ( gadget -- ) : retarget-click ( gadget -- )
find-world dup hide-glass update-hand-gadget find-world dup hide-glass update-hand update-clicked ;
update-clicked ;
: menu-actions ( glass -- ) : menu-actions ( glass -- )
dup [ retarget-drag ] [ drag ] set-action dup [ retarget-drag ] [ drag ] set-action
@ -30,7 +29,7 @@ namespaces sequences ;
over >r menu-loc r> set-rect-loc ; over >r menu-loc r> set-rect-loc ;
: show-hand-menu ( menu gadget -- ) : show-hand-menu ( menu gadget -- )
hand get rect-loc -rot show-menu ; hand-click-loc get-global -rot show-menu ;
: menu-item-quot ( quot -- quot ) : menu-item-quot ( quot -- quot )
[ keep find-world hide-glass ] curry ; [ keep find-world hide-glass ] curry ;

2
library/ui/sliders.factor
View File

@ -70,7 +70,7 @@ SYMBOL: slider-changed
[ slider-page * ] keep slide-by ; [ slider-page * ] keep slide-by ;
: elevator-click ( elevator -- ) : elevator-click ( elevator -- )
dup hand get rect-loc relative-loc >r find-slider r> dup hand-click-loc relative-loc >r find-slider r>
over gadget-orientation v. over gadget-orientation v.
over screen>slider over slider-value - sgn over screen>slider over slider-value - sgn
swap slide-by-page ; swap slide-by-page ;