From 64f716b8d22c0f4afb4842d9648300c5cbffb851 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Feb 2009 01:40:18 -0600 Subject: [PATCH] ui.gadgets.sliders: new appearance --- basis/ui/gadgets/scrollers/scrollers.factor | 8 +- basis/ui/gadgets/sliders/sliders-docs.factor | 18 +- basis/ui/gadgets/sliders/sliders.factor | 211 ++++++++++++------- 3 files changed, 140 insertions(+), 97 deletions(-) diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor index 24c46d2e57..7d41d48c70 100644 --- a/basis/ui/gadgets/scrollers/scrollers.factor +++ b/basis/ui/gadgets/scrollers/scrollers.factor @@ -39,12 +39,10 @@ scroller H{ >>model dup model>> dependencies>> - [ first [ >>x ] [ @bottom grid-add ] bi ] - [ second [ >>y ] [ @right grid-add ] bi ] bi + [ first horizontal [ >>x ] [ @bottom grid-add ] bi ] + [ second vertical [ >>y ] [ @right grid-add ] bi ] bi - tuck model>> [ >>viewport ] [ @center grid-add ] bi - - faint-boundary ; inline + tuck model>> [ >>viewport ] [ @center grid-add ] bi ; inline : ( gadget -- scroller ) scroller new-scroller ; diff --git a/basis/ui/gadgets/sliders/sliders-docs.factor b/basis/ui/gadgets/sliders/sliders-docs.factor index 6f107b4e42..f58628e5c6 100644 --- a/basis/ui/gadgets/sliders/sliders-docs.factor +++ b/basis/ui/gadgets/sliders/sliders-docs.factor @@ -11,7 +11,7 @@ HELP: find-elevator HELP: slider { $class-description "A slider is a control for graphically manipulating a " { $link "models-range" } "." $nl -"Sliders are created by calling " { $link } " or " { $link } "." } ; +"Sliders are created by calling " { $link } "." } ; HELP: find-slider { $values { "gadget" gadget } { "slider/f" { $maybe slider } } } @@ -34,24 +34,12 @@ HELP: slide-by-line HELP: { $values { "range" range } { "orientation" "an orientation specifier" } { "slider" "a new " { $link slider } } } -{ $description "Internal word for constructing sliders." } -{ $notes "This does not build a complete slider, and user code should call " { $link } " or " { $link } " instead." } ; - -HELP: -{ $values { "range" range } { "slider" slider } } -{ $description "Creates a new horizontal " { $link slider } "." } ; - -HELP: -{ $values { "range" range } { "slider" slider } } -{ $description "Creates a new vertical " { $link slider } "." } ; - -{ } related-words +{ $description "Creates a new slider." } ; 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." { $subsection slider } -{ $subsection } -{ $subsection } +{ $subsection } "Changing slider values:" { $subsection slide-by } { $subsection slide-by-line } diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor index 1cc21beb1a..f6353112cd 100644 --- a/basis/ui/gadgets/sliders/sliders.factor +++ b/basis/ui/gadgets/sliders/sliders.factor @@ -1,36 +1,49 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons -ui.gadgets.frames ui.gadgets.grids math.order -ui.gadgets.theme ui.render kernel math namespaces sequences -vectors models models.range math.vectors math.functions -quotations colors colors.constants math.rectangles fry ; +USING: accessors arrays assocs kernel math namespaces sequences +vectors models models.range math.vectors math.functions quotations +colors colors.constants math.rectangles fry combinators ui.gestures +ui.gadgets ui.gadgets.buttons ui.gadgets.tracks math.order +ui.gadgets.theme ui.gadgets.icons ui.render ; IN: ui.gadgets.sliders +TUPLE: slider < track elevator thumb saved line ; + +: slider-value ( gadget -- n ) model>> range-value >fixnum ; +: slider-page ( gadget -- n ) model>> range-page-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 ; + +> dim>> ] [ orientation>> ] bi v. ; + [ elevator>> dim>> ] [ orientation>> ] bi v. + elevator-padding 2 * - ; -: min-thumb-dim 15 ; +CONSTANT: min-thumb-dim 30 -: slider-value ( gadget -- n ) model>> range-value >fixnum ; -: slider-page ( gadget -- n ) model>> range-page-value ; -: slider-max ( gadget -- n ) model>> range-max-value ; -: slider-max* ( gadget -- n ) model>> range-max-value* ; +: visible-portion ( slider -- n ) + [ slider-page ] [ slider-max 1 max ] bi / 1 min ; : thumb-dim ( slider -- h ) [ - [ [ slider-page ] [ slider-max 1 max ] bi / 1 min ] - [ elevator-length ] bi * min-thumb-dim max + [ visible-portion ] [ elevator-length ] bi * + min-thumb-dim max ] - [ [ elevator>> dim>> ] [ orientation>> ] bi v. ] bi min ; + [ elevator-length ] bi min ; : slider-scale ( slider -- n ) #! 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 ] bi / ; -: slider>screen ( m scale -- n ) slider-scale * ; -: screen>slider ( m scale -- n ) slider-scale / ; +: slider>screen ( m slider -- n ) slider-scale * elevator-padding + ; +: screen>slider ( m slider -- n ) [ elevator-padding - ] dip slider-scale / ; M: slider model-changed nip elevator>> relayout-1 ; -TUPLE: thumb < gadget ; +TUPLE: thumb < track ; : begin-drag ( thumb -- ) find-slider dup slider-value >>saved drop ; : do-drag ( thumb -- ) - find-slider drag-loc over orientation>> v. - over screen>slider swap [ saved>> + ] keep - model>> set-range-value ; + find-slider { + [ orientation>> drag-loc v. ] + [ screen>slider ] + [ saved>> + ] + [ model>> set-range-value ] + } cleave ; thumb H{ { T{ button-down } [ begin-drag ] } @@ -61,19 +77,37 @@ thumb H{ { T{ drag } [ do-drag ] } } set-gestures -: thumb-theme ( thumb -- thumb ) - plain-gradient >>interior - faint-boundary ; inline +CONSTANT: horizontal-thumb-tiles + { + { "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 } + } -: ( vector -- thumb ) - thumb new-gadget - swap >>orientation - t >>root? - thumb-theme ; +CONSTANT: vertical-thumb-tiles + { + { "vertical-scroller-handle-top" f } + { "vertical-scroller-handle-middle" 1/2 } + { "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 ] dip track-add ] assoc-each ; -: slide-by-page ( amount slider -- ) model>> move-by-page ; +: ( orientation -- thumb ) + thumb new-track + 0 >>fill + 1/2 >>align + build-thumb + t >>root? ; : compute-direction ( elevator -- -1/1 ) [ hand-click-rel ] [ find-slider ] bi @@ -96,68 +130,91 @@ elevator H{ : ( vector -- elevator ) elevator new-gadget - swap >>orientation - lowered-gradient >>interior ; - -: (layout-thumb) ( slider n -- n thumb ) - over orientation>> n*v swap thumb>> ; + swap >>orientation ; : thumb-loc ( slider -- loc ) [ slider-value ] keep slider>screen ; -: layout-thumb-loc ( slider -- ) - dup thumb-loc (layout-thumb) - [ [ floor ] map ] dip (>>loc) ; +: layout-thumb-loc ( thumb slider -- ) + [ thumb-loc ] [ orientation>> ] bi n*v + [ floor ] map >>loc drop ; -: layout-thumb-dim ( slider -- ) - dup dup thumb-dim (layout-thumb) - [ - [ [ dim>> ] dip ] [ drop orientation>> ] 2bi set-axis - [ ceiling ] map - ] dip (>>dim) ; +: layout-thumb-dim ( thumb slider -- ) + [ dim>> ] [ thumb-dim ] [ orientation>> ] tri [ n*v ] keep set-axis + [ ceiling ] map >>dim drop ; : 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* find-slider layout-thumb ; -: slide-by-line ( amount slider -- ) [ line>> * ] keep slide-by ; +: add-thumb-to-elevator ( object -- object ) + [ elevator>> ] [ thumb>> ] bi add-gadget ; -: ( vector polygon amount -- button ) - [ COLOR: gray swap ] dip - '[ _ swap find-slider slide-by-line ] - swap >>orientation ; +: ( orientation left right -- pen ) + [ horizontal = ] 2dip ? + [ f f ] [ theme-image f ] bi* ; -: add-elevator ( gadget orientation -- gadget ) - [ >>elevator ] [ >>thumb ] bi - dup [ elevator>> ] [ thumb>> ] bi add-gadget - @center grid-add ; +TUPLE: slide-button < repeat-button ; -: ( -- button ) { 0 1 } arrow-left -1 ; -: ( -- button ) { 0 1 } arrow-right 1 ; -: ( -- button ) horizontal arrow-up -1 ; -: ( -- button ) horizontal arrow-down 1 ; +: ( orientation amount left right -- button ) + [ swap ] 2dip + [ + [ ] dip + '[ _ swap find-slider slide-by-line ] + slide-button new-button + ] 3dip + >>interior ; -: ( range orientation -- slider ) - slider new-frame - swap >>orientation - swap >>model - 32 >>line ; +M: slide-button pref-dim* dup interior>> pen-pref-dim ; -: ( range -- slider ) - horizontal - @left grid-add - vertical add-elevator - @right grid-add ; +: ( orientation -- button ) + -1 + "horizontal-scroller-leftarrow-clicked" + "vertical-scroller-uparrow-clicked" + ; -: ( range -- slider ) - vertical - @top grid-add - horizontal add-elevator - @bottom grid-add ; +: ( orientation -- button ) + 1 + "horizontal-scroller-rightarrow-clicked" + "vertical-scroller-downarrow-clicked" + ; + +: ( 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@ ; M: slider pref-dim* - [ call-next-method ] [ orientation>> ] bi - [ 40 v*n ] keep + [ dup interior>> pen-pref-dim ] [ drop { 100 100 } ] [ orientation>> ] tri set-axis ; + +PRIVATE> + +: ( range orientation -- slider ) + slider new-track + swap >>model + 32 >>line + dup orientation>> { + [ >>interior ] + [ >>thumb ] + [ >>elevator ] + [ drop dup add-thumb-to-elevator 1 track-add ] + [ f track-add ] + [ f track-add ] + [ drop { 1 1 } >>dim f track-add ] + } cleave ; \ No newline at end of file