Documented frames, grids, incremental, labels, lists, outliner

TODO.txt

@@ -33,6 +33,7 @@
   - string-lines
   - md5, crc32
   - all-words [ word-name ] map prune [ words-named ] map
+  - 100000 [ "\"hello\" not" eval drop ] times
 - auto-update browser and help when sources reload
 - mac intel: struct returns from objc methods
 - new windows don't always have focus, eg focus follows mouse

core/ui/gadgets/controls.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: gadgets
 USING: kernel models ;
+IN: gadgets
 
 TUPLE: control self model quot ;
 

core/ui/gadgets/frames.factor

@@ -39,5 +39,5 @@ M: frame layout*
 : make-frame ( specs -- gadget )
     <frame> [ swap build-grid ] keep ; inline
 
-: make-frame* ( gadget specs -- gadget )
+: make-frame* ( tuple specs -- gadget )
     over [ delegate>frame build-grid ] keep ; inline

core/ui/gadgets/frames.facts

@@ -1,5 +1,5 @@
 IN: help
-USING: gadgets ;
+USING: gadgets kernel arrays ;
 
 : $ui-frame-constant
     { $description "Symbolic constant for a common input to " { $link grid-add } "." } print-element ;
@@ -26,3 +26,16 @@ HELP: <frame>
 { $values { "frame" frame } }
 { $description "Creates a new " { $link frame } " for laying out gadgets in a 3x3 grid." }
 { $see-also delegate>frame make-frame make-frame* } ;
+
+HELP: delegate>frame
+{ $values { "tuple" tuple } }
+{ $description "Sets the tuple's delegate to a new " { $link frame } "." } 
+{ $side-effects "frame" } ;
+
+HELP: make-frame
+{ $values { "specs" array } { "frame" frame } }
+{ $description "Creates a new frame from a declarative specification. See " { $link build-grid } " for a description of the format of " { $snippet "spec" } "." } ;
+
+HELP: make-frame*
+{ $values { "tuple" tuple } { "specs" array } { "frame" frame } }
+{ $description "Creates a new frame from a declarative specification and sets " { $snippet "tuple" } "'s delegate to the new frame. See " { $link build-grid } " for a description of the format of " { $snippet "spec" } "." } ;

core/ui/gadgets/grid-lines.factor

@@ -3,7 +3,6 @@
 IN: gadgets
 USING: kernel math namespaces opengl sequences ;
 
-! You can set a grid's gadget-boundary to this.
 TUPLE: grid-lines color ;
 
 SYMBOL: grid-dim
@@ -16,12 +15,10 @@ SYMBOL: grid-dim
     grid-dim get swap rot set-axis ;
 
 : draw-grid-lines ( gaps orientation -- )
-    #! Clean this up later.
     swap grid-positions grid get rect-dim { 1 0 } v- add
     [ grid-line-from/to gl-line ] each-with ;
 
 M: grid-lines draw-boundary
