Add horizontal and vertical orientation constants, working on baseline alignment
Slava Pestov
parent
7b2a705352
commit
d31b902f96
|
|
@ -150,15 +150,10 @@ M: checkmark-paint draw-interior
|
|||
: toggle-model ( model -- )
|
||||
[ not ] change-model ;
|
||||
|
||||
: checkbox-theme ( gadget -- gadget )
|
||||
f >>interior
|
||||
{ 5 5 } >>gap
|
||||
1/2 >>align ; inline
|
||||
|
||||
TUPLE: checkbox < button ;
|
||||
|
||||
: <checkbox> ( model label -- checkbox )
|
||||
<checkmark> label-on-right checkbox-theme
|
||||
<checkmark> label-on-right
|
||||
[ model>> toggle-model ]
|
||||
checkbox new-button
|
||||
swap >>model
|
||||
|
|
@ -173,7 +168,7 @@ TUPLE: radio-paint < caching-pen color interior-vertices boundary-vertices ;
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: circle-steps 8 ;
|
||||
CONSTANT: circle-steps 8
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -223,12 +218,8 @@ M: radio-control model-changed
|
|||
:: <radio-controls> ( parent model assoc quot: ( value model label -- gadget ) -- parent )
|
||||
assoc model [ parent swap quot call add-gadget ] assoc-each ; inline
|
||||
|
||||
: radio-button-theme ( gadget -- gadget )
|
||||
{ 5 5 } >>gap
|
||||
1/2 >>align ; inline
|
||||
|
||||
: <radio-button> ( value model label -- gadget )
|
||||
<radio-knob> label-on-right radio-button-theme <radio-control> ;
|
||||
<radio-knob> label-on-right <radio-control> ;
|
||||
|
||||
: <radio-buttons> ( model assoc -- gadget )
|
||||
<filled-pile>
|
||||
|
|
|
|||
|
|
@ -242,6 +242,9 @@ M: editor draw-gadget*
|
|||
M: editor pref-dim*
|
||||
[ font>> ] [ control-value ] bi text-dim ;
|
||||
|
||||
M: editor baseline
|
||||
font>> "" line-metrics ascent>> ;
|
||||
|
||||
: contents-changed ( model editor -- )
|
||||
swap
|
||||
over caret>> [ over validate-loc ] (change-model)
|
||||
|
|
@ -585,7 +588,7 @@ TUPLE: field < wrapper editor min-width max-width ;
|
|||
gray <solid> >>boundary ; inline
|
||||
|
||||
: <field-border> ( gadget -- border )
|
||||
2 <border>
|
||||
{ 2 2 } <border>
|
||||
{ 1 0 } >>fill
|
||||
field-theme ;
|
||||
|
||||
|
|
|
|||
|
|
@ -6,6 +6,10 @@ binary-search vectors dlists deques models threads
|
|||
concurrency.flags math.order math.geometry.rect fry ;
|
||||
IN: ui.gadgets
|
||||
|
||||
! Values for orientation slot
|
||||
CONSTANT: horizontal { 1 0 }
|
||||
CONSTANT: vertical { 0 1 }
|
||||
|
||||
TUPLE: gadget < rect pref-dim parent children orientation focus
|
||||
visible? root? clipped? layout-state graft-state graft-node
|
||||
interior boundary model ;
|
||||
|
|
@ -103,14 +107,14 @@ GENERIC: gadget-text* ( gadget -- )
|
|||
GENERIC: gadget-text-separator ( gadget -- str )
|
||||
|
||||
M: gadget gadget-text-separator
|
||||
orientation>> { 0 1 } = "\n" "" ? ;
|
||||
orientation>> vertical = "\n" "" ? ;
|
||||
|
||||
: gadget-seq-text ( seq gadget -- )
|
||||
gadget-text-separator swap
|
||||
[ dup % ] [ gadget-text* ] interleave drop ;
|
||||
|
||||
M: gadget gadget-text*
|
||||
dup children>> swap gadget-seq-text ;
|
||||
[ children>> ] keep gadget-seq-text ;
|
||||
|
||||
M: array gadget-text*
|
||||
[ gadget-text* ] each ;
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ M: grid-lines draw-boundary
|
|||
[ grid set ]
|
||||
[ dim>> half-gap v- grid-dim set ]
|
||||
[ compute-grid ] tri
|
||||
[ { 1 0 } draw-grid-lines ]
|
||||
[ { 0 1 } draw-grid-lines ]
|
||||
[ horizontal draw-grid-lines ]
|
||||
[ vertical draw-grid-lines ]
|
||||
bi*
|
||||
] with-scope ;
|
||||
|
|
|
|||
|
|
@ -48,8 +48,8 @@ grid
|
|||
dupd add-gaps dim-sum v+ ;
|
||||
|
||||
M: grid pref-dim*
|
||||
dup gap>> swap compute-grid [ over ] dip
|
||||
[ gap-sum ] 2bi@ (pair-up) ;
|
||||
[ gap>> ] [ compute-grid ] bi
|
||||
[ over ] dip [ gap-sum ] 2bi@ (pair-up) ;
|
||||
|
||||
: do-grid ( dims grid quot -- )
|
||||
[ grid>> ] dip '[ _ 2each ] 2each ; inline
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ TUPLE: incremental < pack cursor ;
|
|||
|
||||
: <incremental> ( -- incremental )
|
||||
incremental new-gadget
|
||||
{ 0 1 } >>orientation
|
||||
vertical >>orientation
|
||||
{ 0 0 } >>cursor ;
|
||||
|
||||
M: incremental pref-dim*
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ IN: ui.gadgets.labelled
|
|||
TUPLE: labelled-gadget < track content ;
|
||||
|
||||
: <labelled-gadget> ( gadget title -- newgadget )
|
||||
{ 0 1 } labelled-gadget new-track
|
||||
vertical labelled-gadget new-track
|
||||
swap <label> reverse-video-theme f track-add
|
||||
swap >>content
|
||||
dup content>> 1 track-add ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays hashtables io kernel math namespaces
|
||||
make opengl sequences strings splitting ui.gadgets
|
||||
ui.gadgets.tracks fonts ui.render
|
||||
ui.text colors models ;
|
||||
USING: accessors arrays hashtables io kernel math math.functions
|
||||
namespaces make opengl sequences strings splitting ui.gadgets
|
||||
ui.gadgets.tracks ui.gadgets.packs fonts ui.render ui.text
|
||||
colors models ;
|
||||
IN: ui.gadgets.labels
|
||||
|
||||
! A label gadget draws a string.
|
||||
|
|
@ -35,7 +35,8 @@ M: label pref-dim*
|
|||
>label< text-dim ;
|
||||
|
||||
M: label baseline
|
||||
>label< line-metrics ascent>> ;
|
||||
>label< dup string? [ first ] unless
|
||||
line-metrics ascent>> ceiling ;
|
||||
|
||||
M: label draw-gadget*
|
||||
>label< origin get draw-text ;
|
||||
|
|
@ -64,12 +65,20 @@ M: array >label <label> ;
|
|||
M: object >label ;
|
||||
M: f >label drop <gadget> ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: label-on-left/right ( -- track )
|
||||
horizontal <track>
|
||||
+baseline+ >>align
|
||||
{ 5 5 } >>gap ; inline
|
||||
PRIVATE>
|
||||
|
||||
: label-on-left ( gadget label -- button )
|
||||
{ 1 0 } <track>
|
||||
label-on-left/right
|
||||
swap >label f track-add
|
||||
swap 1 track-add ;
|
||||
|
||||
: label-on-right ( label gadget -- button )
|
||||
{ 1 0 } <track>
|
||||
label-on-left/right
|
||||
swap f track-add
|
||||
swap >label 1 track-add ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: ui.gadgets help.markup help.syntax generic kernel
|
||||
classes.tuple quotations ;
|
||||
classes.tuple quotations ui.gadgets.packs.private ;
|
||||
IN: ui.gadgets.packs
|
||||
|
||||
ARTICLE: "ui-pack-layout" "Pack layouts"
|
||||
|
|
@ -38,7 +38,7 @@ HELP: pack-layout
|
|||
|
||||
HELP: <pack>
|
||||
{ $values { "orientation" "an orientation specifier" } { "pack" "a new " { $link pack } } }
|
||||
{ $description "Creates a new pack which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ;
|
||||
{ $description "Creates a new pack which lays out children with the given orientation, either " { $link horizontal } " or " { $link vertical } "." } ;
|
||||
|
||||
{ <pack> <pile> <shelf> } related-words
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
IN: ui.gadgets.packs.tests
|
||||
USING: ui.gadgets.packs ui.gadgets.labels ui.gadgets ui.render
|
||||
USING: ui.gadgets.packs ui.gadgets.packs.private
|
||||
ui.gadgets.labels ui.gadgets ui.render
|
||||
kernel namespaces tools.test math.parser sequences math.geometry.rect
|
||||
accessors ;
|
||||
|
||||
|
|
@ -16,6 +17,30 @@ accessors ;
|
|||
[ { { 10 30 } } ] [
|
||||
{ { 10 20 } }
|
||||
{ { 100 30 } }
|
||||
<gadget> { 0 1 } >>orientation
|
||||
<gadget> vertical >>orientation
|
||||
orient
|
||||
] unit-test
|
||||
|
||||
TUPLE: baseline-gadget < gadget baseline ;
|
||||
|
||||
M: baseline-gadget baseline baseline>> ;
|
||||
|
||||
: <baseline-gadget> ( baseline dim -- gadget )
|
||||
baseline-gadget new-gadget
|
||||
swap >>dim
|
||||
swap >>baseline ;
|
||||
|
||||
<shelf> +baseline+ >>align
|
||||
5 { 10 10 } <baseline-gadget> add-gadget
|
||||
10 { 10 10 } <baseline-gadget> add-gadget
|
||||
"g" set
|
||||
|
||||
[ ] [ "g" get prefer ] unit-test
|
||||
|
||||
[ { 20 15 } ] [ "g" get dim>> ] unit-test
|
||||
|
||||
[ V{ { 0 5 } { 10 0 } } ] [
|
||||
"g" get
|
||||
dup layout
|
||||
children>> [ loc>> ] map
|
||||
] unit-test
|
||||
|
|
@ -1,67 +1,95 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences ui.gadgets kernel math math.functions
|
||||
math.vectors math.order math.geometry.rect namespaces accessors
|
||||
fry ;
|
||||
fry combinators arrays ;
|
||||
IN: ui.gadgets.packs
|
||||
|
||||
SYMBOL: +baseline+
|
||||
|
||||
TUPLE: pack < gadget
|
||||
{ align initial: 0 } { fill initial: 0 } { gap initial: { 0 0 } } ;
|
||||
|
||||
: packed-dim-2 ( gadget sizes -- list )
|
||||
<PRIVATE
|
||||
|
||||
: (packed-dims) ( gadget sizes -- list )
|
||||
swap [ dim>> ] [ fill>> ] bi '[ _ over v- _ v*n v+ ] map ;
|
||||
|
||||
: orient ( seq1 seq2 gadget -- seq )
|
||||
orientation>> '[ _ set-axis ] 2map ;
|
||||
|
||||
: packed-dims ( gadget sizes -- seq )
|
||||
[ packed-dim-2 ] [ nip ] [ drop ] 2tri orient ;
|
||||
[ (packed-dims) ] [ nip ] [ drop ] 2tri orient ;
|
||||
|
||||
: gap-locs ( gap sizes -- seq )
|
||||
{ 0 0 } [ v+ over v+ ] accumulate 2nip ;
|
||||
: gap-locs ( sizes gap -- seq )
|
||||
[ { 0 0 } ] dip '[ v+ _ v+ ] accumulate nip ;
|
||||
|
||||
: aligned-locs ( gadget sizes -- seq )
|
||||
[ [ [ align>> ] [ dim>> ] bi ] dip v- n*v ] with map ;
|
||||
: numerically-aligned-locs ( sizes pack -- seq )
|
||||
[ align>> ] [ dim>> ] bi '[ [ _ _ ] dip v- n*v ] map ;
|
||||
|
||||
: packed-locs ( gadget sizes -- seq )
|
||||
[ aligned-locs ] [ [ gap>> ] dip gap-locs ] [ drop ] 2tri orient ;
|
||||
: baseline-aligned-locs ( pack -- seq )
|
||||
children>> [ baseline ] map [ supremum ] keep
|
||||
[ - 0 swap 2array ] with map ;
|
||||
|
||||
: aligned-locs ( sizes pack -- seq )
|
||||
dup align>> +baseline+ eq?
|
||||
[ nip baseline-aligned-locs ]
|
||||
[ numerically-aligned-locs ]
|
||||
if ;
|
||||
|
||||
: packed-locs ( sizes pack -- seq )
|
||||
[ aligned-locs ] [ gap>> gap-locs ] [ nip ] 2tri orient ;
|
||||
|
||||
: round-dims ( seq -- newseq )
|
||||
{ 0 0 } swap
|
||||
[ { 0 0 } ] dip
|
||||
[ swap v- dup [ ceiling >fixnum ] map [ swap v- ] keep ] map
|
||||
nip ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: pack-layout ( pack sizes -- )
|
||||
round-dims over children>>
|
||||
[ dupd packed-dims ] dip
|
||||
[ [ (>>dim) ] 2each ]
|
||||
[ [ packed-locs ] dip [ (>>loc) ] 2each ] 2bi ;
|
||||
[ round-dims packed-dims ] [ drop ] 2bi
|
||||
[ children>> [ (>>dim) ] 2each ]
|
||||
[ [ packed-locs ] [ children>> ] bi [ (>>loc) ] 2each ] 2bi ;
|
||||
|
||||
: <pack> ( orientation -- pack )
|
||||
pack new-gadget
|
||||
swap >>orientation ;
|
||||
|
||||
: <pile> ( -- pack ) { 0 1 } <pack> ;
|
||||
: <pile> ( -- pack ) vertical <pack> ;
|
||||
|
||||
: <filled-pile> ( -- pack ) <pile> 1 >>fill ;
|
||||
|
||||
: <shelf> ( -- pack ) { 1 0 } <pack> ;
|
||||
: <shelf> ( -- pack ) horizontal <pack> ;
|
||||
|
||||
: gap-dims ( sizes gadget -- seeq )
|
||||
[ [ dim-sum ] [ length 1 [-] ] bi ] [ gap>> ] bi* n*v v+ ;
|
||||
<PRIVATE
|
||||
|
||||
: gap-dims ( gadget sizes -- seeq )
|
||||
[ gap>> ] [ [ length 1 [-] ] [ dim-sum ] bi ] bi* [ v*n ] dip v+ ;
|
||||
|
||||
: pack-pref-dim ( gadget sizes -- dim )
|
||||
[ nip max-dim ]
|
||||
[ swap gap-dims ]
|
||||
[ drop orientation>> ]
|
||||
2tri set-axis ;
|
||||
[ nip max-dim ] [ gap-dims ] [ drop orientation>> ] 2tri set-axis ;
|
||||
|
||||
M: pack pref-dim*
|
||||
dup children>> pref-dims pack-pref-dim ;
|
||||
|
||||
: vertical-baseline ( pack -- y )
|
||||
children>> [ 0 ] [ first baseline ] if-empty ;
|
||||
|
||||
: horizontal-baseline ( pack -- y )
|
||||
children>> [ baseline ] map supremum ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: pack baseline
|
||||
dup orientation>> {
|
||||
{ vertical [ vertical-baseline ] }
|
||||
{ horizontal [ horizontal-baseline ] }
|
||||
} case ;
|
||||
|
||||
M: pack layout*
|
||||
dup children>> pref-dims pack-layout ;
|
||||
|
||||
M: pack children-on ( rect gadget -- seq )
|
||||
dup orientation>> swap children>>
|
||||
[ orientation>> ] [ children>> ] bi
|
||||
[ fast-children-on ] keep <slice> ;
|
||||
|
|
|
|||
|
|
@ -48,8 +48,8 @@ M: pane gadget-selection ( pane -- string/f )
|
|||
|
||||
: new-pane ( class -- pane )
|
||||
new-gadget
|
||||
{ 0 1 } >>orientation
|
||||
<shelf> >>prototype
|
||||
vertical >>orientation
|
||||
<shelf> +baseline+ >>align >>prototype
|
||||
<incremental> add-output
|
||||
dup prepare-line
|
||||
selection-color >>selection-color ;
|
||||
|
|
@ -231,7 +231,7 @@ MEMO: specified-font ( assoc -- font )
|
|||
page-color [ solid-interior ] apply-style ;
|
||||
|
||||
: apply-border-width-style ( style gadget -- style gadget )
|
||||
border-width [ <border> ] apply-style ;
|
||||
border-width [ dup 2array <border> ] apply-style ;
|
||||
|
||||
: style-pane ( style pane -- pane )
|
||||
apply-border-width-style
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ TUPLE: paragraph < gadget margin ;
|
|||
|
||||
: <paragraph> ( margin -- gadget )
|
||||
paragraph new-gadget
|
||||
{ 1 0 } >>orientation
|
||||
horizontal >>orientation
|
||||
swap >>margin ;
|
||||
|
||||
SYMBOL: x SYMBOL: max-x
|
||||
|
|
|
|||
|
|
@ -76,13 +76,14 @@ thumb H{
|
|||
: slide-by-page ( amount slider -- ) model>> move-by-page ;
|
||||
|
||||
: compute-direction ( elevator -- -1/1 )
|
||||
dup find-slider swap hand-click-rel
|
||||
over orientation>> v.
|
||||
over screen>slider
|
||||
swap slider-value - sgn ;
|
||||
[ hand-click-rel ] [ find-slider ] bi
|
||||
[ orientation>> v. ]
|
||||
[ screen>slider ]
|
||||
[ slider-value - sgn ]
|
||||
tri ;
|
||||
|
||||
: elevator-hold ( elevator -- )
|
||||
dup direction>> swap find-slider slide-by-page ;
|
||||
[ direction>> ] [ find-slider ] bi slide-by-page ;
|
||||
|
||||
: elevator-click ( elevator -- )
|
||||
dup compute-direction >>direction
|
||||
|
|
@ -102,7 +103,7 @@ elevator H{
|
|||
over orientation>> n*v swap thumb>> ;
|
||||
|
||||
: thumb-loc ( slider -- loc )
|
||||
dup slider-value swap slider>screen ;
|
||||
[ slider-value ] keep slider>screen ;
|
||||
|
||||
: layout-thumb-loc ( slider -- )
|
||||
dup thumb-loc (layout-thumb)
|
||||
|
|
@ -136,8 +137,8 @@ M: elevator layout*
|
|||
|
||||
: <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
|
||||
: <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ;
|
||||
: <up-button> ( -- button ) { 1 0 } arrow-up -1 <slide-button> ;
|
||||
: <down-button> ( -- button ) { 1 0 } arrow-down 1 <slide-button> ;
|
||||
: <up-button> ( -- button ) horizontal arrow-up -1 <slide-button> ;
|
||||
: <down-button> ( -- button ) horizontal arrow-down 1 <slide-button> ;
|
||||
|
||||
: <slider> ( range orientation -- slider )
|
||||
slider new-frame
|
||||
|
|
@ -146,15 +147,15 @@ M: elevator layout*
|
|||
32 >>line ;
|
||||
|
||||
: <x-slider> ( range -- slider )
|
||||
{ 1 0 } <slider>
|
||||
horizontal <slider>
|
||||
<left-button> @left grid-add
|
||||
{ 0 1 } elevator,
|
||||
vertical elevator,
|
||||
<right-button> @right grid-add ;
|
||||
|
||||
: <y-slider> ( range -- slider )
|
||||
{ 0 1 } <slider>
|
||||
vertical <slider>
|
||||
<up-button> @top grid-add
|
||||
{ 1 0 } elevator,
|
||||
horizontal elevator,
|
||||
<down-button> @bottom grid-add ;
|
||||
|
||||
M: slider pref-dim*
|
||||
|
|
|
|||
|
|
@ -65,7 +65,7 @@ TUPLE: slot-editor < track ref close-hook update-hook text ;
|
|||
} define-command
|
||||
|
||||
: <slot-editor> ( close-hook update-hook ref -- gadget )
|
||||
{ 0 1 } slot-editor new-track
|
||||
vertical slot-editor new-track
|
||||
swap >>ref
|
||||
swap >>update-hook
|
||||
swap >>close-hook
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: ui.gadgets.tabbed
|
|||
TUPLE: tabbed-gadget < track tabs book ;
|
||||
|
||||
: <tabbed-gadget> ( -- gadget )
|
||||
{ 0 1 } tabbed-gadget new-track
|
||||
vertical tabbed-gadget new-track
|
||||
0 <model> >>model
|
||||
<shelf> >>tabs
|
||||
dup tabs>> f track-add
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ HELP: track
|
|||
|
||||
HELP: <track>
|
||||
{ $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } }
|
||||
{ $description "Creates a new track which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ;
|
||||
{ $description "Creates a new track which lays out children along the given orientation, either " { $link horizontal } " or " { $link vertical } "." } ;
|
||||
|
||||
HELP: track-add
|
||||
{ $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } }
|
||||
|
|
|
|||
|
|
@ -3,27 +3,27 @@ USING: kernel ui.gadgets ui.gadgets.tracks tools.test
|
|||
IN: ui.gadgets.tracks.tests
|
||||
|
||||
[ { 100 100 } ] [
|
||||
{ 0 1 } <track>
|
||||
vertical <track>
|
||||
<gadget> { 100 100 } >>dim 1 track-add
|
||||
pref-dim
|
||||
] unit-test
|
||||
|
||||
[ { 100 110 } ] [
|
||||
{ 0 1 } <track>
|
||||
vertical <track>
|
||||
<gadget> { 10 10 } >>dim f track-add
|
||||
<gadget> { 100 100 } >>dim 1 track-add
|
||||
pref-dim
|
||||
] unit-test
|
||||
|
||||
[ { 10 10 } ] [
|
||||
{ 0 1 } <track>
|
||||
vertical <track>
|
||||
<gadget> { 10 10 } >>dim 1 track-add
|
||||
<gadget> { 10 10 } >>dim 0 track-add
|
||||
pref-dim
|
||||
] unit-test
|
||||
|
||||
[ { 10 30 } ] [
|
||||
{ 0 1 } <track>
|
||||
vertical <track>
|
||||
<gadget> { 10 10 } >>dim f track-add
|
||||
<gadget> { 10 10 } >>dim f track-add
|
||||
<gadget> { 10 10 } >>dim f track-add
|
||||
|
|
@ -31,7 +31,7 @@ IN: ui.gadgets.tracks.tests
|
|||
] unit-test
|
||||
|
||||
[ { 10 40 } ] [
|
||||
{ 0 1 } <track>
|
||||
vertical <track>
|
||||
{ 5 5 } >>gap
|
||||
<gadget> { 10 10 } >>dim f track-add
|
||||
<gadget> { 10 10 } >>dim f track-add
|
||||
|
|
|
|||
|
|
@ -39,7 +39,7 @@ M: world request-focus-on ( child gadget -- )
|
|||
[ 2drop ] [ dup focused?>> (request-focus) ] if ;
|
||||
|
||||
: new-world ( gadget title status class -- world )
|
||||
{ 0 1 } swap new-track
|
||||
vertical swap new-track
|
||||
t >>root?
|
||||
t >>active?
|
||||
H{ } clone >>fonts
|
||||
|
|
|
|||
|
|
@ -10,8 +10,10 @@ TUPLE: wrapper < gadget ;
|
|||
|
||||
: <wrapper> ( child -- wrapper ) wrapper new-wrapper ;
|
||||
|
||||
M: wrapper pref-dim* ( wrapper -- dim ) gadget-child pref-dim ;
|
||||
M: wrapper pref-dim* gadget-child pref-dim ;
|
||||
|
||||
M: wrapper layout* ( wrapper -- ) [ dim>> ] [ gadget-child ] bi (>>dim) ;
|
||||
M: wrapper baseline gadget-child baseline ;
|
||||
|
||||
M: wrapper focusable-child* ( wrapper -- child/t ) gadget-child ;
|
||||
M: wrapper layout* [ gadget-child ] [ dim>> ] bi >>dim drop ;
|
||||
|
||||
M: wrapper focusable-child* gadget-child ;
|
||||
|
|
|
|||
|
|
@ -30,13 +30,13 @@ TUPLE: browser-gadget < tool pane scroller search-field ;
|
|||
|
||||
: <browser-toolbar> ( browser -- toolbar )
|
||||
<shelf>
|
||||
+baseline+ >>align
|
||||
{ 5 5 } >>gap
|
||||
over <toolbar> add-gadget
|
||||
"Search:" <label> add-gadget
|
||||
swap search-field>> add-gadget ;
|
||||
swap search-field>> "Search:" label-on-left add-gadget ;
|
||||
|
||||
: <browser-gadget> ( link -- gadget )
|
||||
{ 0 1 } browser-gadget new-track
|
||||
vertical browser-gadget new-track
|
||||
swap >link <history> >>model
|
||||
dup <search-field> >>search-field
|
||||
dup <browser-toolbar> f track-add
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ TUPLE: debugger < track error restarts restart-hook restart-list continuation ;
|
|||
PRIVATE>
|
||||
|
||||
: <debugger> ( error restarts restart-hook -- gadget )
|
||||
{ 0 1 } debugger new-track
|
||||
vertical debugger new-track
|
||||
add-toolbar
|
||||
swap >>restart-hook
|
||||
swap >>restarts
|
||||
|
|
|
|||
|
|
@ -66,7 +66,7 @@ M: hashtable make-slot-descriptions
|
|||
monospace-font >>font ;
|
||||
|
||||
: <inspector-gadget> ( obj -- gadget )
|
||||
{ 0 1 } inspector-gadget new-track
|
||||
vertical inspector-gadget new-track
|
||||
add-toolbar
|
||||
swap <model> >>model
|
||||
dup model>> <inspector-table> >>table
|
||||
|
|
|
|||
|
|
@ -176,7 +176,7 @@ TUPLE: listener-gadget < tool input output scroller popup ;
|
|||
<scroller> ;
|
||||
|
||||
: <listener-gadget> ( -- gadget )
|
||||
{ 0 1 } listener-gadget new-track
|
||||
vertical listener-gadget new-track
|
||||
add-toolbar
|
||||
init-listener
|
||||
dup <listener-scroller> >>scroller
|
||||
|
|
|
|||
|
|
@ -98,7 +98,7 @@ M: method-renderer row-value drop first ;
|
|||
} ;
|
||||
|
||||
: <sort-options> ( model -- gadget )
|
||||
sort-options <radio-buttons> { 1 0 } >>orientation ;
|
||||
sort-options <radio-buttons> horizontal >>orientation ;
|
||||
|
||||
: <profiler-tool-bar> ( profiler -- gadget )
|
||||
<shelf>
|
||||
|
|
@ -108,7 +108,7 @@ M: method-renderer row-value drop first ;
|
|||
swap sort>> <sort-options> add-gadget ;
|
||||
|
||||
:: <words-tab> ( profiler -- gadget )
|
||||
{ 1 0 } <track>
|
||||
horizontal <track>
|
||||
profiler vocabs>> <profiler-table>
|
||||
profiler vocab>> >>selected-value
|
||||
vocab-renderer >>renderer
|
||||
|
|
@ -120,8 +120,8 @@ M: method-renderer row-value drop first ;
|
|||
1/2 track-add ;
|
||||
|
||||
:: <methods-tab> ( profiler -- gadget )
|
||||
{ 0 1 } <track>
|
||||
{ 1 0 } <track>
|
||||
vertical <track>
|
||||
horizontal <track>
|
||||
profiler <generic-model> <profiler-table>
|
||||
profiler generic>> >>selected-value
|
||||
word-renderer >>renderer
|
||||
|
|
@ -141,7 +141,7 @@ M: method-renderer row-value drop first ;
|
|||
: <selection-model> ( -- model ) { f 0 } <model> ;
|
||||
|
||||
: <profiler-gadget> ( -- profiler )
|
||||
{ 0 1 } profiler-gadget new-track
|
||||
vertical profiler-gadget new-track
|
||||
[ [ first ] compare ] <model> >>sort
|
||||
all-words counters <model> >>words
|
||||
<selection-model> >>vocab
|
||||
|
|
|
|||
|
|
@ -24,11 +24,11 @@ TUPLE: traceback-gadget < track ;
|
|||
M: traceback-gadget pref-dim* drop { 550 600 } ;
|
||||
|
||||
: <traceback-gadget> ( model -- gadget )
|
||||
{ 0 1 } traceback-gadget new-track
|
||||
vertical traceback-gadget new-track
|
||||
swap >>model
|
||||
|
||||
dup model>>
|
||||
{ 1 0 } <track>
|
||||
horizontal <track>
|
||||
over <datastack-display> 1/2 track-add
|
||||
swap <retainstack-display> 1/2 track-add
|
||||
1/3 track-add
|
||||
|
|
|
|||
|
|
@ -58,7 +58,7 @@ M: walker-gadget focusable-child*
|
|||
'[ _ walker-state-string ] <filter> <label-control> ;
|
||||
|
||||
: <walker-gadget> ( status continuation thread -- gadget )
|
||||
{ 0 1 } walker-gadget new-track
|
||||
vertical walker-gadget new-track
|
||||
swap >>thread
|
||||
swap >>continuation
|
||||
swap >>status
|
||||
|
|
|
|||
|
|
@ -78,7 +78,7 @@ DEFER: (gadget-subtree)
|
|||
[ (gadget-subtree) ] { } make ;
|
||||
|
||||
M: node gadget-text*
|
||||
dup children>> swap value>> gadget-seq-text ;
|
||||
[ children>> ] [ value>> ] bi gadget-seq-text ;
|
||||
|
||||
: gadget-text-range ( frompath topath gadget -- str )
|
||||
gadget-subtree gadget-text ;
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@ ARTICLE: "ui-glossary" "UI glossary"
|
|||
{ "font" { "an instance of " { $link font } } }
|
||||
{ "gadget" { "a graphical element which responds to user input. Gadgets are tuples which (directly or indirectly) inherit from " { $link gadget } "." } }
|
||||
{ "label specifier" { "a string, " { $link f } " or a gadget. See " { $link "ui.gadgets.buttons" } } }
|
||||
{ "orientation specifier" { "one of " { $snippet "{ 0 1 }" } " or " { $snippet "{ 1 0 }" } ", with the former denoting vertical orientation and the latter denoting horizontal. Using a vector instead of symbolic constants allows these values to be directly useful in co-ordinate calculations" } }
|
||||
{ "orientation specifier" { "one of " { $link horizontal } " or " { $link vertical } } }
|
||||
{ "point" "a pair of integers denoting a pixel location on screen" }
|
||||
} ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue