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

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

@ -7,27 +7,24 @@ TUPLE: book < gadget ;
: hide-all ( book -- ) gadget-children [ hide-gadget ] each ;
: current-page ( book -- gadget )
[ control-value ] keep nth-gadget ;
: current-page ( book -- gadget ) [ control-value ] keep nth-gadget ;
M: book model-changed
M: book model-changed ( model book -- )
nip
dup hide-all
dup current-page show-gadget
relayout ;
: new-book ( pages model class -- book )
new-gadget
swap >>model
[ swap add-gadgets drop ] keep ; inline
new-gadget
swap >>model
swap add-gadgets ; inline
: <book> ( pages model -- book )
book new-book ;
: <book> ( pages model -- 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*
dup rect-dim swap gadget-children
[ set-layout-dim ] with each ;
M: book layout* ( book -- )
[ dim>> ] [ children>> ] bi [ set-layout-dim ] with each ;
M: book focusable-child* current-page ;
M: book focusable-child* ( book -- child/t ) current-page ;

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

@ -9,27 +9,21 @@ IN: ui.gadgets.sliders
TUPLE: elevator < gadget direction ;
: find-elevator ( gadget -- elevator/f )
[ elevator? ] find-parent ;
: find-elevator ( gadget -- elevator/f ) [ elevator? ] find-parent ;
TUPLE: slider < frame elevator thumb saved line ;
: find-slider ( gadget -- slider/f )
[ slider? ] find-parent ;
: find-slider ( gadget -- slider/f ) [ slider? ] find-parent ;
: elevator-length ( slider -- n )
dup slider-elevator rect-dim
swap gadget-orientation v. ;
[ elevator>> dim>> ] [ orientation>> ] bi v. ;
: min-thumb-dim 15 ;
: slider-value ( gadget -- n ) gadget-model range-value >fixnum ;
: 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-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* ;
: thumb-dim ( slider -- h )
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 / ;
: slider>screen ( m scale -- n ) slider-scale * ;
: screen>slider ( m scale -- n ) slider-scale / ;
M: slider model-changed nip slider-elevator relayout-1 ;
@ -76,11 +69,9 @@ thumb H{
t >>root?
thumb-theme ;
: slide-by ( amount slider -- )
gadget-model move-by ;
: slide-by ( amount slider -- ) gadget-model move-by ;
: slide-by-page ( amount slider -- )
gadget-model move-by-page ;
: slide-by-page ( amount slider -- ) gadget-model move-by-page ;
: compute-direction ( elevator -- -1/1 )
dup find-slider swap hand-click-rel
@ -100,13 +91,10 @@ elevator H{
{ T{ button-down } [ elevator-click ] }
} set-gestures
: elevator-theme ( elevator -- )
lowered-gradient swap set-gadget-interior ;
: <elevator> ( vector -- elevator )
elevator new-gadget
[ set-gadget-orientation ] keep
dup elevator-theme ;
elevator new-gadget
swap >>orientation
lowered-gradient >>interior ;
: (layout-thumb) ( slider n -- n thumb )
over gadget-orientation n*v swap slider-thumb ;
@ -144,17 +132,10 @@ M: elevator layout*
dup elevator>> over thumb>> add-gadget
@center grid-add* ;
: <left-button> ( -- 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> ;
: <down-button> ( -- button )
{ 1 0 } arrow-down 1 <slide-button> ;
: <left-button> ( -- 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> ;
: <down-button> ( -- button ) { 1 0 } arrow-down 1 <slide-button> ;
: <slider> ( range orientation -- slider )
slider new-frame

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

@ -60,10 +60,10 @@ M: gadget tool-scroller drop f ;
request-focus ;
: show-popup ( gadget workspace -- )
dup hide-popup
2dup set-workspace-popup
dupd f track-add
request-focus ;
dup hide-popup
over >>popup
over f track-add* drop
request-focus ;
: show-titled-popup ( workspace gadget title -- )
[ find-workspace hide-popup ] <closable-gadget>