-    #! Clean this up later.
     origin get [
         grid-lines-color gl-color [
             grid get rect-dim half-gap v- grid-dim set

core/ui/gadgets/grid-lines.facts

@@ -0,0 +1,5 @@
+IN: gadgets
+USING: help ;
+
+HELP: grid-lines
+{ $class-description "A class implementing the " { $link draw-boundary } " generic word to draw lines between the cells of a " { $link grid } ". The color of the lines is a color specifier stored in the " { $link grid-lines-color } " slot." } ;

core/ui/gadgets/grids.factor

@@ -6,8 +6,7 @@ USING: arrays kernel math namespaces sequences words ;
 TUPLE: grid children gap ;
 
 : set-grid-children* ( children grid -- )
-    [ set-grid-children ] 2keep
-    >r concat [ ] subset r> add-gadgets ;
+    [ set-grid-children ] 2keep >r concat r> add-gadgets ;
 
 C: grid ( children -- grid )
     dup delegate>gadget
@@ -35,8 +34,7 @@ C: grid ( children -- grid )
 
 : gap grid get grid-gap ;
 
-: (pair-up) ( horiz vert -- dim )
-    >r first r> second 2array ;
+: (pair-up) ( horiz vert -- dim ) >r first r> second 2array ;
 
 M: grid pref-dim*
     [
@@ -68,9 +66,6 @@ M: grid layout*
     [ grid-layout ] with-grid ;
 
 : build-grid ( grid specs -- )
-    #! Specs is an array of quadruples { quot post setter loc }.
-    #! The setter has stack effect ( new gadget -- ),
-    #! the loc is @center, @top, etc.
     swap [ [ grid-add ] build-spec ] with-gadget ; inline
 
 M: grid children-on ( rect gadget -- seq )

core/ui/gadgets/grids.facts

@@ -0,0 +1,41 @@
+IN: gadgets
+USING: help arrays ;
+
+HELP: grid
+{ $class-description "A grid gadget lays out its children so that all gadgets in a column have equal width and all gadgets in a row have equal height. The " { $link grid-gap } " slot stores a pair of integers, the horizontal and vertical gap between children, respectively."
+$terpri
+"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add } " and " { $link grid-remove } "."
+$terpri
+"The " { $link add-gadget } ", " { $link unparent } " and " { $link clear-gadget } " words should not be used to manage child gadgets of grids." }
+{ $see-also frame } ;
+
+HELP: <grid>
+{ $values { "children" "a sequence of sequences of gadgets" } }
+{ $description "Creates a new " { $link grid } " gadget with the given children." } ;
+
+HELP: grid-child
+{ $values { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } }
+{ $description "Outputs the child gadget at the " { $snippet "i" } "," { $snippet "j" } "th position of the grid." }
+{ $errors "Throws an error if the indices are out of bounds." } ;
+
+HELP: grid-add
+{ $values { "gadget" gadget } { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } }
+{ $description "Adds a child gadget at the specified location." }
+{ $side-effects "grid" } ;
+
+HELP: grid-remove
+{ $values { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } }
+{ $description "Removes a child gadget from the specified location." }
+{ $side-effects "grid" } ;
+
+HELP: build-grid
+{ $values { "grid" grid } { "specs" array } }
+{ $description "Constructs gadgets and adds them to the grid by interpreting " { $snippet "spec" } ", which is an array of quadruples of the form " { $snippet "{ quot setter post loc }" } ". 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 "grid" } " is a tuple delegating to a " { $link grid } ", 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 "loc" } " - a word with stack effect " { $snippet "( -- i j )" } " which pushes the grid location where to add the new gadget, for example " { $link @center } "." }
+    }
+}
+{ $see-also make-frame make-frame* } ;

core/ui/gadgets/incremental.facts

@@ -0,0 +1,28 @@
+IN: gadgets
+USING: help ;
+
+HELP: incremental
+{ $class-description "An incremental layout gadget delegates to a " { $link pack } " and implements an optimization which the relayout operation after adding a child to be done in constant time."
+$terpri
+"Incremental layout gadgets are created by calling " { $link <incremental> } "."
+$terpri
+"Children are managed with the " { $link add-incremental } " and " { $link clear-incremental } " words."
+$terpri
+"Not every " { $link pack } " can use incremental layout, since incremental layout does not support non-default values for " { $link pack-align } ", " { $link pack-fill } ", and " { $link pack-gap } "." } ;
+
+HELP: <incremental>
+{ $values { "pack" pack } { "incremental" "a new instance of " { $link incremental } } }
+{ $description "Creates a new incremental layout gadget delegating to " { $snippet "pack" } "." }
+{ $see-also add-incremental clear-incremental } ;
+
+HELP: add-incremental
+{ $values { "gadget" gadget } { "incremental" incremental } }
+{ $description "Adds the gadget to the incremental layout and performs relayout immediately in constant time." }
+{ $side-effects "incremental" }
+{ $see-also add-gadget clear-incremental } ;
+
+HELP: clear-incremental
+{ $values { "incremental" incremental } }
+{ $description "Removes all gadgets from the incremental layout and performs relayout immediately in constant time." }
+{ $side-effects "incremental" }
+{ $see-also add-gadget clear-incremental } ;

