- poorly documented vocabs:
- alien
- - assembler
- cocoa
- command-line
- compiler
{ $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "."
$terpri
"Unlike " { $link with-nested-stream } ", the quotation's output is inline, and not nested in a paragraph block." }
-{ $notes "Details are in the documentation for " { $link with-stream-style } "." }
$io-error ;
HELP: stream-print
! We don't care if this fails or returns 0 (its CPU-specific)
! as long as it doesn't crash
[ ] [ [ 0 0 /i ] catch clear ] unit-test
+[ ] [ [ 100000000000000000 0 /i ] catch clear ] unit-test
HELP: book
{ $class-description "A book is a " { $link control } " containing one or more children. The " { $link control-value } " is the index of exactly one child to be visible at any one time, the rest being hidden by having their " { $link gadget-visible? } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget."
$terpri
-"Books are created with " { $link <book> } "." } ;
+"Books are created by calling " { $link <book> } "." } ;
HELP: <book>
{ $values { "pages" "a sequence of gadgets" } { "book" book } }
{ $see-also "presentations" } ;
HELP: <command-button>
-{ $values { "target" object } { "command" command } { "button" "a new " button } }
+{ $values { "target" object } { "command" command } { "button" "a new " { $link button } } }
{ $description "Creates a " { $link <bevel-button> } " which invokes the command on " { $snippet "target" } " when clicked." }
{ $see-also <button> <roll-button> <presentation> } ;
gadgets-sliders generic kernel math namespaces sequences
models ;
-! A scroller combines a viewport with two x and y sliders.
-! The follows slot is t or a gadget
TUPLE: scroller viewport x y follows model ;
-: find-scroller [ scroller? ] find-parent ;
+: find-scroller ( gadget -- scroller/f )
+ [ scroller? ] find-parent ;
: scroll-up-page scroller-y -1 swap slide-by-page ;
over scroller-y control-model
2array <compose> swap set-scroller-model ;
-: scroller-value scroller-model model-value ;
+: scroller-value ( scroller -- loc )
+ scroller-model model-value ;
C: scroller ( gadget -- scroller )
{
t over set-gadget-root?
dup faint-boundary ;
-: set-slider ( value page max slider -- )
- #! page/max/value are 2-vectors.
- [ [ gadget-orientation v. ] keep set-slider-max ] keep
- [ [ gadget-orientation v. ] keep set-slider-page ] keep
- [ gadget-orientation v. ] keep set-slider-value ;
-
: update-slider ( scroller value slider -- )
>r swap scroller-viewport dup rect-dim swap viewport-dim
r> set-slider ;
>r >r v- { 0 0 } vmin r> r> v- { 0 0 } vmax v+
] keep dup scroller-value rot v+ scroll ;
-: relative-scroll-rect ( rect gadget scroller -- rect )
- #! Adjust rect for the case where the gadget is not the
- #! immediate child of the scroller's viewport.
+: relative-scroll-rect ( rect gadget scroller -- newrect )
scroller-viewport gadget-child relative-loc offset-rect ;
: scroll>rect ( rect gadget -- )
--- /dev/null
+IN: gadgets-scrolling
+USING: help gadgets gadgets-viewports gadgets-sliders ;
+
+HELP: scroller
+{ $class-description "A scroller consists of a " { $link viewport } " containing a child, together with horizontal and vertical " { $link slider } " gadgets which scroll the viewport's child. Scroller gadgets also support using a mouse scroll wheel."
+$terpri
+"Scroller gadgets are created by calling " { $link <scroller> } "." } ;
+
+HELP: find-scroller
+{ $values { "gadget" gadget } { "scroller/f" "a " { $link scroller } " or " { $link f } } }
+{ $description "Finds the first parent of " { $snippet "gadget" } " which is a " { $link scroller } ". Outputs " { $link f } " if the gadget is not contained in a " { $link scroller } "." } ;
+
+HELP: scroller-value
+{ $values { "scroller" scroller } { "loc" "a pair of integers" } }
+{ $description "Outputs the offset of the top-left corner of the scroller's " { $link viewport } "'s child." }
+{ $see-also scroll } ;
+
+HELP: <scroller>
+{ $values { "gadget" gadget } { "scroller" "a new " { $link scroller } } }
+{ $description "Creates a new " { $link scroller } " for scrolling around " { $snippet "gadget" } "." } ;
+
+HELP: scroll
+{ $values { "scroller" scroller } { "value" "a pair of integers" } }
+{ $description "Sets the offset of the top-left corner of the scroller's " { $link viewport } "'s child." }
+{ $see-also scroller-value } ;
+
+HELP: relative-scroll-rect
+{ $values { "rect" rect } { "gadget" gadget } { "scroller" scroller } { "newrect" "a new " { $link rect } } }
+{ $description "Adjusts " { $snippet "rect" } " for the case where the gadget is not the immediate child of the scroller's viewport." } ;
+
+HELP: scroll>rect
+{ $values { "rect" rect } { "gadget" gadget } }
+{ $description "Ensures that a rectangular region relative to the top-left corner of " { $snippet "gadget" } " becomes visible in a scroller containing " { $snippet "gadget" } ". If no parent of " { $snippet "scroller" } " is a gadget, does nothing." }
+{ $see-also scroll>bottom scroll>top } ;
+
+HELP: scroll>bottom
+{ $values { "gadget" gadget } }
+{ $description "Ensures that any scroller containing " { $snippet "gadget" } " is scrolled all the way down. If no parent of " { $snippet "scroller" } " is a gadget, does nothing." }
+{ $see-also scroll>rect scroll>top } ;
+
+HELP: scroll>top
+{ $values { "gadget" gadget } }
+{ $description "Ensures that any scroller containing " { $snippet "gadget" } " is scrolled all the way up. If no parent of " { $snippet "scroller" } " is a gadget, does nothing." }
+{ $see-also scroll>rect scroll>bottom } ;
gadgets-theme generic kernel math namespaces
sequences styles threads vectors models ;
-! An elevator has a thumb that may be moved up and down.
TUPLE: elevator ;
-: find-elevator [ elevator? ] find-parent ;
+: find-elevator ( gadget -- elevator/f )
+ [ elevator? ] find-parent ;
-! A slider scrolls a viewport.
TUPLE: slider elevator thumb saved max line page ;
-: find-slider [ slider? ] find-parent ;
+: find-slider ( gadget -- slider/f )
+ [ slider? ] find-parent ;
: elevator-length ( slider -- n )
dup slider-elevator rect-dim
<thumb> swap 2dup slider-elevator add-gadget
set-slider-thumb ;
-C: slider ( vector -- slider )
+C: slider ( orientation -- slider )
dup 0 <model> <frame> delegate>control
[ set-gadget-orientation ] keep
32 over set-slider-line
: <y-slider> ( -- slider )
{ 0 1 } <slider> dup build-y-slider
dup { 1 0 } add-thumb ;
+
+: set-slider ( value page max slider -- )
+ [ [ gadget-orientation v. ] keep set-slider-max ] keep
+ [ [ gadget-orientation v. ] keep set-slider-page ] keep
+ [ gadget-orientation v. ] keep set-slider-value ;
--- /dev/null
+IN: gadgets-sliders
+USING: help gadgets gadgets-scrolling models ;
+
+HELP: elevator
+{ $class-description "An elevator is the part of a " { $link slider } " between the up/down arrow buttons, where a " { $link thumb } " may be moved up and down." } ;
+
+HELP: find-elevator
+{ $values { "gadget" gadget } { "elevator/f" "an " { $link elevator } " or " { $link f } } }
+{ $description "Finds the first parent of " { $snippet "gadget" } " which is an " { $link elevator } ". Outputs " { $link f } " if the gadget is not contained in an " { $link elevator } "." } ;
+
+HELP: slider
+{ $class-description "A slider is a " { $link control } " for graphically manipulating a " { $link model } " whose value is an integer belonging to a certain range."
+$terpri
+"Sliders are created by calling " { $link <x-slider> } " or " { $link <y-slider> } ", and their canonical use-case is for scrolling; see " { $link scroller } "."
+$terpri
+"Sliders have the following slots:"
+{ $list
+ { { $link slider-max } " - maximum value, an integer" }
+ { { $link slider-line } " - amount to scroll when up/down arrows are clicked, an integer" }
+ { { $link slider-page } " - amount to scroll when paging areas above/below thumb are clicked, an integer" }
+}
+"They should not be changed directly; instead use " { $link set-slider } "." }
+{ $see-also set-slider-value set-slider slide-by slide-by-page } ;
+
+HELP: find-slider
+{ $values { "gadget" gadget } { "slider/f" "a " { $link slider } " or " { $link f } } }
+{ $description "Finds the first parent of " { $snippet "gadget" } " which is a " { $link slider } ". Outputs " { $link f } " if the gadget is not contained in a " { $link slider } "." } ;
+
+HELP: set-slider
+{ $values { "value" "a pair of integers" } { "page" "a pair of integers" } { "max" "a pair of integers" } { "slider" slider } }
+{ $description "Sets a slider's parameters all at once." }
+{ $see-also set-slider-value slide-by-page } ;
+
+HELP: set-slider-value
+{ $values { "value" "a non-negative integer" } { "slider" slider } }
+{ $description "Sets a slider's current position." }
+{ $see-also set-slider slide-by slide-by-page } ;
+
+HELP: thumb
+{ $class-description "A thumb is the gadget contained in a " { $link slider } "'s " { $link elevator } " which indicates the current scroll position and can be dragged up and down with the mouse." } ;
+
+HELP: slide-by
+{ $values { "amount" "an integer" } { "slider" slider } }
+{ $description "Adds the amount (which may be positive or negative) to the slider's current position." }
+{ $see-also set-slider-value set-slider slide-by-page } ;
+
+HELP: slide-by-page
+{ $values { "amount" "an integer" } { "slider" slider } }
+{ $description "Adds the amount multiplied by " { $link slider-page } " to the slider's current position." }
+{ $see-also set-slider-value set-slider slide-by-page } ;
+
+HELP: slide-by-line
+{ $values { "amount" "an integer" } { "slider" slider } }
+{ $description "Adds the amount multiplied by " { $link slider-line } " to the slider's current position." }
+{ $see-also set-slider-value set-slider slide-by-page } ;
+
+HELP: <slider>
+{ $values { "orientation" "either " { $snippet "{ 1 0 }" } " or " { $snippet "{ 0 1 }" } } { "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 <x-slider> } " or " { $link <y-slider> } " instead." } ;
+
+HELP: <x-slider>
+{ $values { "slider" slider } }
+{ $description "Creates a new horizontal " { $link slider } "." }
+{ $see-also <y-slider> } ;
+
+HELP: <y-slider>
+{ $values { "slider" slider } }
+{ $description "Creates a new horizontal " { $link slider } "." }
+{ $see-also <x-slider> } ;
over track-sizes push add-gadget ;
: build-track ( track specs -- )
- #! Specs is an array of quadruples { quot post setter loc }.
- #! The setter has stack effect ( new gadget -- ),
- #! the loc is a ratio from 0 to 1.
swap [ [ track-add ] build-spec ] with-gadget ; inline
: make-track ( specs orientation -- gadget )
--- /dev/null
+IN: gadgets-tracks
+USING: help gadgets ;
+
+HELP: track
+{ $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link <track> } "." }
+{ $see-also make-track make-track* } ;
+
+HELP: build-track
+{ $values { "track" track } { "specs" array } }
+{ $description "Constructs gadgets and adds them to the track by interpreting " { $snippet "spec" } ", which is an array of quadruples of the form " { $snippet "{ quot setter post ratio }" } ". The quadruples break down as follows:"
+ { $list
+ { { $snippet "quot" } " - a quotation which pushes a new gadget on the stack. The quotation is permitted to consume values from the stack, and it is up to the caller of " { $link build-grid } " to prove the correct amount." }
+ { { $snippet "setter" } " - a word with stack effect " { $link "( gadget grid -- )" } ". If " { $snippet "track" } " is a tuple delegating to a " { $link track } ", this can be used to store the new gadget in a tuple slot." }
+ { { $snippet "post" } " - a quotation with stack effect " { $snippet "( gadget -- newgadget )" } ", applied to the gadget before it is added to the grid" }
+ { { $snippet "ratio" } " - a rational number between 0 and 1 which determines the space allocation received by the child." }
+ }
+}
+{ $see-also make-track make-track* } ;
+
+HELP: make-track
+{ $values { "specs" array } { "track" track } }
+{ $description "Creates a new track from a declarative specification. See " { $link build-track } " for a description of the format of " { $snippet "spec" } "." } ;
+
+HELP: make-track*
+{ $values { "tuple" tuple } { "specs" array } { "track" track } }
+{ $description "Creates a new track from a declarative specification and sets " { $snippet "tuple" } "'s delegate to the new track. See " { $link build-track } " for a description of the format of " { $snippet "spec" } "." } ;
--- /dev/null
+IN: gadgets-viewports
+USING: help gadgets ;
+
+HELP: viewport
+{ $class-description "A viewport is a " { $link control } " which positions a child gadget translated by the " { $link control-value } " vector. Viewports are used in the implementation of " { $link scroller } " gadgets and can be created directly by calling " { $link <viewport> } "." } ;
+
+HELP: <viewport>
+{ $values { "content" gadget } { "model" model } }
+{ $description "Creates a new " { $link viewport } " containing " { $snippet "content" } "." }
+{ $see-also <scroller> } ;
{ $values { "gadget" gadget } { "parent" gadget } }
{ $description "Adds a child gadget to a parent. If the gadget is contained in another gadget, " { $link unparent } " is called on the gadget first. The parent will be relayout." }
{ $notes "Adding a gadget to a parent may result in " { $link graft* } " being called on the children, if the parent is visible on the screen." }
-{ $warning "Some gadget classes have their own words for adding children, for example " { $link grid-add } " and " { $link track-add } ". Read the documentation for the gadget class before using this word." }
+{ $warning "Some gadget classes have their own words for adding children, for example " { $link grid-add } " and " { $link add-incremental } ". Read the documentation for the gadget class before using this word." }
{ $side-effects "parent" } ;
HELP: add-gadgets
{ $values { "seq" "a sequence of gadgets" } { "parent" gadget } }
{ $description "Adds a sequence of gadgets to a parent. The parent will be relayout." }
{ $notes "This may result in " { $link graft* } " being called on the children, if the parent is visible on the screen." }
-{ $warning "Some gadget classes have their own words for adding children, for example " { $link grid-add } " and " { $link track-add } ". Read the documentation for the gadget class before using this word." }
+{ $warning "Some gadget classes have their own words for adding children, for example " { $link grid-add } " and " { $link add-incremental } ". Read the documentation for the gadget class before using this word." }
{ $side-effects "parent" } ;
HELP: parents
"gadgets/lists.facts"
"gadgets/menus.facts"
"gadgets/outliner.facts"
- "gadgets/presentations.facts"
"gadgets/panes.facts"
+ "gadgets/presentations.facts"
+ "gadgets/scrolling.facts"
+ "gadgets/sliders.facts"
+ "gadgets/tracks.facts"
+ "gadgets/viewports.facts"
"text/editor.facts"
} }
{ +tests+ {
projects / factor.git / commitdiff