steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Add horizontal and vertical orientation constants, working on baseline alignment

db4
Slava Pestov 2009-02-02 00:02:55 -06:00
parent 7b2a705352
commit d31b902f96
29 changed files with 167 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
basis/ui/gadgets/buttons/buttons.factor
View File

@ -150,15 +150,10 @@ M: checkmark-paint draw-interior
: toggle-model ( model -- ) : toggle-model ( model -- )
[ not ] change-model ; [ not ] change-model ;
: checkbox-theme ( gadget -- gadget )
f >>interior
{ 5 5 } >>gap
1/2 >>align ; inline
TUPLE: checkbox < button ; TUPLE: checkbox < button ;
: <checkbox> ( model label -- checkbox ) : <checkbox> ( model label -- checkbox )
<checkmark> label-on-right checkbox-theme <checkmark> label-on-right
[ model>> toggle-model ] [ model>> toggle-model ]
checkbox new-button checkbox new-button
swap >>model swap >>model
@ -173,7 +168,7 @@ TUPLE: radio-paint < caching-pen color interior-vertices boundary-vertices ;
<PRIVATE <PRIVATE
: circle-steps 8 ; CONSTANT: circle-steps 8
PRIVATE> PRIVATE>
@ -223,12 +218,8 @@ M: radio-control model-changed
:: <radio-controls> ( parent model assoc quot: ( value model label -- gadget ) -- parent ) :: <radio-controls> ( parent model assoc quot: ( value model label -- gadget ) -- parent )
assoc model [ parent swap quot call add-gadget ] assoc-each ; inline 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-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 ) : <radio-buttons> ( model assoc -- gadget )
<filled-pile> <filled-pile>

5
basis/ui/gadgets/editors/editors.factor
View File

@ -242,6 +242,9 @@ M: editor draw-gadget*
M: editor pref-dim* M: editor pref-dim*
[ font>> ] [ control-value ] bi text-dim ; [ font>> ] [ control-value ] bi text-dim ;
M: editor baseline
font>> "" line-metrics ascent>> ;
: contents-changed ( model editor -- ) : contents-changed ( model editor -- )
swap swap
over caret>> [ over validate-loc ] (change-model) over caret>> [ over validate-loc ] (change-model)
@ -585,7 +588,7 @@ TUPLE: field < wrapper editor min-width max-width ;
gray <solid> >>boundary ; inline gray <solid> >>boundary ; inline
: <field-border> ( gadget -- border ) : <field-border> ( gadget -- border )
2 <border> { 2 2 } <border>
{ 1 0 } >>fill { 1 0 } >>fill
field-theme ; field-theme ;

8
basis/ui/gadgets/gadgets.factor
View File

@ -6,6 +6,10 @@ binary-search vectors dlists deques models threads
concurrency.flags math.order math.geometry.rect fry ; concurrency.flags math.order math.geometry.rect fry ;
IN: ui.gadgets IN: ui.gadgets
! Values for orientation slot
CONSTANT: horizontal { 1 0 }
CONSTANT: vertical { 0 1 }
TUPLE: gadget < rect pref-dim parent children orientation focus TUPLE: gadget < rect pref-dim parent children orientation focus
visible? root? clipped? layout-state graft-state graft-node visible? root? clipped? layout-state graft-state graft-node
interior boundary model ; interior boundary model ;
@ -103,14 +107,14 @@ GENERIC: gadget-text* ( gadget -- )
GENERIC: gadget-text-separator ( gadget -- str ) GENERIC: gadget-text-separator ( gadget -- str )
M: gadget gadget-text-separator M: gadget gadget-text-separator
orientation>> { 0 1 } = "\n" "" ? ; orientation>> vertical = "\n" "" ? ;
: gadget-seq-text ( seq gadget -- ) : gadget-seq-text ( seq gadget -- )
gadget-text-separator swap gadget-text-separator swap
[ dup % ] [ gadget-text* ] interleave drop ; [ dup % ] [ gadget-text* ] interleave drop ;
M: gadget gadget-text* M: gadget gadget-text*
dup children>> swap gadget-seq-text ; [ children>> ] keep gadget-seq-text ;
M: array gadget-text* M: array gadget-text*
[ gadget-text* ] each ; [ gadget-text* ] each ;