core/ui/gadgets/labelled-gadget.factor

@@ -6,7 +6,7 @@ queues sequences test threads help sequences words timers ;
 
 TUPLE: labelled-gadget content ;
 
-C: labelled-gadget ( gadget title -- gadget )
+C: labelled-gadget ( gadget title -- newgadget )
     {
         { [ <label> dup reverse-video-theme ] f f @top }
         { f set-labelled-gadget-content f @center }

core/ui/gadgets/labelled-gadget.facts

@@ -0,0 +1,17 @@
+IN: gadgets
+USING: help strings ;
+
+HELP: labelled-gadget
+{ $class-description "A labelled gadget can be created by calling " { $link <labelled-gadget> } "." } ;
+
+HELP: <labelled-gadget>
+{ $values { "gadget" gadget } { "title" string } { "newgadget" "a new " { $link <labelled-gadget> } } }
+{ $description "Creates a new " { $link labelled-gadget } " display " { $snippet "gadget" } " with " { $snippet "title" } " on top." } ;
+
+HELP: closable-gadget
+{ $class-description "A closable gadget displays a title bar with a close box on top of another gadget. Clicking the close box invokes a quotation. Closable gadgets are created by calling " { $link <closable-gadget> } "." } ;
+
+HELP: <closable-gadget>
+{ $values { "gadget" gadget } { "title" string } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } }
+{ $description "Creates a new " { $link closable-gadget } ". Clicking the close box calls " { $snippet "quot" } "." }
+{ $notes "The quotation can find the " { $link closable-gadget } " instance, or any other parent gadget by calling " { $link find-parent } " with the gadget it receives on the stack." } ;

core/ui/gadgets/labels.facts

@@ -0,0 +1,23 @@
+IN: gadgets-labels
+USING: help strings gadgets models ;
+
+HELP: label
+{ $class-description "A label displays a piece of text, either a single line string or an array of line strings. Labels are created by calling " { $link <label> } "." }
+{ $see-also label-string set-label-string <label-control> } ;
+
+HELP: <label>
+{ $values { "string" string } { "label" "a new " { $link label } } }
+{ $description "Creates a new " { $link label } " gadget. The string is permitted to contain line breaks." }
+{ $see-also label-string set-label-string <label-control> } ;
+
+HELP: label-string
+{ $values { "label" label } { "string" string } }
+{ $description "Outputs the string currently displayed by the label." } ;
+
+HELP: set-label-string
+{ $values { "label" label } { "string" string } }
+{ $description "Sets the string currently displayed by the label. The string is permitted to contain line breaks. After calling this word, you must also call " { $link relayout } " on the label." } ;
+
+HELP: <label-control>
+{ $values { "model" model } }
+{ $description "Creates a " { $link control } " which displays the value of " { $snippet "model" } ", which is required to be a string. The label control is automatically updated when the model value changes." } ;

core/ui/gadgets/lists.factor

@@ -88,9 +88,9 @@ M: list focusable-child* drop t ;
         dup list-index swap nth-gadget invoke-secondary
     ] if ; inline
 
-list H{
-    { T{ button-down } [ request-focus ] }
-    { T{ key-down f f "UP" } [ select-prev ] }
-    { T{ key-down f f "DOWN" } [ select-next ] }
-    { T{ key-down f f "RETURN" } [ list-action ] }
-} set-gestures
+list "commands" {
+    { "Request focus" T{ button-down } [ request-focus ] }
+    { "Select previous value" T{ key-down f f "UP" } [ select-prev ] }
+    { "Select next value" T{ key-down f f "DOWN" } [ select-next ] }
+    { "Invoke value action" T{ key-down f f "RETURN" } [ list-action ] }
+} define-commands

core/ui/gadgets/lists.facts

