- 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
! 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 ;
: 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
IN: help
-USING: gadgets ;
+USING: gadgets kernel arrays ;
: $ui-frame-constant
{ $description "Symbolic constant for a common input to " { $link grid-add } "." } print-element ;
{ $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" } "." } ;
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
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
--- /dev/null
+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." } ;
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
: 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*
[
[ 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 )
--- /dev/null
+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* } ;
--- /dev/null
+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 } ;
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 }
--- /dev/null
+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." } ;
--- /dev/null
+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." } ;
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
--- /dev/null
+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." } ;
! 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
: <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 ;
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> ;
: 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
--- /dev/null
+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" } ;
! 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 ;
] 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
USING: arrays gadgets gadgets-borders generic kernel math
namespaces sequences models ;
-: viewport-gap { 3 3 } ;
+: viewport-gap { 3 3 } ; inline
TUPLE: viewport ;
IN: gadgets
-USING: help gadgets-text ;
+USING: help gadgets-text gadgets-tracks ;
HELP: graft*
{ $values { "gadget" gadget } }
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 } }
"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+ {
projects / factor.git / commitdiff