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

ui.gadgets.sliders: new appearance

db4
Slava Pestov 2009-02-12 01:40:18 -06:00
parent a41e502bad
commit 64f716b8d2
3 changed files with 140 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
basis/ui/gadgets/scrollers/scrollers.factor
View File

@ -39,12 +39,10 @@ scroller H{
<scroller-model> >>model <scroller-model> >>model
dup model>> dependencies>> dup model>> dependencies>>
[ first <x-slider> [ >>x ] [ @bottom grid-add ] bi ] [ first horizontal <slider> [ >>x ] [ @bottom grid-add ] bi ]
[ second <y-slider> [ >>y ] [ @right grid-add ] bi ] bi [ second vertical <slider> [ >>y ] [ @right grid-add ] bi ] bi
tuck model>> <viewport> [ >>viewport ] [ @center grid-add ] bi tuck model>> <viewport> [ >>viewport ] [ @center grid-add ] bi ; inline
faint-boundary ; inline
: <scroller> ( gadget -- scroller ) scroller new-scroller ; : <scroller> ( gadget -- scroller ) scroller new-scroller ;

18
basis/ui/gadgets/sliders/sliders-docs.factor
View File

@ -11,7 +11,7 @@ HELP: find-elevator
HELP: slider HELP: slider
{ $class-description "A slider is a control for graphically manipulating a " { $link "models-range" } "." { $class-description "A slider is a control for graphically manipulating a " { $link "models-range" } "."
$nl $nl
"Sliders are created by calling " { $link <x-slider> } " or " { $link <y-slider> } "." } ; "Sliders are created by calling " { $link <slider> } "." } ;
HELP: find-slider HELP: find-slider
{ $values { "gadget" gadget } { "slider/f" { $maybe slider } } } { $values { "gadget" gadget } { "slider/f" { $maybe slider } } }
@ -34,24 +34,12 @@ HELP: slide-by-line
HELP: <slider> HELP: <slider>
{ $values { "range" range } { "orientation" "an orientation specifier" } { "slider" "a new " { $link slider } } } { $values { "range" range } { "orientation" "an orientation specifier" } { "slider" "a new " { $link slider } } }
{ $description "Internal word for constructing sliders." } { $description "Creates a new slider." } ;
{ $notes "This does not build a complete slider, and user code should call " { $link <x-slider> } " or " { $link <y-slider> } " instead." } ;
HELP: <x-slider>
{ $values { "range" range } { "slider" slider } }
{ $description "Creates a new horizontal " { $link slider } "." } ;
HELP: <y-slider>
{ $values { "range" range } { "slider" slider } }
{ $description "Creates a new vertical " { $link slider } "." } ;
{ <x-slider> <y-slider> } related-words
ARTICLE: "ui.gadgets.sliders" "Slider gadgets" ARTICLE: "ui.gadgets.sliders" "Slider gadgets"
"The " { $vocab-link "ui.gadgets.sliders" } " vocabulary implements slider gadgets. A slider allows the user to graphically manipulate a value by moving a thumb back and forth." "The " { $vocab-link "ui.gadgets.sliders" } " vocabulary implements slider gadgets. A slider allows the user to graphically manipulate a value by moving a thumb back and forth."
{ $subsection slider } { $subsection slider }
{ $subsection <x-slider> } { $subsection <slider> }
{ $subsection <y-slider> }
"Changing slider values:" "Changing slider values:"
{ $subsection slide-by } { $subsection slide-by }
{ $subsection slide-by-line } { $subsection slide-by-line }

219
basis/ui/gadgets/sliders/sliders.factor
View File

@ -1,36 +1,49 @@
! Copyright (C) 2005, 2009 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons USING: accessors arrays assocs kernel math namespaces sequences
ui.gadgets.frames ui.gadgets.grids math.order vectors models models.range math.vectors math.functions quotations
ui.gadgets.theme ui.render kernel math namespaces sequences colors colors.constants math.rectangles fry combinators ui.gestures
vectors models models.range math.vectors math.functions ui.gadgets ui.gadgets.buttons ui.gadgets.tracks math.order
quotations colors colors.constants math.rectangles fry ; ui.gadgets.theme ui.gadgets.icons ui.render ;
IN: ui.gadgets.sliders IN: ui.gadgets.sliders
TUPLE: elevator < gadget direction ; TUPLE: slider < track elevator thumb saved line ;
: find-elevator ( gadget -- elevator/f ) [ elevator? ] find-parent ;
TUPLE: slider < frame elevator thumb saved line ;
: find-slider ( gadget -- slider/f ) [ slider? ] find-parent ;
: elevator-length ( slider -- n )
[ elevator>> dim>> ] [ orientation>> ] bi v. ;
: min-thumb-dim 15 ;
: slider-value ( gadget -- n ) model>> range-value >fixnum ; : slider-value ( gadget -- n ) model>> range-value >fixnum ;
: slider-page ( gadget -- n ) model>> range-page-value ; : slider-page ( gadget -- n ) model>> range-page-value ;
: slider-max ( gadget -- n ) model>> range-max-value ; : slider-max ( gadget -- n ) model>> range-max-value ;
: slider-max* ( gadget -- n ) model>> range-max-value* ; : slider-max* ( gadget -- n ) model>> range-max-value* ;
: slide-by ( amount slider -- ) model>> move-by ;
: slide-by-page ( amount slider -- ) model>> move-by-page ;
: slide-by-line ( amount slider -- ) [ line>> * ] keep slide-by ;
<PRIVATE
TUPLE: elevator < gadget direction ;
: find-elevator ( gadget -- elevator/f ) [ elevator? ] find-parent ;
: find-slider ( gadget -- slider/f ) [ slider? ] find-parent ;
CONSTANT: elevator-padding 4
: elevator-length ( slider -- n )
[ elevator>> dim>> ] [ orientation>> ] bi v.
elevator-padding 2 * - ;
CONSTANT: min-thumb-dim 30
: visible-portion ( slider -- n )
[ slider-page ] [ slider-max 1 max ] bi / 1 min ;
: thumb-dim ( slider -- h ) : thumb-dim ( slider -- h )
[ [
[ [ slider-page ] [ slider-max 1 max ] bi / 1 min ] [ visible-portion ] [ elevator-length ] bi *
[ elevator-length ] bi * min-thumb-dim max min-thumb-dim max
] ]
[ [ elevator>> dim>> ] [ orientation>> ] bi v. ] bi min ; [ elevator-length ] bi min ;
: slider-scale ( slider -- n ) : slider-scale ( slider -- n )
#! A scaling factor such that if x is a slider co-ordinate, #! A scaling factor such that if x is a slider co-ordinate,
@ -40,20 +53,23 @@ TUPLE: slider < frame elevator thumb saved line ;
[ slider-max* 1 max ] [ slider-max* 1 max ]
bi / ; bi / ;
: slider>screen ( m scale -- n ) slider-scale * ; : slider>screen ( m slider -- n ) slider-scale * elevator-padding + ;
: screen>slider ( m scale -- n ) slider-scale / ; : screen>slider ( m slider -- n ) [ elevator-padding - ] dip slider-scale / ;
M: slider model-changed nip elevator>> relayout-1 ; M: slider model-changed nip elevator>> relayout-1 ;
TUPLE: thumb < gadget ; TUPLE: thumb < track ;
: begin-drag ( thumb -- ) : begin-drag ( thumb -- )
find-slider dup slider-value >>saved drop ; find-slider dup slider-value >>saved drop ;
: do-drag ( thumb -- ) : do-drag ( thumb -- )
find-slider drag-loc over orientation>> v. find-slider {
over screen>slider swap [ saved>> + ] keep [ orientation>> drag-loc v. ]
model>> set-range-value ; [ screen>slider ]
[ saved>> + ]
[ model>> set-range-value ]
} cleave ;
thumb H{ thumb H{
{ T{ button-down } [ begin-drag ] } { T{ button-down } [ begin-drag ] }
@ -61,19 +77,37 @@ thumb H{
{ T{ drag } [ do-drag ] } { T{ drag } [ do-drag ] }
} set-gestures } set-gestures
: thumb-theme ( thumb -- thumb ) CONSTANT: horizontal-thumb-tiles
plain-gradient >>interior {
faint-boundary ; inline { "horizontal-scroller-handle-left" f }
{ "horizontal-scroller-handle-middle" 1/2 }
{ "horizontal-scroller-handle-grip" f }
{ "horizontal-scroller-handle-middle" 1/2 }
{ "horizontal-scroller-handle-right" f }
}
: <thumb> ( vector -- thumb ) CONSTANT: vertical-thumb-tiles
thumb new-gadget {
swap >>orientation { "vertical-scroller-handle-top" f }
t >>root? { "vertical-scroller-handle-middle" 1/2 }
thumb-theme ; { "vertical-scroller-handle-grip" f }
{ "vertical-scroller-handle-middle" 1/2 }
{ "vertical-scroller-handle-bottom" f }
}
: slide-by ( amount slider -- ) model>> move-by ; : build-thumb ( thumb -- thumb )
dup orientation>> {
{ horizontal [ horizontal-thumb-tiles ] }
{ vertical [ vertical-thumb-tiles ] }
} case
[ [ theme-image <icon> ] dip track-add ] assoc-each ;
: slide-by-page ( amount slider -- ) model>> move-by-page ; : <thumb> ( orientation -- thumb )
thumb new-track
0 >>fill
1/2 >>align
build-thumb
t >>root? ;
: compute-direction ( elevator -- -1/1 ) : compute-direction ( elevator -- -1/1 )
[ hand-click-rel ] [ find-slider ] bi [ hand-click-rel ] [ find-slider ] bi
@ -96,68 +130,91 @@ elevator H{
: <elevator> ( vector -- elevator ) : <elevator> ( vector -- elevator )
elevator new-gadget elevator new-gadget
swap >>orientation swap >>orientation ;
lowered-gradient >>interior ;
: (layout-thumb) ( slider n -- n thumb )
over orientation>> n*v swap thumb>> ;
: thumb-loc ( slider -- loc ) : thumb-loc ( slider -- loc )
[ slider-value ] keep slider>screen ; [ slider-value ] keep slider>screen ;
: layout-thumb-loc ( slider -- ) : layout-thumb-loc ( thumb slider -- )
dup thumb-loc (layout-thumb) [ thumb-loc ] [ orientation>> ] bi n*v
[ [ floor ] map ] dip (>>loc) ; [ floor ] map >>loc drop ;
: layout-thumb-dim ( slider -- ) : layout-thumb-dim ( thumb slider -- )
dup dup thumb-dim (layout-thumb) [ dim>> ] [ thumb-dim ] [ orientation>> ] tri [ n*v ] keep set-axis
[ [ ceiling ] map >>dim drop ;
[ [ dim>> ] dip ] [ drop orientation>> ] 2bi set-axis
[ ceiling ] map
] dip (>>dim) ;
: layout-thumb ( slider -- ) : layout-thumb ( slider -- )
dup layout-thumb-loc layout-thumb-dim ; [ thumb>> ] keep
[ visible-portion 1 = not >>visible? drop ]
[ layout-thumb-loc ]
[ layout-thumb-dim ]
2tri ;
M: elevator layout* M: elevator layout*
find-slider layout-thumb ; find-slider layout-thumb ;
: slide-by-line ( amount slider -- ) [ line>> * ] keep slide-by ; : add-thumb-to-elevator ( object -- object )
[ elevator>> ] [ thumb>> ] bi add-gadget ;
: <slide-button> ( vector polygon amount -- button ) : <slide-button-pen> ( orientation left right -- pen )
[ COLOR: gray swap <polygon-gadget> ] dip [ horizontal = ] 2dip ?
'[ _ swap find-slider slide-by-line ] <repeat-button> [ f f ] [ theme-image <image-pen> f ] bi* <button-paint> ;
swap >>orientation ;
: add-elevator ( gadget orientation -- gadget ) TUPLE: slide-button < repeat-button ;
[ <elevator> >>elevator ] [ <thumb> >>thumb ] bi
dup [ elevator>> ] [ thumb>> ] bi add-gadget
@center grid-add ;
: <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ; : <slide-button> ( orientation amount left right -- button )
: <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ; [ swap ] 2dip
: <up-button> ( -- button ) horizontal arrow-up -1 <slide-button> ; [
: <down-button> ( -- button ) horizontal arrow-down 1 <slide-button> ; [ <gadget> ] dip
'[ _ swap find-slider slide-by-line ]
slide-button new-button
] 3dip
<slide-button-pen> >>interior ;
: <slider> ( range orientation -- slider ) M: slide-button pref-dim* dup interior>> pen-pref-dim ;
slider new-frame
swap >>orientation
swap >>model
32 >>line ;
: <x-slider> ( range -- slider ) : <up-button> ( orientation -- button )
horizontal <slider> -1
<left-button> @left grid-add "horizontal-scroller-leftarrow-clicked"
vertical add-elevator "vertical-scroller-uparrow-clicked"
<right-button> @right grid-add ; <slide-button> ;
: <y-slider> ( range -- slider ) : <down-button> ( orientation -- button )
vertical <slider> 1
<up-button> @top grid-add "horizontal-scroller-rightarrow-clicked"
horizontal add-elevator "vertical-scroller-downarrow-clicked"
<down-button> @bottom grid-add ; <slide-button> ;
: <slider-pen> ( orientation -- pen )
{
{ horizontal [
"horizontal-scroller-left"
"horizontal-scroller-middle"
"horizontal-scroller-right"
] }
{ vertical [
"vertical-scroller-top"
"vertical-scroller-middle"
"vertical-scroller-bottom"
] }
} case [ theme-image ] tri@ <tile-pen> ;
M: slider pref-dim* M: slider pref-dim*
[ call-next-method ] [ orientation>> ] bi [ dup interior>> pen-pref-dim ] [ drop { 100 100 } ] [ orientation>> ] tri
[ 40 v*n ] keep
set-axis ; set-axis ;
PRIVATE>
: <slider> ( range orientation -- slider )
slider new-track
swap >>model
32 >>line
dup orientation>> {
[ <slider-pen> >>interior ]
[ <thumb> >>thumb ]
[ <elevator> >>elevator ]
[ drop dup add-thumb-to-elevator 1 track-add ]
[ <up-button> f track-add ]
[ <down-button> f track-add ]
[ drop <gadget> { 1 1 } >>dim f track-add ]
} cleave ;