@@ -0,0 +1,22 @@
+IN: gadgets-lists
+USING: help gadgets gadgets-presentations generic models ;
+
+HELP: list
+{ $class-description
+    "A list " { $link control } " is backed by a " { $link model } " holding a sequence of objects, and displays as a list of " { $link presentation } " instances of these objects."
+    $terpri
+    "Lists are created by calling " { $link <list> } "."
+    $terpri
+    "Lists can be navigated from the keyboard:"
+    { $commands list "commands" }
+} ;
+
+HELP: <list>
+{ $values { "hook" "a quotation with stack effect " { $snippet "( list -- )" } } { "presenter" "a quotation with stack effect " { $snippet "( object -- label )" } } { "model" model } }
+{ $description "Creates a new " { $link list } "."
+$terpri
+"The model value must be a sequence. The list displays presentations of elements with labels obtained by applying the " { $snippet "presenter" } " quotation to each object. The " { $snippet "hook" } " quotation is called when a presentation is selected." } ;
+
+HELP: list-value
+{ $values { "list" list } { "object" object } }
+{ $description "Outputs the currently selected list value." } ;

core/ui/gadgets/outliner.factor

@@ -1,11 +1,10 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: gadgets-outliner
+IN: gadgets-outliners
 USING: arrays gadgets gadgets-borders gadgets-buttons
-gadgets-labels gadgets-panes gadgets-theme generic io kernel
+gadgets-labels gadgets-theme generic io kernel
 math opengl sequences styles namespaces ;
 
-! Vertical line.
 TUPLE: guide color ;
 
 M: guide draw-interior
@@ -19,13 +18,8 @@ M: guide draw-interior
 : <guide-gadget> ( -- gadget )
     <gadget> dup guide-theme ;
 
-! Outliner gadget.
 TUPLE: outliner quot ;
 
-: outliner-expanded? ( outliner -- ? )
-    #! If the outliner is expanded, it has a center gadget.
-    @center grid-child >boolean ;
-
 : find-outliner ( gadget -- outliner )
     [ outliner? ] find-parent ;
 
@@ -35,7 +29,7 @@ TUPLE: outliner quot ;
 
 DEFER: set-outliner-expanded?
 
-: <expand-button> ( ? -- gadget )
+: <expand-button> ( ? -- button )
     #! If true, the button expands, otherwise it collapses.
     dup [ swap find-outliner set-outliner-expanded? ] curry
     >r <expand-arrow> r> <button> ;
@@ -45,18 +39,16 @@ DEFER: set-outliner-expanded?
 
 : setup-center ( expanded? outliner -- )
     [
-        swap [ outliner-quot make-pane ] [ drop <gadget> ] if
+        swap [ outliner-quot call ] [ drop <gadget> ] if
     ] keep @center grid-add ;
 
 : setup-guide ( expanded? outliner -- )
     >r [ <guide-gadget> ] [ <gadget> ] if r> @left grid-add ;
 
-: set-outliner-expanded? ( expanded? outliner -- )
-    #! Call the expander quotation if expanding.
+: set-outliner-expanded? ( ? outliner -- )
     2dup setup-expand 2dup setup-center setup-guide ;
 
 C: outliner ( gadget quot -- gadget )
-    #! The quotation generates child gadgets.
     dup delegate>frame
     [ set-outliner-quot ] keep
     [ >r 1array make-shelf r> @top grid-add ] keep

core/ui/gadgets/outliner.facts

