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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2008-07-15 15:22:40 -05:00
parent 2b9d2302e6 d7d896205c
commit 9a4ac996a1
3 changed files with 29 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
extra/ui/gadgets/books/books.factor
View File

@ -7,10 +7,9 @@ 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
@ -19,15 +18,13 @@ M: book model-changed
: 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 ;

41
extra/ui/gadgets/sliders/sliders.factor
View File

@ -9,26 +9,20 @@ 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 )
@ -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

4
extra/ui/tools/workspace/workspace.factor
View File

@ -61,8 +61,8 @@ M: gadget tool-scroller drop f ;
: 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 -- )