4
basis/ui/gadgets/grid-lines/grid-lines.factor
View File

@ -28,7 +28,7 @@ M: grid-lines draw-boundary
[ grid set ] [ grid set ]
[ dim>> half-gap v- grid-dim set ] [ dim>> half-gap v- grid-dim set ]
[ compute-grid ] tri [ compute-grid ] tri
[ { 1 0 } draw-grid-lines ] [ horizontal draw-grid-lines ]
[ { 0 1 } draw-grid-lines ] [ vertical draw-grid-lines ]
bi* bi*
] with-scope ; ] with-scope ;

4
basis/ui/gadgets/grids/grids.factor
View File

@ -48,8 +48,8 @@ grid
dupd add-gaps dim-sum v+ ; dupd add-gaps dim-sum v+ ;
M: grid pref-dim* M: grid pref-dim*
dup gap>> swap compute-grid [ over ] dip [ gap>> ] [ compute-grid ] bi
[ gap-sum ] 2bi@ (pair-up) ; [ over ] dip [ gap-sum ] 2bi@ (pair-up) ;
: do-grid ( dims grid quot -- ) : do-grid ( dims grid quot -- )
[ grid>> ] dip '[ _ 2each ] 2each ; inline [ grid>> ] dip '[ _ 2each ] 2each ; inline

2
basis/ui/gadgets/incremental/incremental.factor
View File

@ -9,7 +9,7 @@ TUPLE: incremental < pack cursor ;
: <incremental> ( -- incremental ) : <incremental> ( -- incremental )
incremental new-gadget incremental new-gadget
{ 0 1 } >>orientation vertical >>orientation
{ 0 0 } >>cursor ; { 0 0 } >>cursor ;
M: incremental pref-dim* M: incremental pref-dim*

2
basis/ui/gadgets/labelled/labelled.factor
View File

@ -11,7 +11,7 @@ IN: ui.gadgets.labelled
TUPLE: labelled-gadget < track content ; TUPLE: labelled-gadget < track content ;
: <labelled-gadget> ( gadget title -- newgadget ) : <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 <label> reverse-video-theme f track-add
swap >>content swap >>content
dup content>> 1 track-add ; dup content>> 1 track-add ;

23
basis/ui/gadgets/labels/labels.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2005, 2009 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hashtables io kernel math namespaces USING: accessors arrays hashtables io kernel math math.functions
make opengl sequences strings splitting ui.gadgets namespaces make opengl sequences strings splitting ui.gadgets
ui.gadgets.tracks fonts ui.render ui.gadgets.tracks ui.gadgets.packs fonts ui.render ui.text
ui.text colors models ; colors models ;
IN: ui.gadgets.labels IN: ui.gadgets.labels
! A label gadget draws a string. ! A label gadget draws a string.
@ -35,7 +35,8 @@ M: label pref-dim*
>label< text-dim ; >label< text-dim ;
M: label baseline M: label baseline
>label< line-metrics ascent>> ; >label< dup string? [ first ] unless
line-metrics ascent>> ceiling ;
M: label draw-gadget* M: label draw-gadget*
>label< origin get draw-text ; >label< origin get draw-text ;
@ -64,12 +65,20 @@ M: array >label <label> ;
M: object >label ; M: object >label ;
M: f >label drop <gadget> ; 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 ) : label-on-left ( gadget label -- button )
{ 1 0 } <track> label-on-left/right
swap >label f track-add swap >label f track-add
swap 1 track-add ; swap 1 track-add ;
: label-on-right ( label gadget -- button ) : label-on-right ( label gadget -- button )
{ 1 0 } <track> label-on-left/right
swap f track-add swap f track-add
swap >label 1 track-add ; swap >label 1 track-add ;

4
basis/ui/gadgets/packs/packs-docs.factor
View File