@@ -0,0 +1,25 @@
+IN: gadgets-outliners
+USING: help gadgets gadgets-buttons kernel ;
+
+TUPLE: guide
+{ $class-description "A class implementing the " { $link draw-interior } " generic word to draw a single vertical line." } ;
+
+TUPLE: outliner
+{ $class-description "A gadget with an expander arrow which can be clicked to show and hide a child gadget generated by the quotation stored in the " { $link outliner-quot } " slot. Outliners are created by calling " { $link <outliner> } "." }
+{ $see-also <outliner> "presentations" } ;
+
+HELP: <expand-button>
+{ $values { "?" "a boolean" } { "button" "a new " { $link button } } }
+{ $description "Creates a " { $link button } " which calls " { $link set-outliner-expanded? } " on an " { $link outliner } " parent with the given boolean." } ;
+
+HELP: set-outliner-expanded?
+{ $values { "?" "a boolean" } { "outliner" outliner } }
+{ $description "Shows or hides the content out of the outliner, depending on the value of the boolean. The content is generated by calling " { $link outliner-quot } "." }
+{ $see-also <outliner> } ;
+
+HELP: <outliner>
+{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( -- newgadget )" } } }
+{ $description { "Creates an " { $link outliner } " which displays " { $snippet "gadget" } " together with an expander arrow."
+$terpri
+"Clicking the expander arrow calls the quotation to generate a new gadget, and adds the gadget to the outliner. Clicking the expander arrow again removes the new gadget." } }
+{ $see-also "presentations" } ;

core/ui/gadgets/presentations.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets-presentations
 USING: arrays definitions gadgets gadgets-borders
-gadgets-buttons gadgets-labels gadgets-outliner
+gadgets-buttons gadgets-labels gadgets-outliners
 gadgets-panes gadgets-paragraphs gadgets-theme
 generic hashtables tools io kernel prettyprint sequences strings
 styles words help math models namespaces ;
@@ -130,7 +130,7 @@ presentation H{
     ] apply-style ;
 
 : apply-outliner-style ( style gadget -- style gadget )
-    outline [ <outliner> ] apply-style ;
+    outline [ [ make-pane ] curry <outliner> ] apply-style ;
 
 : <styled-paragraph> ( style pane -- gadget )
     apply-wrap-style

core/ui/gadgets/viewports.factor

@@ -4,7 +4,7 @@ IN: gadgets-viewports
 USING: arrays gadgets gadgets-borders generic kernel math
 namespaces sequences models ;
 
-: viewport-gap { 3 3 } ;
+: viewport-gap { 3 3 } ; inline
 
 TUPLE: viewport ;
 

core/ui/hierarchy.facts

@@ -1,5 +1,5 @@
 IN: gadgets
-USING: help gadgets-text ;
+USING: help gadgets-text gadgets-tracks ;
 
 HELP: graft*
 { $values { "gadget" gadget } }
@@ -26,22 +26,29 @@ HELP: ungraft
 HELP: unparent
 { $values { "gadget" gadget } }
 { $description "Removes the gadget from its parent. This will relayout the parent." }
-{ $notes "This may result in " { $link ungraft* } " being called on the gadget and its children, if the gadget's parent is visible on the screen." } ;
+{ $notes "This may result in " { $link ungraft* } " being called on the gadget and its children, if the gadget's parent is visible on the screen." }
+{ $warning "Some gadget classes have their own words for removing children, for example " { $link grid-remove } ". Read the documentation for the class of the gadget's parent before using this word." } ;
 
 HELP: clear-gadget
 { $values { "gadget" gadget } }
 { $description "Removes all children from the gadget. This will relayout the gadget." }
-{ $notes "This may result in " { $link ungraft* } " being called on the children, if the gadget is visible on the screen." } ;
+{ $notes "This may result in " { $link ungraft* } " being called on the children, if the gadget is visible on the screen." }
+{ $warning "Some gadget classes have their own words for adding children, for example " { $link grid-remove } ". Read the documentation for the gadget class before using this word." }
+{ $side-effects "gadget" } ;
 
 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." } ;
+{ $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." }
+{ $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." } ;
+{ $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." }
+{ $side-effects "parent" } ;
 
 HELP: parents
 { $values { "gadget" gadget } }

core/ui/load.factor

@@ -60,6 +60,13 @@ PROVIDE: core/ui
     "gadgets/buttons.facts"
     "gadgets/controls.facts"
     "gadgets/frames.facts"
+    "gadgets/grid-lines.facts"
+    "gadgets/grids.facts"
+    "gadgets/incremental.facts"
+    "gadgets/labelled-gadget.facts"
+    "gadgets/labels.facts"
+    "gadgets/lists.facts"
+    "gadgets/outliner.facts"
     "text/editor.facts"
 } }
 { +tests+ {