diff --git a/basis/ui/gadgets/books/books-docs.factor b/basis/ui/gadgets/books/books-docs.factor index 01426b4457..f6f5d7dd4d 100755 --- a/basis/ui/gadgets/books/books-docs.factor +++ b/basis/ui/gadgets/books/books-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax ui.gadgets models ; IN: ui.gadgets.books HELP: book -{ $class-description "A book is a 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." +{ $class-description "A book is a 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 " { $snippet "visible?" } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget." $nl "Books are created by calling " { $link } "." } ; diff --git a/basis/ui/gadgets/buttons/buttons-docs.factor b/basis/ui/gadgets/buttons/buttons-docs.factor index 59270ead79..b975416e97 100755 --- a/basis/ui/gadgets/buttons/buttons-docs.factor +++ b/basis/ui/gadgets/buttons/buttons-docs.factor @@ -5,7 +5,7 @@ IN: ui.gadgets.buttons HELP: button { $class-description "A button is a " { $link gadget } " which responds to mouse clicks by invoking a quotation." $nl -"A button's appearance can vary depending on the state of the mouse button if the " { $link gadget-interior } " or " { $link gadget-boundary } " slots are set to instances of " { $link button-paint } "." +"A button's appearance can vary depending on the state of the mouse button if the " { $snippet "interior" } " or " { $snippet "boundary" } " slots are set to instances of " { $link button-paint } "." $nl "A button can be selected, which is distinct from being pressed. This state is held in the " { $link button-selected? } " slot, and is used by the " { $link } " word to construct a row of buttons for choosing among several alternatives." } ; diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 6e09fd73b2..d8810824c6 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -38,12 +38,12 @@ focused? ; : activate-editor-model ( editor model -- ) 2dup add-connection dup activate-model - swap gadget-model add-loc ; + swap model>> add-loc ; : deactivate-editor-model ( editor model -- ) 2dup remove-connection dup deactivate-model - swap gadget-model remove-loc ; + swap model>> remove-loc ; M: editor graft* dup @@ -60,11 +60,11 @@ M: editor ungraft* : editor-mark* ( editor -- loc ) editor-mark model-value ; : set-caret ( loc editor -- ) - [ gadget-model validate-loc ] keep + [ model>> validate-loc ] keep editor-caret set-model ; : change-caret ( editor quot -- ) - over >r >r dup editor-caret* swap gadget-model r> call r> + over >r >r dup editor-caret* swap model>> r> call r> set-caret ; inline : mark>caret ( editor -- ) @@ -81,7 +81,7 @@ M: editor ungraft* editor-font* "" string-height ; : y>line ( y editor -- line# ) - [ line-height / >fixnum ] keep gadget-model validate-line ; + [ line-height / >fixnum ] keep model>> validate-line ; : point>loc ( point editor -- loc ) [ @@ -157,7 +157,7 @@ M: editor ungraft* swap dup first-visible-line \ first-visible-line set dup last-visible-line \ last-visible-line set - dup gadget-model document set + dup model>> document set editor set call ] with-scope ; inline @@ -227,19 +227,19 @@ M: editor gadget-selection? selection-start/end = not ; M: editor gadget-selection - [ selection-start/end ] keep gadget-model doc-range ; + [ selection-start/end ] keep model>> doc-range ; : remove-selection ( editor -- ) - [ selection-start/end ] keep gadget-model remove-doc-range ; + [ selection-start/end ] keep model>> remove-doc-range ; M: editor user-input* - [ selection-start/end ] keep gadget-model set-doc-range t ; + [ selection-start/end ] keep model>> set-doc-range t ; : editor-string ( editor -- string ) - gadget-model doc-string ; + model>> doc-string ; : set-editor-string ( string editor -- ) - gadget-model set-doc-string ; + model>> set-doc-string ; M: editor gadget-text* editor-string % ; @@ -257,12 +257,12 @@ M: editor gadget-text* editor-string % ; : drag-selection-caret ( loc editor element -- loc ) >r [ drag-direction? ] 2keep - gadget-model + model>> r> prev/next-elt ? ; : drag-selection-mark ( loc editor element -- loc ) >r [ drag-direction? not ] 2keep - nip dup editor-mark* swap gadget-model + nip dup editor-mark* swap model>> r> prev/next-elt ? ; : drag-caret&mark ( editor -- caret mark ) @@ -282,8 +282,8 @@ M: editor gadget-text* editor-string % ; over gadget-selection? [ drop nip remove-selection ] [ - over >r >r dup editor-caret* swap gadget-model - r> call r> gadget-model remove-doc-range + over >r >r dup editor-caret* swap model>> + r> call r> model>> remove-doc-range ] if ; inline : editor-delete ( editor elt -- ) @@ -309,7 +309,7 @@ M: editor gadget-text* editor-string % ; : select-elt ( editor elt -- ) over >r - >r dup editor-caret* swap gadget-model r> prev/next-elt + >r dup editor-caret* swap model>> r> prev/next-elt r> editor-select ; : start-of-document ( editor -- ) T{ doc-elt } editor-prev ; diff --git a/basis/ui/gadgets/gadgets-docs.factor b/basis/ui/gadgets/gadgets-docs.factor index f0ba3518bd..394841c599 100755 --- a/basis/ui/gadgets/gadgets-docs.factor +++ b/basis/ui/gadgets/gadgets-docs.factor @@ -31,7 +31,7 @@ HELP: user-input* HELP: children-on { $values { "rect/point" "a " { $link rect } " or a pair of integers" } { "gadget" gadget } { "seq" "a sequence of gadgets" } } { $contract "Outputs a sequence of gadgets which potentially intersect a rectangle or contain a point in the co-ordinate system of the gadget." } -{ $notes "This does not have to be an accurate intersection test, and simply returning " { $link gadget-children } " is a valid implementation. However, an accurate intersection test reduces the amount of work done when drawing this gadget if it is partially clipped and not all children are visible." } ; +{ $notes "This does not have to be an accurate intersection test, and simply returning " { $snippet "children" } " is a valid implementation. However, an accurate intersection test reduces the amount of work done when drawing this gadget if it is partially clipped and not all children are visible." } ; HELP: pick-up { $values { "point" "a pair of integers" } { "gadget" gadget } { "child/f" "a " { $link gadget } " or " { $link f } } } @@ -57,7 +57,7 @@ HELP: gadget-selection HELP: relayout { $values { "gadget" gadget } } -{ $description "Relayout and redraw a gadget before the next iteration of the event loop. Unlike " { $link relayout-1 } ", this relayouts all parents up to a gadget having " { $link gadget-root? } " set, so this word should be used when the gadget's dimensions have potentially changed." } ; +{ $description "Relayout and redraw a gadget before the next iteration of the event loop. Unlike " { $link relayout-1 } ", this relayouts all parents up to a gadget having " { $snippet "root?" } " set, so this word should be used when the gadget's dimensions have potentially changed." } ; HELP: relayout-1 { $values { "gadget" gadget } } @@ -170,7 +170,7 @@ HELP: focusable-child { $values { "gadget" gadget } { "child" gadget } } { $description "Outputs the child of the gadget which would prefer to receive keyboard focus." } ; -{ control-value set-control-value gadget-model } related-words +{ control-value set-control-value } related-words HELP: control-value { $values { "control" gadget } { "value" object } } @@ -181,10 +181,9 @@ HELP: set-control-value { $description "Sets the value of the control's model." } ; ARTICLE: "ui-control-impl" "Implementing controls" -"A " { $emphasis "control" } " is a gadget which is linked to an underlying " { $link model } " by having its " { $link gadget-model } " slot set to a " { $link model } " instance." +"A " { $emphasis "control" } " is a gadget which is linked to an underlying " { $link model } " by having its " { $snippet "model" } " slot set to a " { $link model } " instance." $nl "Some utility words useful in control implementations:" -{ $subsection gadget-model } { $subsection control-value } { $subsection set-control-value } { $see-also "models" } ; diff --git a/basis/ui/gadgets/packs/packs-docs.factor b/basis/ui/gadgets/packs/packs-docs.factor index 7d28e84e88..32f4fe1a36 100755 --- a/basis/ui/gadgets/packs/packs-docs.factor +++ b/basis/ui/gadgets/packs/packs-docs.factor @@ -15,7 +15,7 @@ ARTICLE: "ui-pack-layout" "Pack layouts" { $subsection pack-layout } ; HELP: pack -{ $class-description "A gadget which lays out its children along a single axis stored in the " { $link gadget-orientation } " slot. Can be constructed with one of the following words:" +{ $class-description "A gadget which lays out its children along a single axis stored in the " { $snippet "orientation" } " slot. Can be constructed with one of the following words:" { $list { $link } { $link } @@ -31,7 +31,7 @@ HELP: pack HELP: pack-layout { $values { "pack" "a new " { $link pack } } { "sizes" "a sequence of pairs of integers" } } -{ $description "Lays out the pack's children along the " { $link gadget-orientation } " of the pack, with each gadget receiving its size from the corresponding index of the " { $snippet "sizes" } " sequence." } +{ $description "Lays out the pack's children along the " { $snippet "orientation" } " of the pack, with each gadget receiving its size from the corresponding index of the " { $snippet "sizes" } " sequence." } { $notes "This word is useful if you are writing your own layout gadget which inherits from " { $link pack } ". This allows you to reuse layout logic while computing gadget sizes using a custom procedure." } ; diff --git a/basis/ui/gadgets/sliders/sliders-docs.factor b/basis/ui/gadgets/sliders/sliders-docs.factor index e58e4fe7e9..55e1751be5 100755 --- a/basis/ui/gadgets/sliders/sliders-docs.factor +++ b/basis/ui/gadgets/sliders/sliders-docs.factor @@ -56,6 +56,6 @@ ARTICLE: "ui.gadgets.sliders" "Slider gadgets" { $subsection slide-by } { $subsection slide-by-line } { $subsection slide-by-page } -"Since sliders are controls the value can be get and set by calling " { $link gadget-model } "." ; +"Since sliders are controls the value can be get and set by via the " { $snippet "model" } " slot. " ; ABOUT: "ui.gadgets.sliders" diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor index 294229ddd5..92e287a032 100755 --- a/basis/ui/gadgets/sliders/sliders.factor +++ b/basis/ui/gadgets/sliders/sliders.factor @@ -20,10 +20,10 @@ TUPLE: slider < frame elevator thumb saved line ; : min-thumb-dim 15 ; -: slider-value ( gadget -- n ) gadget-model range-value >fixnum ; -: slider-page ( gadget -- n ) gadget-model range-page-value ; -: slider-max ( gadget -- n ) gadget-model range-max-value ; -: slider-max* ( gadget -- n ) gadget-model range-max-value* ; +: 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* ; : thumb-dim ( slider -- h ) dup slider-page over slider-max 1 max / 1 min @@ -51,7 +51,7 @@ TUPLE: thumb < gadget ; : do-drag ( thumb -- ) find-slider drag-loc over orientation>> v. over screen>slider swap [ slider-saved + ] keep - gadget-model set-range-value ; + model>> set-range-value ; thumb H{ { T{ button-down } [ begin-drag ] } @@ -69,9 +69,9 @@ thumb H{ t >>root? thumb-theme ; -: slide-by ( amount slider -- ) gadget-model move-by ; +: slide-by ( amount slider -- ) model>> move-by ; -: slide-by-page ( amount slider -- ) gadget-model move-by-page ; +: slide-by-page ( amount slider -- ) model>> move-by-page ; : compute-direction ( elevator -- -1/1 ) dup find-slider swap hand-click-rel diff --git a/basis/ui/gadgets/tracks/tracks-docs.factor b/basis/ui/gadgets/tracks/tracks-docs.factor index 7fbbd1a330..9ed5bf4223 100755 --- a/basis/ui/gadgets/tracks/tracks-docs.factor +++ b/basis/ui/gadgets/tracks/tracks-docs.factor @@ -11,7 +11,7 @@ ARTICLE: "ui-track-layout" "Track layouts" { $subsection track-add } ; 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 } "." } ; +{ $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 " { $snippet "orientation" } ". Tracks are created by calling " { $link } "." } ; HELP: { $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } } diff --git a/basis/ui/gadgets/viewports/viewports.factor b/basis/ui/gadgets/viewports/viewports.factor index 5a896d8d62..79aca6bd35 100755 --- a/basis/ui/gadgets/viewports/viewports.factor +++ b/basis/ui/gadgets/viewports/viewports.factor @@ -31,7 +31,7 @@ M: viewport focusable-child* M: viewport pref-dim* viewport-dim ; : scroller-value ( scroller -- loc ) - gadget-model range-value [ >fixnum ] map ; + model>> range-value [ >fixnum ] map ; M: viewport model-changed nip diff --git a/basis/ui/render/render-docs.factor b/basis/ui/render/render-docs.factor index a969ba202d..04b623672d 100755 --- a/basis/ui/render/render-docs.factor +++ b/basis/ui/render/render-docs.factor @@ -31,17 +31,17 @@ HELP: draw-gadget* HELP: draw-interior { $values { "interior" object } { "gadget" gadget } } -{ $contract "Draws the interior of a gadget by making OpenGL calls. The " { $link gadget-interior } " slot may be set to objects implementing this generic word." } ; +{ $contract "Draws the interior of a gadget by making OpenGL calls. The " { $snippet "interior" } " slot may be set to objects implementing this generic word." } ; HELP: draw-boundary { $values { "boundary" object } { "gadget" gadget } } -{ $contract "Draws the boundary of a gadget by making OpenGL calls. The " { $link gadget-boundary } " slot may be set to objects implementing this generic word." } ; +{ $contract "Draws the boundary of a gadget by making OpenGL calls. The " { $snippet "boundary" } " slot may be set to objects implementing this generic word." } ; HELP: solid { $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid fill, respectively. The " { $link solid-color } " slot stores a color specifier." } ; HELP: gradient -{ $class-description "A class implementing the " { $link draw-interior } " generic word to draw a smoothly shaded transition between colors. The " { $link gradient-colors } " slot stores a sequence of color specifiers and the gradient is drawn in the direction given by the " { $link gadget-orientation } " slot of the gadget." } ; +{ $class-description "A class implementing the " { $link draw-interior } " generic word to draw a smoothly shaded transition between colors. The " { $link gradient-colors } " slot stores a sequence of color specifiers and the gradient is drawn in the direction given by the " { $snippet "orientation" } " slot of the gadget." } ; HELP: polygon { $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid filled polygon, respectively. Instances of " { $link polygon } " have two slots:" @@ -94,17 +94,17 @@ ARTICLE: "gadgets-polygons" "Polygon gadgets" ARTICLE: "ui-paint" "Customizing gadget appearance" "The UI carries out the following steps when drawing a gadget:" { $list - { "The " { $link draw-interior } " generic word is called on the value of the " { $link gadget-interior } " slot." } + { "The " { $link draw-interior } " generic word is called on the value of the " { $snippet "interior" } " slot." } { "The " { $link draw-gadget* } " generic word is called on the gadget." } { "The gadget's visible children are drawn, determined by calling " { $link visible-children } " on the gadget." } - { "The " { $link draw-boundary } " generic word is called on the value of the " { $link gadget-boundary } " slot." } + { "The " { $link draw-boundary } " generic word is called on the value of the " { $snippet "boundary" } " slot." } } "Now, each one of these steps will be covered in detail." { $subsection "ui-pen-protocol" } { $subsection "ui-paint-custom" } ; ARTICLE: "ui-pen-protocol" "UI pen protocol" -"The " { $link gadget-interior } " and " { $link gadget-boundary } " slots of a gadget facilitate easy factoring and sharing of drawing logic. Objects stored in these slots must implement the pen protocol:" +"The " { $snippet "interior" } " and " { $snippet "boundary" } " slots of a gadget facilitate easy factoring and sharing of drawing logic. Objects stored in these slots must implement the pen protocol:" { $subsection draw-interior } { $subsection draw-boundary } "The default value of these slots is the " { $link f } " singleton, which implements the above protocol by doing nothing." @@ -139,7 +139,7 @@ $nl $nl "OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa." $nl -"Gadgets must not draw outside of their bounding box, however clipping is not enforced by default, for performance reasons. This can be changed by setting the " { $link gadget-clipped? } " slot to " { $link t } " in the gadget's constructor." +"Gadgets must not draw outside of their bounding box, however clipping is not enforced by default, for performance reasons. This can be changed by setting the " { $snippet "clipped?" } " slot to " { $link t } " in the gadget's constructor." $nl "Saving the " { $link GL_MODELVIEW } " matrix and enabling/disabling flags can be done in a clean way using the combinators documented in the following section." { $subsection "gl-utilities" } diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor index e669ec8a52..c7bfc99024 100644 --- a/basis/ui/render/render.factor +++ b/basis/ui/render/render.factor @@ -63,7 +63,7 @@ DEFER: draw-gadget dup dup interior>> draw-interior dup draw-gadget* dup visible-children [ draw-gadget ] each - dup gadget-boundary draw-boundary + dup boundary>> draw-boundary ] with-scope ; : >absolute ( rect -- rect ) diff --git a/basis/ui/tools/deploy/deploy.factor b/basis/ui/tools/deploy/deploy.factor index 636323e7a8..b68e5162a3 100755 --- a/basis/ui/tools/deploy/deploy.factor +++ b/basis/ui/tools/deploy/deploy.factor @@ -57,7 +57,7 @@ TUPLE: deploy-gadget < pack vocab settings ; advanced-settings deploy-settings-theme - namespace over set-gadget-model + namespace over (>>model) ] bind ; diff --git a/basis/ui/tools/interactor/interactor.factor b/basis/ui/tools/interactor/interactor.factor index c277440db7..624a6e5b83 100755 --- a/basis/ui/tools/interactor/interactor.factor +++ b/basis/ui/tools/interactor/interactor.factor @@ -54,7 +54,7 @@ M: interactor ungraft* : word-at-loc ( loc interactor -- word ) over [ - [ gadget-model T{ one-word-elt } elt-string ] keep + [ model>> T{ one-word-elt } elt-string ] keep interactor-use assoc-stack ] [ 2drop f @@ -82,7 +82,7 @@ M: interactor model-changed : interactor-continue ( obj interactor -- ) mailbox>> mailbox-put ; -: clear-input ( interactor -- ) gadget-model clear-doc ; +: clear-input ( interactor -- ) model>> clear-doc ; : interactor-finish ( interactor -- ) #! The spawn is a kludge to make it infer. Stupid. diff --git a/basis/ui/tools/traceback/traceback.factor b/basis/ui/tools/traceback/traceback.factor index 6438bc0ebb..05cb043e49 100755 --- a/basis/ui/tools/traceback/traceback.factor +++ b/basis/ui/tools/traceback/traceback.factor @@ -46,7 +46,7 @@ M: traceback-gadget pref-dim* drop { 550 600 } ; { 400 400 } ; : variables ( traceback -- ) - gadget-model + model>> "Dynamic variables" open-status-window ; : traceback-window ( continuation -- ) diff --git a/basis/ui/tools/workspace/workspace.factor b/basis/ui/tools/workspace/workspace.factor index 0780103415..bc758e9eb8 100755 --- a/basis/ui/tools/workspace/workspace.factor +++ b/basis/ui/tools/workspace/workspace.factor @@ -29,7 +29,7 @@ M: gadget tool-scroller drop f ; book>> children>> [ class eq? ] with find ; : show-tool ( class workspace -- tool ) - [ find-tool swap ] keep workspace-book gadget-model + [ find-tool swap ] keep workspace-book model>> set-model ; : select-tool ( workspace class -- ) swap show-tool drop ; diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index 1d409a48c7..2bc2a7ec5d 100755 --- a/basis/ui/ui-docs.factor +++ b/basis/ui/ui-docs.factor @@ -83,7 +83,7 @@ ARTICLE: "ui-glossary" "UI glossary" ARTICLE: "building-ui" "Building user interfaces" "A gadget is a graphical element which responds to user input. Gadgets are implemented as tuples which (directly or indirectly) inherit from " { $link gadget } ", which in turn inherits from " { $link rect } "." { $subsection gadget } -"Gadgets are arranged in a hierarchy, and all visible gadgets except for instances of " { $link world } " are contained in a parent gadget, stored in the " { $link gadget-parent } " slot." +"Gadgets are arranged in a hierarchy, and all visible gadgets except for instances of " { $link world } " are contained in a parent gadget, stored in the " { $snippet "parent" } " slot." { $subsection "ui-geometry" } { $subsection "ui-layouts" } { $subsection "gadgets" } @@ -119,8 +119,10 @@ ARTICLE: "ui-geometry" "Gadget geometry" { $subsection offset-rect } { $subsection rect-intersect } { $subsection intersects? } -"A gadget's bounding box is always relative to its parent:" -{ $subsection gadget-parent } + +! "A gadget's bounding box is always relative to its parent. " +! { $subsection gadget-parent } + "Word for converting from a child gadget's co-ordinate system to a parent's:" { $subsection relative-loc } { $subsection screen-loc } @@ -211,8 +213,8 @@ $nl { $subsection unparent } { $subsection add-gadgets } { $subsection clear-gadget } -"Working with gadget children:" -{ $subsection gadget-children } +"The children of a gadget are available via the " +{ $snippet "children" } " slot. " "Working with gadget children:" { $subsection gadget-child } { $subsection nth-gadget } { $subsection each-child }