@ -1,5 +1,5 @@
USING: ui.gadgets help.markup help.syntax generic kernel USING: ui.gadgets help.markup help.syntax generic kernel
classes.tuple quotations ; classes.tuple quotations ui.gadgets.packs.private ;
IN: ui.gadgets.packs IN: ui.gadgets.packs
ARTICLE: "ui-pack-layout" "Pack layouts" ARTICLE: "ui-pack-layout" "Pack layouts"
@ -38,7 +38,7 @@ HELP: pack-layout
HELP: <pack> HELP: <pack>
{ $values { "orientation" "an orientation specifier" } { "pack" "a new " { $link 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 { <pack> <pile> <shelf> } related-words

31
basis/ui/gadgets/packs/packs-tests.factor
View File

@ -1,5 +1,6 @@
IN: ui.gadgets.packs.tests 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 kernel namespaces tools.test math.parser sequences math.geometry.rect
accessors ; accessors ;
@ -7,7 +8,7 @@ accessors ;
{ 0 0 } { 100 100 } <rect> clip set { 0 0 } { 100 100 } <rect> clip set
<pile> <pile>
100 [ number>string <label> add-gadget ] each 100 [ number>string <label> add-gadget ] each
dup layout dup layout
visible-children [ label? ] all? visible-children [ label? ] all?
@ -16,6 +17,30 @@ accessors ;
[ { { 10 30 } } ] [ [ { { 10 30 } } ] [
{ { 10 20 } } { { 10 20 } }
{ { 100 30 } } { { 100 30 } }
<gadget> { 0 1 } >>orientation <gadget> vertical >>orientation
orient orient
] unit-test ] 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

76
basis/ui/gadgets/packs/packs.factor
View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
USING: sequences ui.gadgets kernel math math.functions USING: sequences ui.gadgets kernel math math.functions
math.vectors math.order math.geometry.rect namespaces accessors math.vectors math.order math.geometry.rect namespaces accessors
fry ; fry combinators arrays ;
IN: ui.gadgets.packs IN: ui.gadgets.packs
SYMBOL: +baseline+
TUPLE: pack < gadget TUPLE: pack < gadget
{ align initial: 0 } { fill initial: 0 } { gap initial: { 0 0 } } ; { 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 ; swap [ dim>> ] [ fill>> ] bi '[ _ over v- _ v*n v+ ] map ;
: orient ( seq1 seq2 gadget -- seq ) : orient ( seq1 seq2 gadget -- seq )
orientation>> '[ _ set-axis ] 2map ; orientation>> '[ _ set-axis ] 2map ;
: packed-dims ( gadget sizes -- seq ) : packed-dims ( gadget sizes -- seq )
[ packed-dim-2 ] [ nip ] [ drop ] 2tri orient ; [ (packed-dims) ] [ nip ] [ drop ] 2tri orient ;
: gap-locs ( gap sizes -- seq ) : gap-locs ( sizes gap -- seq )
{ 0 0 } [ v+ over v+ ] accumulate 2nip ; [ { 0 0 } ] dip '[ v+ _ v+ ] accumulate nip ;
: aligned-locs ( gadget sizes -- seq ) : numerically-aligned-locs ( sizes pack -- seq )
[ [ [ align>> ] [ dim>> ] bi ] dip v- n*v ] with map ; [ align>> ] [ dim>> ] bi '[ [ _ _ ] dip v- n*v ] map ;
: packed-locs ( gadget sizes -- seq ) : baseline-aligned-locs ( pack -- seq )
[ aligned-locs ] [ [ gap>> ] dip gap-locs ] [ drop ] 2tri orient ; 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 ) : round-dims ( seq -- newseq )
{ 0 0 } swap [ { 0 0 } ] dip
[ swap v- dup [ ceiling >fixnum ] map [ swap v- ] keep ] map [ swap v- dup [ ceiling >fixnum ] map [ swap v- ] keep ] map
nip ; nip ;
PRIVATE>
: pack-layout ( pack sizes -- ) : pack-layout ( pack sizes -- )
round-dims over children>> [ round-dims packed-dims ] [ drop ] 2bi
[ dupd packed-dims ] dip [ children>> [ (>>dim) ] 2each ]
[ [ (>>dim) ] 2each ] [ [ packed-locs ] [ children>> ] bi [ (>>loc) ] 2each ] 2bi ;
[ [ packed-locs ] dip [ (>>loc) ] 2each ] 2bi ;
: <pack> ( orientation -- pack ) : <pack> ( orientation -- pack )
pack new-gadget pack new-gadget
swap >>orientation ; swap >>orientation ;
: <pile> ( -- pack ) { 0 1 } <pack> ; : <pile> ( -- pack ) vertical <pack> ;
: <filled-pile> ( -- pack ) <pile> 1 >>fill ; : <filled-pile> ( -- pack ) <pile> 1 >>fill ;
: <shelf> ( -- pack ) { 1 0 } <pack> ; : <shelf> ( -- pack ) horizontal <pack> ;
: gap-dims ( sizes gadget -- seeq ) <PRIVATE
[ [ dim-sum ] [ length 1 [-] ] bi ] [ gap>> ] bi* n*v v+ ;
: gap-dims ( gadget sizes -- seeq )
[ gap>> ] [ [ length 1 [-] ] [ dim-sum ] bi ] bi* [ v*n ] dip v+ ;
: pack-pref-dim ( gadget sizes -- dim ) : pack-pref-dim ( gadget sizes -- dim )
[ nip max-dim ] [ nip max-dim ] [ gap-dims ] [ drop orientation>> ] 2tri set-axis ;
[ swap gap-dims ]
[ drop orientation>> ]
2tri set-axis ;
M: pack pref-dim* M: pack pref-dim*
dup children>> pref-dims 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* M: pack layout*
dup children>> pref-dims pack-layout ; dup children>> pref-dims pack-layout ;
M: pack children-on ( rect gadget -- seq ) M: pack children-on ( rect gadget -- seq )
dup orientation>> swap children>> [ orientation>> ] [ children>> ] bi
[ fast-children-on ] keep <slice> ; [ fast-children-on ] keep <slice> ;

6
basis/ui/gadgets/panes/panes.factor
View File

@ -48,8 +48,8 @@ M: pane gadget-selection ( pane -- string/f )
: new-pane ( class -- pane ) : new-pane ( class -- pane )
new-gadget new-gadget
{ 0 1 } >>orientation vertical >>orientation
<shelf> >>prototype <shelf> +baseline+ >>align >>prototype
<incremental> add-output <incremental> add-output
dup prepare-line dup prepare-line
selection-color >>selection-color ; selection-color >>selection-color ;
@ -231,7 +231,7 @@ MEMO: specified-font ( assoc -- font )
page-color [ solid-interior ] apply-style ; page-color [ solid-interior ] apply-style ;
: apply-border-width-style ( style gadget -- style gadget ) : 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 ) : style-pane ( style pane -- pane )
apply-border-width-style apply-border-width-style

2
basis/ui/gadgets/paragraphs/paragraphs.factor
View File

@ -18,7 +18,7 @@ TUPLE: paragraph < gadget margin ;
: <paragraph> ( margin -- gadget ) : <paragraph> ( margin -- gadget )
paragraph new-gadget paragraph new-gadget
{ 1 0 } >>orientation horizontal >>orientation
swap >>margin ; swap >>margin ;
SYMBOL: x SYMBOL: max-x SYMBOL: x SYMBOL: max-x

31
basis/ui/gadgets/sliders/sliders.factor
View File

@ -76,13 +76,14 @@ thumb H{
: slide-by-page ( amount slider -- ) model>> move-by-page ; : slide-by-page ( amount slider -- ) model>> move-by-page ;
: compute-direction ( elevator -- -1/1 ) : compute-direction ( elevator -- -1/1 )
dup find-slider swap hand-click-rel [ hand-click-rel ] [ find-slider ] bi
over orientation>> v. [ orientation>> v. ]
over screen>slider [ screen>slider ]
swap slider-value - sgn ; [ slider-value - sgn ]
tri ;
: elevator-hold ( elevator -- ) : elevator-hold ( elevator -- )
dup direction>> swap find-slider slide-by-page ; [ direction>> ] [ find-slider ] bi slide-by-page ;
: elevator-click ( elevator -- ) : elevator-click ( elevator -- )
dup compute-direction >>direction dup compute-direction >>direction
@ -94,15 +95,15 @@ elevator H{
} set-gestures } set-gestures
: <elevator> ( vector -- elevator ) : <elevator> ( vector -- elevator )
elevator new-gadget elevator new-gadget
swap >>orientation swap >>orientation
lowered-gradient >>interior ; lowered-gradient >>interior ;
: (layout-thumb) ( slider n -- n thumb ) : (layout-thumb) ( slider n -- n thumb )
over orientation>> n*v swap thumb>> ; over orientation>> n*v swap thumb>> ;
: thumb-loc ( slider -- loc ) : thumb-loc ( slider -- loc )
dup slider-value swap slider>screen ; [ slider-value ] keep slider>screen ;
: layout-thumb-loc ( slider -- ) : layout-thumb-loc ( slider -- )
dup thumb-loc (layout-thumb) dup thumb-loc (layout-thumb)
@ -136,8 +137,8 @@ M: elevator layout*
: <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ; : <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
: <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ; : <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ;
: <up-button> ( -- button ) { 1 0 } arrow-up -1 <slide-button> ; : <up-button> ( -- button ) horizontal arrow-up -1 <slide-button> ;
: <down-button> ( -- button ) { 1 0 } arrow-down 1 <slide-button> ; : <down-button> ( -- button ) horizontal arrow-down 1 <slide-button> ;
: <slider> ( range orientation -- slider ) : <slider> ( range orientation -- slider )
slider new-frame slider new-frame
@ -146,15 +147,15 @@ M: elevator layout*
32 >>line ; 32 >>line ;
: <x-slider> ( range -- slider ) : <x-slider> ( range -- slider )
{ 1 0 } <slider> horizontal <slider>
<left-button> @left grid-add <left-button> @left grid-add
{ 0 1 } elevator, vertical elevator,
<right-button> @right grid-add ; <right-button> @right grid-add ;
: <y-slider> ( range -- slider ) : <y-slider> ( range -- slider )
{ 0 1 } <slider> vertical <slider>
<up-button> @top grid-add <up-button> @top grid-add
{ 1 0 } elevator, horizontal elevator,
<down-button> @bottom grid-add ; <down-button> @bottom grid-add ;
M: slider pref-dim* M: slider pref-dim*

2
basis/ui/gadgets/slots/slots.factor
View File

@ -65,7 +65,7 @@ TUPLE: slot-editor < track ref close-hook update-hook text ;
} define-command } define-command
: <slot-editor> ( close-hook update-hook ref -- gadget ) : <slot-editor> ( close-hook update-hook ref -- gadget )
{ 0 1 } slot-editor new-track vertical slot-editor new-track
swap >>ref swap >>ref
swap >>update-hook swap >>update-hook
swap >>close-hook swap >>close-hook

