From 14778affb684e32c8b4119eb416c8b9d25bf878c Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Thu, 14 Dec 2006 06:30:50 +0000
Subject: [PATCH] Finish documenting ui/gadgets: scrolling sliders tracks
 viewports

---
 TODO.txt                            |  1 -
 core/io/stream.facts                |  1 -
 core/test/math/integer.factor       |  1 +
 core/ui/gadgets/books.facts         |  2 +-
 core/ui/gadgets/presentations.facts |  2 +-
 core/ui/gadgets/scrolling.factor    | 18 +++-----
 core/ui/gadgets/scrolling.facts     | 44 ++++++++++++++++++
 core/ui/gadgets/sliders.factor      | 15 ++++---
 core/ui/gadgets/sliders.facts       | 70 +++++++++++++++++++++++++++++
 core/ui/gadgets/tracks.factor       |  3 --
 core/ui/gadgets/tracks.facts        | 26 +++++++++++
 core/ui/gadgets/viewports.facts     | 10 +++++
 core/ui/hierarchy.facts             |  4 +-
 core/ui/load.factor                 |  6 ++-
 14 files changed, 175 insertions(+), 28 deletions(-)
 create mode 100644 core/ui/gadgets/scrolling.facts
 create mode 100644 core/ui/gadgets/sliders.facts
 create mode 100644 core/ui/gadgets/tracks.facts
 create mode 100644 core/ui/gadgets/viewports.facts

diff --git a/TODO.txt b/TODO.txt
index 219b0c0e35..4c1135462b 100644
--- a/TODO.txt
+++ b/TODO.txt
@@ -9,7 +9,6 @@
 
 - poorly documented vocabs:
   - alien
-  - assembler
   - cocoa
   - command-line
   - compiler
diff --git a/core/io/stream.facts b/core/io/stream.facts
index b4586bf52a..d96b5197e3 100644
--- a/core/io/stream.facts
+++ b/core/io/stream.facts
@@ -75,7 +75,6 @@ HELP: with-stream-style
 { $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
diff --git a/core/test/math/integer.factor b/core/test/math/integer.factor
index f62ef9a0f2..e8c42243c7 100644
--- a/core/test/math/integer.factor
+++ b/core/test/math/integer.factor
@@ -117,3 +117,4 @@ unit-test
 ! 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
diff --git a/core/ui/gadgets/books.facts b/core/ui/gadgets/books.facts
index 11f7831161..b7d32ad6c1 100644
--- a/core/ui/gadgets/books.facts
+++ b/core/ui/gadgets/books.facts
@@ -4,7 +4,7 @@ USING: help gadgets ;
 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 } }
diff --git a/core/ui/gadgets/presentations.facts b/core/ui/gadgets/presentations.facts
index 20a589e8a1..a7f4b8bdff 100644
--- a/core/ui/gadgets/presentations.facts
+++ b/core/ui/gadgets/presentations.facts
@@ -45,7 +45,7 @@ HELP: <presentation>
 { $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> } ;
 
diff --git a/core/ui/gadgets/scrolling.factor b/core/ui/gadgets/scrolling.factor
index 4ef360e339..52f52c0e1c 100644
--- a/core/ui/gadgets/scrolling.factor
+++ b/core/ui/gadgets/scrolling.factor
@@ -5,11 +5,10 @@ USING: arrays gadgets gadgets-theme gadgets-viewports
 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 ;
 
@@ -33,7 +32,8 @@ scroller H{
     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 )
     {
@@ -51,12 +51,6 @@ 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 ;
@@ -76,9 +70,7 @@ C: scroller ( gadget -- scroller )
         >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 -- )
diff --git a/core/ui/gadgets/scrolling.facts b/core/ui/gadgets/scrolling.facts
new file mode 100644
index 0000000000..4bc3f7fe6c
--- /dev/null
+++ b/core/ui/gadgets/scrolling.facts
@@ -0,0 +1,44 @@
+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 } ;
diff --git a/core/ui/gadgets/sliders.factor b/core/ui/gadgets/sliders.factor
index 3c8fd5de32..bb03f49bf0 100644
--- a/core/ui/gadgets/sliders.factor
+++ b/core/ui/gadgets/sliders.factor
@@ -5,15 +5,15 @@ USING: arrays gadgets gadgets-buttons
 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
@@ -151,7 +151,7 @@ M: elevator layout*
     <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
@@ -165,3 +165,8 @@ C: slider ( vector -- slider )
 : <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 ;
diff --git a/core/ui/gadgets/sliders.facts b/core/ui/gadgets/sliders.facts
new file mode 100644
index 0000000000..cf2d0d74d5
--- /dev/null
+++ b/core/ui/gadgets/sliders.facts
@@ -0,0 +1,70 @@
+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> } ;
diff --git a/core/ui/gadgets/tracks.factor b/core/ui/gadgets/tracks.factor
index f8c17b1f42..8f1d9c7f4c 100644
--- a/core/ui/gadgets/tracks.factor
+++ b/core/ui/gadgets/tracks.factor
@@ -30,9 +30,6 @@ M: track pref-dim*
     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 )
diff --git a/core/ui/gadgets/tracks.facts b/core/ui/gadgets/tracks.facts
new file mode 100644
index 0000000000..4e3d766b8a
--- /dev/null
+++ b/core/ui/gadgets/tracks.facts
@@ -0,0 +1,26 @@
+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" } "." } ;
diff --git a/core/ui/gadgets/viewports.facts b/core/ui/gadgets/viewports.facts
new file mode 100644
index 0000000000..8748e4d032
--- /dev/null
+++ b/core/ui/gadgets/viewports.facts
@@ -0,0 +1,10 @@
+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> } ;
diff --git a/core/ui/hierarchy.facts b/core/ui/hierarchy.facts
index b77bf66da1..7e65c220ad 100644
--- a/core/ui/hierarchy.facts
+++ b/core/ui/hierarchy.facts
@@ -40,14 +40,14 @@ HELP: add-gadget
 { $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
diff --git a/core/ui/load.factor b/core/ui/load.factor
index 753ce15c4d..1ef42c09ef 100644
--- a/core/ui/load.factor
+++ b/core/ui/load.factor
@@ -68,8 +68,12 @@ PROVIDE: core/ui
     "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+ {