Merge branch 'master' of git://factorcode.org/git/factor
commit
9a4ac996a1
|
@ -7,27 +7,24 @@ TUPLE: book < gadget ;
|
||||||
|
|
||||||
: hide-all ( book -- ) gadget-children [ hide-gadget ] each ;
|
: hide-all ( book -- ) gadget-children [ hide-gadget ] each ;
|
||||||
|
|
||||||
: current-page ( book -- gadget )
|
: current-page ( book -- gadget ) [ control-value ] keep nth-gadget ;
|
||||||
[ control-value ] keep nth-gadget ;
|
|
||||||
|
|
||||||
M: book model-changed
|
M: book model-changed ( model book -- )
|
||||||
nip
|
nip
|
||||||
dup hide-all
|
dup hide-all
|
||||||
dup current-page show-gadget
|
dup current-page show-gadget
|
||||||
relayout ;
|
relayout ;
|
||||||
|
|
||||||
: new-book ( pages model class -- book )
|
: new-book ( pages model class -- book )
|
||||||
new-gadget
|
new-gadget
|
||||||
swap >>model
|
swap >>model
|
||||||
[ swap add-gadgets drop ] keep ; inline
|
swap add-gadgets ; inline
|
||||||
|
|
||||||
: <book> ( pages model -- book )
|
: <book> ( pages model -- book ) book new-book ;
|
||||||
book new-book ;
|
|
||||||
|
|
||||||
M: book pref-dim* gadget-children pref-dims max-dim ;
|
M: book pref-dim* ( book -- dim ) children>> pref-dims max-dim ;
|
||||||
|
|
||||||
M: book layout*
|
M: book layout* ( book -- )
|
||||||
dup rect-dim swap gadget-children
|
[ dim>> ] [ children>> ] bi [ set-layout-dim ] with each ;
|
||||||
[ set-layout-dim ] with each ;
|
|
||||||
|
|
||||||
M: book focusable-child* current-page ;
|
M: book focusable-child* ( book -- child/t ) current-page ;
|
||||||
|
|
|
@ -9,27 +9,21 @@ IN: ui.gadgets.sliders
|
||||||
|
|
||||||
TUPLE: elevator < gadget direction ;
|
TUPLE: elevator < gadget direction ;
|
||||||
|
|
||||||
: find-elevator ( gadget -- elevator/f )
|
: find-elevator ( gadget -- elevator/f ) [ elevator? ] find-parent ;
|
||||||
[ elevator? ] find-parent ;
|
|
||||||
|
|
||||||
TUPLE: slider < frame elevator thumb saved line ;
|
TUPLE: slider < frame elevator thumb saved line ;
|
||||||
|
|
||||||
: find-slider ( gadget -- slider/f )
|
: find-slider ( gadget -- slider/f ) [ slider? ] find-parent ;
|
||||||
[ slider? ] find-parent ;
|
|
||||||
|
|
||||||
: elevator-length ( slider -- n )
|
: elevator-length ( slider -- n )
|
||||||
dup slider-elevator rect-dim
|
[ elevator>> dim>> ] [ orientation>> ] bi v. ;
|
||||||
swap gadget-orientation v. ;
|
|
||||||
|
|
||||||
: min-thumb-dim 15 ;
|
: min-thumb-dim 15 ;
|
||||||
|
|
||||||
: slider-value ( gadget -- n ) gadget-model range-value >fixnum ;
|
: slider-value ( gadget -- n ) gadget-model range-value >fixnum ;
|
||||||
|
: slider-page ( gadget -- n ) gadget-model range-page-value ;
|
||||||
: slider-page ( gadget -- n ) gadget-model range-page-value ;
|
: slider-max ( gadget -- n ) gadget-model range-max-value ;
|
||||||
|
: slider-max* ( gadget -- n ) gadget-model range-max-value* ;
|
||||||
: slider-max ( gadget -- n ) gadget-model range-max-value ;
|
|
||||||
|
|
||||||
: slider-max* ( gadget -- n ) gadget-model range-max-value* ;
|
|
||||||
|
|
||||||
: thumb-dim ( slider -- h )
|
: thumb-dim ( slider -- h )
|
||||||
dup slider-page over slider-max 1 max / 1 min
|
dup slider-page over slider-max 1 max / 1 min
|
||||||
|
@ -45,7 +39,6 @@ TUPLE: slider < frame elevator thumb saved line ;
|
||||||
swap slider-max* 1 max / ;
|
swap slider-max* 1 max / ;
|
||||||
|
|
||||||
: slider>screen ( m scale -- n ) slider-scale * ;
|
: slider>screen ( m scale -- n ) slider-scale * ;
|
||||||
|
|
||||||
: screen>slider ( m scale -- n ) slider-scale / ;
|
: screen>slider ( m scale -- n ) slider-scale / ;
|
||||||
|
|
||||||
M: slider model-changed nip slider-elevator relayout-1 ;
|
M: slider model-changed nip slider-elevator relayout-1 ;
|
||||||
|
@ -76,11 +69,9 @@ thumb H{
|
||||||
t >>root?
|
t >>root?
|
||||||
thumb-theme ;
|
thumb-theme ;
|
||||||
|
|
||||||
: slide-by ( amount slider -- )
|
: slide-by ( amount slider -- ) gadget-model move-by ;
|
||||||
gadget-model move-by ;
|
|
||||||
|
|
||||||
: slide-by-page ( amount slider -- )
|
: slide-by-page ( amount slider -- ) gadget-model move-by-page ;
|
||||||
gadget-model move-by-page ;
|
|
||||||
|
|
||||||
: compute-direction ( elevator -- -1/1 )
|
: compute-direction ( elevator -- -1/1 )
|
||||||
dup find-slider swap hand-click-rel
|
dup find-slider swap hand-click-rel
|
||||||
|
@ -100,13 +91,10 @@ elevator H{
|
||||||
{ T{ button-down } [ elevator-click ] }
|
{ T{ button-down } [ elevator-click ] }
|
||||||
} set-gestures
|
} set-gestures
|
||||||
|
|
||||||
: elevator-theme ( elevator -- )
|
|
||||||
lowered-gradient swap set-gadget-interior ;
|
|
||||||
|
|
||||||
: <elevator> ( vector -- elevator )
|
: <elevator> ( vector -- elevator )
|
||||||
elevator new-gadget
|
elevator new-gadget
|
||||||
[ set-gadget-orientation ] keep
|
swap >>orientation
|
||||||
dup elevator-theme ;
|
lowered-gradient >>interior ;
|
||||||
|
|
||||||
: (layout-thumb) ( slider n -- n thumb )
|
: (layout-thumb) ( slider n -- n thumb )
|
||||||
over gadget-orientation n*v swap slider-thumb ;
|
over gadget-orientation n*v swap slider-thumb ;
|
||||||
|
@ -144,17 +132,10 @@ M: elevator layout*
|
||||||
dup elevator>> over thumb>> add-gadget
|
dup elevator>> over thumb>> add-gadget
|
||||||
@center grid-add* ;
|
@center grid-add* ;
|
||||||
|
|
||||||
: <left-button> ( -- button )
|
: <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
|
||||||
{ 0 1 } arrow-left -1 <slide-button> ;
|
: <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ;
|
||||||
|
: <up-button> ( -- button ) { 1 0 } arrow-up -1 <slide-button> ;
|
||||||
: <right-button> ( -- button )
|
: <down-button> ( -- button ) { 1 0 } arrow-down 1 <slide-button> ;
|
||||||
{ 0 1 } arrow-right 1 <slide-button> ;
|
|
||||||
|
|
||||||
: <up-button> ( -- button )
|
|
||||||
{ 1 0 } arrow-up -1 <slide-button> ;
|
|
||||||
|
|
||||||
: <down-button> ( -- button )
|
|
||||||
{ 1 0 } arrow-down 1 <slide-button> ;
|
|
||||||
|
|
||||||
: <slider> ( range orientation -- slider )
|
: <slider> ( range orientation -- slider )
|
||||||
slider new-frame
|
slider new-frame
|
||||||
|
|
|
@ -60,10 +60,10 @@ M: gadget tool-scroller drop f ;
|
||||||
request-focus ;
|
request-focus ;
|
||||||
|
|
||||||
: show-popup ( gadget workspace -- )
|
: show-popup ( gadget workspace -- )
|
||||||
dup hide-popup
|
dup hide-popup
|
||||||
2dup set-workspace-popup
|
over >>popup
|
||||||
dupd f track-add
|
over f track-add* drop
|
||||||
request-focus ;
|
request-focus ;
|
||||||
|
|
||||||
: show-titled-popup ( workspace gadget title -- )
|
: show-titled-popup ( workspace gadget title -- )
|
||||||
[ find-workspace hide-popup ] <closable-gadget>
|
[ find-workspace hide-popup ] <closable-gadget>
|
||||||
|
|
Loading…
Reference in New Issue