2
basis/ui/gadgets/tabbed/tabbed.factor
View File

@ -7,7 +7,7 @@ IN: ui.gadgets.tabbed
TUPLE: tabbed-gadget < track tabs book ; TUPLE: tabbed-gadget < track tabs book ;
: <tabbed-gadget> ( -- gadget ) : <tabbed-gadget> ( -- gadget )
{ 0 1 } tabbed-gadget new-track vertical tabbed-gadget new-track
0 <model> >>model 0 <model> >>model
<shelf> >>tabs <shelf> >>tabs
dup tabs>> f track-add dup tabs>> f track-add

2
basis/ui/gadgets/tracks/tracks-docs.factor
View File

@ -15,7 +15,7 @@ HELP: track
HELP: <track> HELP: <track>
{ $values { "orientation" "an orientation specifier" } { "track" "a new " { $link 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 HELP: track-add
{ $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } } { $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } }

10
basis/ui/gadgets/tracks/tracks-tests.factor
View File

@ -3,27 +3,27 @@ USING: kernel ui.gadgets ui.gadgets.tracks tools.test
IN: ui.gadgets.tracks.tests IN: ui.gadgets.tracks.tests
[ { 100 100 } ] [ [ { 100 100 } ] [
{ 0 1 } <track> vertical <track>
<gadget> { 100 100 } >>dim 1 track-add <gadget> { 100 100 } >>dim 1 track-add
pref-dim pref-dim
] unit-test ] unit-test
[ { 100 110 } ] [ [ { 100 110 } ] [
{ 0 1 } <track> vertical <track>
<gadget> { 10 10 } >>dim f track-add <gadget> { 10 10 } >>dim f track-add
<gadget> { 100 100 } >>dim 1 track-add <gadget> { 100 100 } >>dim 1 track-add
pref-dim pref-dim
] unit-test ] unit-test
[ { 10 10 } ] [ [ { 10 10 } ] [
{ 0 1 } <track> vertical <track>
<gadget> { 10 10 } >>dim 1 track-add <gadget> { 10 10 } >>dim 1 track-add
<gadget> { 10 10 } >>dim 0 track-add <gadget> { 10 10 } >>dim 0 track-add
pref-dim pref-dim
] unit-test ] unit-test
[ { 10 30 } ] [ [ { 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 <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 ] unit-test
[ { 10 40 } ] [ [ { 10 40 } ] [
{ 0 1 } <track> vertical <track>
{ 5 5 } >>gap { 5 5 } >>gap
<gadget> { 10 10 } >>dim f track-add <gadget> { 10 10 } >>dim f track-add
<gadget> { 10 10 } >>dim f track-add <gadget> { 10 10 } >>dim f track-add

2
basis/ui/gadgets/worlds/worlds.factor
View File

@ -39,7 +39,7 @@ M: world request-focus-on ( child gadget -- )
[ 2drop ] [ dup focused?>> (request-focus) ] if ; [ 2drop ] [ dup focused?>> (request-focus) ] if ;
: new-world ( gadget title status class -- world ) : new-world ( gadget title status class -- world )
{ 0 1 } swap new-track vertical swap new-track
t >>root? t >>root?
t >>active? t >>active?
H{ } clone >>fonts H{ } clone >>fonts

8
basis/ui/gadgets/wrappers/wrappers.factor
View File

@ -10,8 +10,10 @@ TUPLE: wrapper < gadget ;
: <wrapper> ( child -- wrapper ) wrapper new-wrapper ; : <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 ;

6
basis/ui/tools/browser/browser.factor
View File

@ -30,13 +30,13 @@ TUPLE: browser-gadget < tool pane scroller search-field ;
: <browser-toolbar> ( browser -- toolbar ) : <browser-toolbar> ( browser -- toolbar )
<shelf> <shelf>
+baseline+ >>align
{ 5 5 } >>gap { 5 5 } >>gap
over <toolbar> add-gadget over <toolbar> add-gadget
"Search:" <label> add-gadget swap search-field>> "Search:" label-on-left add-gadget ;
swap search-field>> add-gadget ;
: <browser-gadget> ( link -- gadget ) : <browser-gadget> ( link -- gadget )
{ 0 1 } browser-gadget new-track vertical browser-gadget new-track
swap >link <history> >>model swap >link <history> >>model
dup <search-field> >>search-field dup <search-field> >>search-field
dup <browser-toolbar> f track-add dup <browser-toolbar> f track-add

2
basis/ui/tools/debugger/debugger.factor
View File

@ -28,7 +28,7 @@ TUPLE: debugger < track error restarts restart-hook restart-list continuation ;
PRIVATE> PRIVATE>
: <debugger> ( error restarts restart-hook -- gadget ) : <debugger> ( error restarts restart-hook -- gadget )
{ 0 1 } debugger new-track vertical debugger new-track
add-toolbar add-toolbar
swap >>restart-hook swap >>restart-hook
swap >>restarts swap >>restarts

2
basis/ui/tools/inspector/inspector.factor
View File

@ -66,7 +66,7 @@ M: hashtable make-slot-descriptions
monospace-font >>font ; monospace-font >>font ;
: <inspector-gadget> ( obj -- gadget ) : <inspector-gadget> ( obj -- gadget )
{ 0 1 } inspector-gadget new-track vertical inspector-gadget new-track
add-toolbar add-toolbar
swap <model> >>model swap <model> >>model
dup model>> <inspector-table> >>table dup model>> <inspector-table> >>table

2
basis/ui/tools/listener/listener.factor
View File

@ -176,7 +176,7 @@ TUPLE: listener-gadget < tool input output scroller popup ;
<scroller> ; <scroller> ;
: <listener-gadget> ( -- gadget ) : <listener-gadget> ( -- gadget )
{ 0 1 } listener-gadget new-track vertical listener-gadget new-track
add-toolbar add-toolbar
init-listener init-listener
dup <listener-scroller> >>scroller dup <listener-scroller> >>scroller

10
basis/ui/tools/profiler/profiler.factor
View File

@ -98,7 +98,7 @@ M: method-renderer row-value drop first ;
} ; } ;
: <sort-options> ( model -- gadget ) : <sort-options> ( model -- gadget )
sort-options <radio-buttons> { 1 0 } >>orientation ; sort-options <radio-buttons> horizontal >>orientation ;
: <profiler-tool-bar> ( profiler -- gadget ) : <profiler-tool-bar> ( profiler -- gadget )
<shelf> <shelf>
@ -108,7 +108,7 @@ M: method-renderer row-value drop first ;
swap sort>> <sort-options> add-gadget ; swap sort>> <sort-options> add-gadget ;
:: <words-tab> ( profiler -- gadget ) :: <words-tab> ( profiler -- gadget )
{ 1 0 } <track> horizontal <track>
profiler vocabs>> <profiler-table> profiler vocabs>> <profiler-table>
profiler vocab>> >>selected-value profiler vocab>> >>selected-value
vocab-renderer >>renderer vocab-renderer >>renderer
@ -120,8 +120,8 @@ M: method-renderer row-value drop first ;
1/2 track-add ; 1/2 track-add ;
:: <methods-tab> ( profiler -- gadget ) :: <methods-tab> ( profiler -- gadget )
{ 0 1 } <track> vertical <track>
{ 1 0 } <track> horizontal <track>
profiler <generic-model> <profiler-table> profiler <generic-model> <profiler-table>
profiler generic>> >>selected-value profiler generic>> >>selected-value
word-renderer >>renderer word-renderer >>renderer
@ -141,7 +141,7 @@ M: method-renderer row-value drop first ;
: <selection-model> ( -- model ) { f 0 } <model> ; : <selection-model> ( -- model ) { f 0 } <model> ;
: <profiler-gadget> ( -- profiler ) : <profiler-gadget> ( -- profiler )
{ 0 1 } profiler-gadget new-track vertical profiler-gadget new-track
[ [ first ] compare ] <model> >>sort [ [ first ] compare ] <model> >>sort
all-words counters <model> >>words all-words counters <model> >>words
<selection-model> >>vocab <selection-model> >>vocab

4
basis/ui/tools/traceback/traceback.factor
View File

@ -24,11 +24,11 @@ TUPLE: traceback-gadget < track ;
M: traceback-gadget pref-dim* drop { 550 600 } ; M: traceback-gadget pref-dim* drop { 550 600 } ;
: <traceback-gadget> ( model -- gadget ) : <traceback-gadget> ( model -- gadget )
{ 0 1 } traceback-gadget new-track vertical traceback-gadget new-track
swap >>model swap >>model
dup model>> dup model>>
{ 1 0 } <track> horizontal <track>
over <datastack-display> 1/2 track-add over <datastack-display> 1/2 track-add
swap <retainstack-display> 1/2 track-add swap <retainstack-display> 1/2 track-add
1/3 track-add 1/3 track-add

2
basis/ui/tools/walker/walker.factor
View File

@ -58,7 +58,7 @@ M: walker-gadget focusable-child*
'[ _ walker-state-string ] <filter> <label-control> ; '[ _ walker-state-string ] <filter> <label-control> ;
: <walker-gadget> ( status continuation thread -- gadget ) : <walker-gadget> ( status continuation thread -- gadget )
{ 0 1 } walker-gadget new-track vertical walker-gadget new-track
swap >>thread swap >>thread
swap >>continuation swap >>continuation
swap >>status swap >>status

2
basis/ui/traverse/traverse.factor
View File

@ -78,7 +78,7 @@ DEFER: (gadget-subtree)
[ (gadget-subtree) ] { } make ; [ (gadget-subtree) ] { } make ;
M: node gadget-text* 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-text-range ( frompath topath gadget -- str )
gadget-subtree gadget-text ; gadget-subtree gadget-text ;

2
basis/ui/ui-docs.factor
View File

@ -71,7 +71,7 @@ ARTICLE: "ui-glossary" "UI glossary"
{ "font" { "an instance of " { $link font } } } { "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 } "." } } { "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" } } } { "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" } { "point" "a pair of integers denoting a pixel location on screen" }
} ; } ;