Use new accessors in place of old accessors from 'ui.gadgets'
Eduardo Cavazos
parent
bea0472941
commit
b33be738f9
|
|
@ -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 <book> } "." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 <toggle-buttons> } " word to construct a row of buttons for choosing among several alternatives." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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" } ;
|
||||
|
|
|
|||
|
|
@ -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 <pack> }
|
||||
{ $link <pile> }
|
||||
|
|
@ -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."
|
||||
} ;
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 <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 " { $snippet "orientation" } ". Tracks are created by calling " { $link <track> } "." } ;
|
||||
|
||||
HELP: <track>
|
||||
{ $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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" }
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@ TUPLE: deploy-gadget < pack vocab settings ;
|
|||
advanced-settings
|
||||
|
||||
deploy-settings-theme
|
||||
namespace <mapping> over set-gadget-model
|
||||
namespace <mapping> over (>>model)
|
||||
]
|
||||
bind ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
|
|||
<namestack-display> { 400 400 } <limited-scroller> ;
|
||||
|
||||
: variables ( traceback -- )
|
||||
gadget-model <variables-gadget>
|
||||
model>> <variables-gadget>
|
||||
"Dynamic variables" open-status-window ;
|
||||
|
||||
: traceback-window ( continuation -- )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
|
|
|
|||
Loading…
Reference in New Issue