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

Remove more delegation usage from UI: build-* words, various misc things

db4
Slava Pestov 2008-07-11 00:01:22 -05:00
parent 40d52ac227
commit 64a2b0c7a5
38 changed files with 312 additions and 306 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
core/kernel/kernel.factor
View File

@ -210,6 +210,3 @@ GENERIC# set-slots 1 ( ... tuple slots -- )
: construct ( ... slots class -- tuple )
new [ swap set-slots ] keep ; inline
: construct-delegate ( delegate class -- tuple )
>r { set-delegate } r> construct ; inline

19
extra/ui/commands/commands-docs.factor
View File

@ -1,22 +1,21 @@
USING: ui.gestures help.markup help.syntax strings kernel
USING: accessors ui.gestures help.markup help.syntax strings kernel
hashtables quotations words classes sequences namespaces
arrays assocs ;
IN: ui.commands
: command-map-row ( children -- seq )
: command-map-row ( gesture command -- seq )
[
[ first gesture>string , ]
[ gesture>string , ]
[
second
[ command-name , ]
[ command-word \ $link swap 2array , ]
[ command-description , ]
tri
] bi
] bi*
] { } make ;
: command-map. ( command-map -- )
[ command-map-row ] map
: command-map. ( alist -- )
[ command-map-row ] { } assoc>map
{ "Shortcut" "Command" "Word" "Notes" }
[ \ $strong swap ] { } map>assoc prefix
$table ;
@ -25,11 +24,13 @@ IN: ui.commands
[ second (command-name) " commands" append $heading ]
[
first2 swap command-map
[ command-map-blurb print-element ] [ command-map. ] bi
[ blurb>> print-element ] [ commands>> command-map. ] bi
] bi ;
: $command ( element -- )
reverse first3 command-map value-at gesture>string $snippet ;
reverse first3 command-map
commands>> value-at gesture>string
$snippet ;
HELP: +nullary+
{ $description "A key which may be set in the hashtable passed to " { $link define-command } ". If set to a true value, the command does not take any inputs, and the value passed to " { $link invoke-command } " will be ignored. Otherwise, it takes one input." } ;

11
extra/ui/commands/commands.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions kernel sequences strings
math assocs words generic namespaces assocs quotations splitting
@ -15,16 +15,14 @@ GENERIC: invoke-command ( target command -- )
GENERIC: command-name ( command -- str )
TUPLE: command-map blurb ;
TUPLE: command-map blurb commands ;
GENERIC: command-description ( command -- str/f )
GENERIC: command-word ( command -- word )
: <command-map> ( blurb commands -- command-map )
{ } like
{ set-command-map-blurb set-delegate }
\ command-map construct ;
{ } like \ command-map boa ;
: commands ( class -- hash )
dup "commands" word-prop [ ] [
@ -37,7 +35,8 @@ GENERIC: command-word ( command -- word )
: command-gestures ( class -- hash )
commands values [
[
[ first ] filter
commands>>
[ drop ] assoc-filter
[ [ invoke-command ] curry swap set ] assoc-each
] each
] H{ } make-assoc ;

7
extra/ui/gadgets/books/books-docs.factor
View File

@ -9,3 +9,10 @@ $nl
HELP: <book>
{ $values { "pages" "a sequence of gadgets" } { "model" model } { "book" book } }
{ $description "Creates a " { $link book } " control, which contains the gadgets in " { $snippet "pages" } ". A book shows one child at a time, determined by the value of the model, which must be an integer " } ;
ARTICLE: "ui-book-layout" "Book layouts"
"Books can contain any number of children, and display one child at a time."
{ $subsection book }
{ $subsection <book> } ;
ABOUT: "ui-book-layout"

2
extra/ui/gadgets/buttons/buttons.factor
View File

@ -225,7 +225,7 @@ M: radio-control model-changed
: <toolbar> ( target -- toolbar )
[
"toolbar" over class command-map swap
"toolbar" over class command-map commands>> swap
[ -rot <command-button> gadget, ] curry assoc-each
] make-shelf ;

9
extra/ui/gadgets/editors/editors-tests.factor
View File

@ -1,6 +1,7 @@
USING: ui.gadgets.editors tools.test kernel io io.streams.plain
definitions namespaces ui.gadgets ui.gadgets.grids prettyprint
documents ui.gestures tools.test.ui models ;
USING: accessors ui.gadgets.editors tools.test kernel io
io.streams.plain definitions namespaces ui.gadgets
ui.gadgets.grids prettyprint documents ui.gestures tools.test.ui
models ;
[ "foo bar" ] [
<editor> "editor" set
@ -44,5 +45,5 @@ documents ui.gestures tools.test.ui models ;
"hello" <model> <field> "field" set
"field" get [
[ "hello" ] [ "field" get field-model model-value ] unit-test
[ "hello" ] [ "field" get field-model>> model-value ] unit-test
] with-grafted-gadget

29
extra/ui/gadgets/frames/frames-docs.factor
View File

@ -2,6 +2,25 @@ USING: help.syntax help.markup ui.gadgets kernel arrays
quotations classes.tuple ui.gadgets.grids ;
IN: ui.gadgets.frames
ARTICLE: "ui-frame-layout" "Frame layouts"
"Frames resemble " { $link "ui-grid-layout" } " except the size of grid is fixed at 3x3, and the center gadget fills up any available space. Because frames delegate to grids, grid layout words can be used to add and remove children."
{ $subsection frame }
"Creating empty frames:"
{ $subsection <frame> }
"Creating new frames using a combinator:"
{ $subsection make-frame }
{ $subsection frame, }
"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add } " or " { $link frame, } ":"
{ $subsection @center }
{ $subsection @left }
{ $subsection @right }
{ $subsection @top }
{ $subsection @bottom }
{ $subsection @top-left }
{ $subsection @top-right }
{ $subsection @bottom-left }
{ $subsection @bottom-right } ;
: $ui-frame-constant ( element -- )
drop
{ $description "Symbolic constant for a common input to " { $link grid-add } " and " { $link frame, } "." } print-element ;
@ -25,18 +44,16 @@ HELP: <frame>
{ $values { "frame" frame } }
{ $description "Creates a new " { $link frame } " for laying out gadgets in a 3x3 grid." } ;
{ <frame> make-frame build-frame } related-words
{ <frame> make-frame } related-words
HELP: make-frame
{ $values { "quot" quotation } { "frame" frame } }
{ $description "Creates a new frame. The quotation can add children by calling the " { $link frame, } " word." } ;
HELP: build-frame
{ $values { "tuple" tuple } { "quot" quotation } }
{ $description "Creates a new frame and sets " { $snippet "tuple" } "'s delegate to the new frame. The quotation can add children by calling the " { $link frame, } " word, and access the frame by calling " { $link g } " or " { $link g-> } "." } ;
HELP: frame,
{ $values { "gadget" gadget } { "i" "non-negative integer" } { "j" "non-negative integer" } }
{ $description "Adds a child gadget at the specified location. This word can only be called inside the quotation passed to " { $link make-frame } " or " { $link build-frame } "." } ;
{ $description "Adds a child gadget at the specified location. This word can only be called inside the quotation passed to " { $link make-frame } "." } ;
{ grid frame } related-words
ABOUT: "ui-frame-layout"

3
extra/ui/gadgets/frames/frames.factor
View File

@ -41,8 +41,5 @@ M: frame layout*
: make-frame ( quot -- frame )
<frame> make-gadget ; inline
: build-frame ( tuple quot -- tuple )
<frame> build-gadget ; inline
: frame, ( gadget i j -- )
\ make-gadget get -rot grid-add ;

10
extra/ui/gadgets/gadgets-docs.factor
View File

@ -232,27 +232,23 @@ HELP: focusable-child
HELP: gadget,
{ $values { "gadget" gadget } }
{ $description "Adds a new child to the gadget being constructed. This word can only be used from a quotation passed to " { $link make-gadget } " or " { $link build-gadget } "." } ;
{ $description "Adds a new child to the gadget being constructed. This word can only be used from a quotation passed to " { $link make-gadget } "." } ;
HELP: make-gadget
{ $values { "quot" quotation } { "gadget" gadget } }
{ $description "Calls the quotation in a new scope with the gadget stored in the " { $link make-gadget } " variable." } ;
HELP: build-gadget
{ $values { "tuple" tuple } { "quot" quotation } { "gadget" gadget } }
{ $description "Delegates the tuple to the gadget, and calls the quotation in a new scope with the tuple stored in the " { $link make-gadget } " and " { $link gadget } " variables." } ;
HELP: with-gadget
{ $values { "gadget" gadget } { "quot" quotation } }
{ $description "Calls the quotation in a new scope with the " { $link gadget } " and " { $link make-gadget } " variables set to " { $snippet "gadget" } ". The quotation can call " { $link g } " and " { $link g-> } " to access the gadget." } ;
HELP: g
{ $values { "gadget" gadget } }
{ $description "Outputs the gadget being built. Can only be used inside a quotation passed to " { $link build-gadget } "." } ;
{ $description "Outputs the gadget being built. Can only be used inside a quotation passed to " { $link with-gadget } "." } ;
HELP: g->
{ $values { "x" object } { "gadget" gadget } }
{ $description "Duplicates the top of the stack and outputs the gadget being built. Can only be used inside a quotation passed to " { $link build-gadget } "." } ;
{ $description "Duplicates the top of the stack and outputs the gadget being built. Can only be used inside a quotation passed to " { $link with-gadget } "." } ;
{ control-value set-control-value gadget-model } related-words

18
extra/ui/gadgets/gadgets.factor
View File

@ -71,9 +71,6 @@ M: gadget model-changed 2drop ;
: <gadget> ( -- gadget )
gadget new-gadget ;
: construct-gadget ( class -- tuple )
>r <gadget> r> construct-delegate ; inline
: activate-control ( gadget -- )
dup gadget-model dup [
2dup add-connection
@ -140,11 +137,6 @@ M: gadget children-on nip gadget-children ;
: each-child ( gadget quot -- )
>r gadget-children r> each ; inline
: set-gadget-delegate ( gadget tuple -- )
over [
dup pick [ set-gadget-parent ] with each-child
] when set-delegate ;
! Selection protocol
GENERIC: gadget-selection? ( gadget -- ? )
@ -413,5 +405,11 @@ M: f request-focus-on 2drop ;
swap dup \ make-gadget set gadget set call
] with-scope ; inline
: build-gadget ( tuple quot gadget -- tuple )
pick set-gadget-delegate over >r with-gadget r> ; inline
! Deprecated
: set-gadget-delegate ( gadget tuple -- )
over [
dup pick [ set-gadget-parent ] with each-child
] when set-delegate ;
: construct-gadget ( class -- tuple )
>r <gadget> { set-delegate } r> construct ; inline

12
extra/ui/gadgets/grids/grids-docs.factor
View File

@ -1,6 +1,16 @@
USING: ui.gadgets help.markup help.syntax arrays ;
IN: ui.gadgets.grids
ARTICLE: "ui-grid-layout" "Grid layouts"
"Grid gadgets layout their children in a rectangular grid."
{ $subsection grid }
"Creating grids from a fixed set of gadgets:"
{ $subsection <grid> }
"Managing chidren:"
{ $subsection grid-add }
{ $subsection grid-remove }
{ $subsection grid-child } ;
HELP: grid
{ $class-description "A grid gadget lays out its children so that all gadgets in a column have equal width and all gadgets in a row have equal height."
$nl
@ -30,3 +40,5 @@ HELP: grid-remove
{ $values { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } }
{ $description "Removes a child gadget from the specified location." }
{ $side-effects "grid" } ;
ABOUT: "ui-grid-layout"

17
extra/ui/gadgets/incremental/incremental-docs.factor
View File

@ -25,3 +25,20 @@ HELP: clear-incremental
{ $values { "incremental" incremental } }
{ $description "Removes all gadgets from the incremental layout and performs relayout immediately in constant time." }
{ $side-effects "incremental" } ;
ARTICLE: "ui-incremental-layout" "Incremental layouts"
"Incremental layout gadgets are like " { $link "ui-pack-layout" } " except the relayout operation after adding a new child can be done in constant time."
$nl
"With all layouts, relayout requests from consecutive additions and removals are of children are coalesced and result in only one relayout operation being performed, however the run time of the relayout operation itself depends on the number of children."
$nl
"Incremental layout is used by " { $link "ui.gadgets.panes" } " to ensure that new lines of output does not take longer to display when the pane already has previous output."
$nl
"Incremental layouts are not a general replacement for " { $link "ui-pack-layout" } " and there are some limitations to be aware of."
{ $subsection incremental }
{ $subsection <incremental> }
"Children are added and removed with a special set of words which perform necessary relayout immediately:"
{ $subsection add-incremental }
{ $subsection clear-incremental }
"Calling " { $link unparent } " to remove a child of an incremental layout is permitted, however the relayout following the removal will not be performed in constant time, because all gadgets following the removed gadget need to be moved." ;
ABOUT: "ui-incremental-layout"

16
extra/ui/gadgets/labelled/labelled.factor
View File

@ -8,14 +8,16 @@ sequences sequences words classes.tuple ui.gadgets ui.render
colors ;
IN: ui.gadgets.labelled
TUPLE: labelled-gadget content ;
TUPLE: labelled-gadget < track content ;
: <labelled-gadget> ( gadget title -- newgadget )
labelled-gadget new
{ 0 1 } labelled-gadget new-track
[
[
<label> reverse-video-theme f track,
g-> set-labelled-gadget-content 1 track,
] { 0 1 } build-track ;
] with-gadget
] keep ;
M: labelled-gadget focusable-child* labelled-gadget-content ;
@ -44,16 +46,18 @@ M: labelled-gadget focusable-child* labelled-gadget-content ;
<title-label> @center frame,
] make-frame ;
TUPLE: closable-gadget content ;
TUPLE: closable-gadget < frame content ;
: find-closable-gadget ( parent -- child )
[ [ closable-gadget? ] is? ] find-parent ;
: <closable-gadget> ( gadget title quot -- gadget )
closable-gadget new
closable-gadget new-frame
[
[
<title-bar> @top frame,
g-> set-closable-gadget-content @center frame,
] build-frame ;
] with-gadget
] keep ;
M: closable-gadget focusable-child* closable-gadget-content ;

18
extra/ui/gadgets/packs/packs-docs.factor
View File

@ -2,6 +2,22 @@ USING: ui.gadgets help.markup help.syntax generic kernel
classes.tuple quotations ;
IN: ui.gadgets.packs
ARTICLE: "ui-pack-layout" "Pack layouts"
"Pack gadgets layout their children along a single axis."
{ $subsection pack }
"Creating empty packs:"
{ $subsection <pack> }
{ $subsection <pile> }
{ $subsection <shelf> }
"Creating packs using a combinator:"
{ $subsection make-pile }
{ $subsection make-filled-pile }
{ $subsection make-shelf }
{ $subsection gadget, }
"For more control, custom layouts can reuse portions of pack layout logic:"
{ $subsection pack-pref-dim }
{ $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:"
{ $list
@ -59,3 +75,5 @@ HELP: make-filled-pile
HELP: make-shelf
{ $values { "quot" quotation } { "pack" "a new " { $link pack } } }
{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets horizontally. The quotation can add children by calling the " { $link gadget, } " word." } ;
ABOUT: "ui-pack-layout"

4
extra/ui/gadgets/packs/packs.factor
View File

@ -69,7 +69,3 @@ M: pack children-on ( rect gadget -- seq )
: make-shelf ( quot -- pack )
<shelf> make-gadget ; inline
: build-pack ( quot quot orientation -- pack )
<pack> build-gadget ; inline

39
extra/ui/gadgets/panes/panes.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.scrollers
@ -200,13 +200,15 @@ M: pane-stream make-span-stream
: apply-presentation-style ( style gadget -- style gadget )
presented [ <presentation> ] apply-style ;
: <styled-label> ( style text -- gadget )
<label>
: style-label ( style gadget -- gadget )
apply-foreground-style
apply-background-style
apply-font-style
apply-presentation-style
nip ;
nip ; inline
: <styled-label> ( style text -- gadget )
<label> style-label ;
! Paragraph styles
@ -240,28 +242,27 @@ M: pane-stream make-span-stream
apply-printer-style
nip ;
TUPLE: nested-pane-stream style parent ;
TUPLE: nested-pane-stream < pane-stream style parent ;
: <nested-pane-stream> ( style parent -- stream )
>r <pane> apply-wrap-style <pane-stream> r> {
set-nested-pane-stream-style
set-delegate
set-nested-pane-stream-parent
} nested-pane-stream construct ;
: new-nested-pane-stream ( style parent class -- stream )
new
swap >>parent
swap <pane> apply-wrap-style [ >>style ] [ >>pane ] bi* ;
inline
: unnest-pane-stream ( stream -- child parent )
dup ?nl
dup nested-pane-stream-style
over pane-stream-pane smash-pane style-pane
swap nested-pane-stream-parent ;
dup style>>
over pane>> smash-pane style-pane
swap parent>> ;
TUPLE: pane-block-stream ;
TUPLE: pane-block-stream < nested-pane-stream ;
M: pane-block-stream dispose
unnest-pane-stream write-gadget ;
M: pane-stream make-block-stream
<nested-pane-stream> pane-block-stream construct-delegate ;
pane-block-stream new-nested-pane-stream ;
! Tables
: apply-table-gap-style ( style grid -- style grid )
@ -278,12 +279,12 @@ M: pane-stream make-block-stream
apply-table-border-style
nip ;
TUPLE: pane-cell-stream ;
TUPLE: pane-cell-stream < nested-pane-stream ;
M: pane-cell-stream dispose ?nl ;
M: pane-stream make-cell-stream
<nested-pane-stream> pane-cell-stream construct-delegate ;
pane-cell-stream new-nested-pane-stream ;
M: pane-stream stream-write-table
>r
@ -303,7 +304,7 @@ M: paragraph dispose drop ;
M: pack stream-write gadget-write ;
: gadget-bl ( style stream -- )
>r " " <styled-label> <word-break-gadget> r> add-gadget ;
>r " " <word-break-gadget> style-label r> add-gadget ;
M: paragraph stream-write
swap " " split

6
extra/ui/gadgets/paragraphs/paragraphs.factor
View File

@ -5,10 +5,10 @@ namespaces sequences math.order ;
IN: ui.gadgets.paragraphs
! A word break gadget
TUPLE: word-break-gadget ;
TUPLE: word-break-gadget < label ;
: <word-break-gadget> ( gadget -- gadget )
{ set-delegate } word-break-gadget construct ;
: <word-break-gadget> ( text -- gadget )
word-break-gadget new-label ;
M: word-break-gadget draw-gadget* drop ;

4
extra/ui/gadgets/presentations/presentations-docs.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax ui.gadgets.buttons
ui.gadgets.menus models ui.operations summary kernel
ui.gadgets.worlds ui.gadgets ;
ui.gadgets.worlds ui.gadgets ui.gadgets.status-bar ;
IN: ui.gadgets.presentations
HELP: presentation
@ -37,6 +37,8 @@ HELP: <presentation>
{ <commands-menu> <toolbar> operations-menu show-menu } related-words
{ <status-bar> show-mouse-help show-status show-summary hide-status } related-words
HELP: show-mouse-help
{ $values { "presentation" presentation } }
{ $description "Displays a " { $link summary } " of the " { $link presentation-object } "in the status bar of the " { $link world } " containing this presentation. This word is executed when the mouse enters the presentation." } ;

11
extra/ui/gadgets/presentations/presentations.factor
View File

@ -1,10 +1,11 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays accessors definitions ui.gadgets ui.gadgets.borders
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.menus
ui.gadgets.worlds hashtables io kernel prettyprint sequences
strings io.styles words help math models namespaces quotations
ui.commands ui.operations ui.gestures ;
USING: arrays accessors definitions hashtables io kernel
prettyprint sequences strings io.styles words help math models
namespaces quotations
ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.menus ui.gadgets.worlds
ui.gadgets.status-bar ui.commands ui.operations ui.gestures ;
IN: ui.gadgets.presentations
TUPLE: presentation < button object hook ;

2
extra/ui/gadgets/slots/slots-tests.factor
View File

@ -1,4 +1,6 @@
IN: ui.gadgets.slots.tests
USING: assocs ui.gadgets.slots tools.test refs ;
\ <editable-slot> must-infer
[ t ] [ { 1 2 3 } 2 <value-ref> <slot-editor> slot-editor? ] unit-test

31
extra/ui/gadgets/slots/slots.factor
View File

@ -13,7 +13,7 @@ TUPLE: update-slot ;
TUPLE: edit-slot ;
TUPLE: slot-editor ref text ;
TUPLE: slot-editor < track ref text ;
: revert ( slot-editor -- )
dup slot-editor-ref get-ref unparse-use
@ -69,16 +69,20 @@ M: value-ref finish-editing
} define-command
: <slot-editor> ( ref -- gadget )
slot-editor new
[ set-slot-editor-ref ] keep
{ 0 1 } slot-editor new-track
swap >>ref
[
[
toolbar,
<source-editor> g-> set-slot-editor-text
<scroller> 1 track,
] { 0 1 } build-track
] with-gadget
] keep
dup revert ;
M: slot-editor pref-dim* delegate pref-dim* { 600 200 } vmin ;
M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
M: slot-editor focusable-child* text>> ;
slot-editor "toolbar" f {
{ T{ key-down f { C+ } "RET" } commit }
@ -100,17 +104,16 @@ TUPLE: editable-slot < track printer ref ;
[ 1 track, <edit-button> f track, ] with-gadget ;
: update-slot ( editable-slot -- )
[
dup editable-slot-ref get-ref
swap editable-slot-printer call
] keep
[ display-slot ] keep
scroll>gadget ;
[ [ ref>> get-ref ] [ printer>> ] bi call ] keep
display-slot ;
: edit-slot ( editable-slot -- )
dup clear-track dup [
dup editable-slot-ref <slot-editor> 1 track,
] with-gadget scroll>gadget ;
[ clear-track ]
[
dup ref>> <slot-editor>
[ swap 1 track-add ]
[ [ scroll>gadget ] [ request-focus ] bi* ] 2bi
] bi ;
\ editable-slot H{
{ T{ update-slot } [ update-slot ] }

6
extra/ui/gadgets/status-bar/status-bar-docs.factor
View File

@ -1,10 +1,8 @@
USING: ui.gadgets.presentations help.markup help.syntax models
USING: help.markup help.syntax models
ui.gadgets ui.gadgets.worlds ;
IN: ui.gadgets.status-bar
HELP: <status-bar>
{ $values { "model" model } { "gadget" "a new " { $link gadget } } }
{ $description "Creates a new " { $link gadget } " displaying the model value, which must be a string or " { $link f } "." }
{ $notes "If the " { $snippet "model" } " is " { $link world-status } ", this gadget will display " { $link presentation } " mouse over help." } ;
{ <status-bar> show-mouse-help show-status show-summary hide-status } related-words
{ $notes "If the " { $snippet "model" } " is " { $link world-status } ", this gadget will display mouse over help for " { $link "ui.gadgets.presentations" } "." } ;

19
extra/ui/gadgets/tracks/tracks-docs.factor
View File

@ -2,6 +2,17 @@ USING: ui.gadgets.packs help.markup help.syntax ui.gadgets
arrays kernel quotations classes.tuple ;
IN: ui.gadgets.tracks
ARTICLE: "ui-track-layout" "Track layouts"
"Track gadgets are like " { $link "ui-pack-layout" } " except each child is resized to a fixed multiple of the track's dimension."
{ $subsection track }
"Creating empty tracks:"
{ $subsection <track> }
"Adding children:"
{ $subsection track-add }
"Creating new tracks using a combinator:"
{ $subsection make-track }
{ $subsection track, } ;
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> } "." } ;
@ -9,7 +20,7 @@ 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 }" } "." } ;
{ <track> make-track build-track } related-words
{ <track> make-track } related-words
HELP: track-add
{ $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } }
@ -17,12 +28,10 @@ HELP: track-add
HELP: track,
{ $values { "gadget" gadget } { "constraint" "a number between 0 and 1, or " { $link f } } }
{ $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child. This word can only be called inside the quotation passed to " { $link make-track } " or " { $link build-track } "." } ;
{ $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child. This word can only be called inside the quotation passed to " { $link make-track } "." } ;
HELP: make-track
{ $values { "quot" quotation } { "orientation" "an orientation specifier" } { "track" track } }
{ $description "Creates a new track. The quotation can add children by calling the " { $link track, } " word." } ;
HELP: build-track
{ $values { "tuple" tuple } { "quot" quotation } { "orientation" "an orientation specifier" } }
{ $description "Creates a new track and sets " { $snippet "tuple" } "'s delegate to the new track. The quotation can add children by calling the " { $link track, } " word, and access the track by calling " { $link g } " or " { $link g-> } "." } ;
ABOUT: "ui-track-layout"

5
extra/ui/gadgets/tracks/tracks.factor
View File

@ -10,7 +10,7 @@ TUPLE: track < pack sizes ;
track-sizes
[ sift sum ] keep [ dup [ over / ] when ] map nip ;
: new-track ( orientation -- track )
: new-track ( orientation class -- track )
new-gadget
swap >>orientation
V{ } clone >>sizes
@ -55,9 +55,6 @@ M: track pref-dim*
: make-track ( quot orientation -- track )
<track> make-gadget ; inline
: build-track ( tuple quot orientation -- tuple )
<track> build-gadget ; inline
: track-remove ( gadget track -- )
over [
[ gadget-children index ] 2keep

6
extra/ui/gadgets/worlds/worlds.factor
View File

@ -65,11 +65,9 @@ M: world children-on nip gadget-children ;
over world-handle
rot rect-dim [ 0 > ] all? and and ;
TUPLE: world-error world ;
TUPLE: world-error error world ;
: <world-error> ( error world -- error )
{ set-delegate set-world-error-world }
world-error construct ;
C: <world-error> world-error
SYMBOL: ui-error-hook

19
extra/ui/operations/operations.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions kernel ui.commands ui.gestures
sequences strings math words generic namespaces hashtables
help.markup quotations assocs ;
USING: accessors arrays definitions kernel ui.commands
ui.gestures sequences strings math words generic namespaces
hashtables help.markup quotations assocs ;
IN: ui.operations
SYMBOL: +keyboard+
@ -12,12 +12,11 @@ SYMBOL: +secondary+
TUPLE: operation predicate command translator hook listener? ;
: <operation> ( predicate command -- operation )
[ ] [ ] {
set-operation-predicate
set-operation-command
set-operation-translator
set-operation-hook
} operation construct ;
operation new
[ ] >>hook
[ ] >>translator
swap >>command
swap >>predicate ;
PREDICATE: listener-operation < operation
dup operation-command listener-command?

17
extra/ui/tools/browser/browser.factor
View File

@ -7,7 +7,7 @@ ui.gadgets.buttons compiler.units assocs words vocabs
accessors ;
IN: ui.tools.browser
TUPLE: browser-gadget pane history ;
TUPLE: browser-gadget < track pane history ;
: show-help ( link help -- )
dup history>> add-history
@ -20,12 +20,15 @@ TUPLE: browser-gadget pane history ;
"handbook" >link <history> >>history drop ;
: <browser-gadget> ( -- gadget )
browser-gadget new
dup init-history [
{ 0 1 } browser-gadget new-track
dup init-history
[
[
toolbar,
g <help-pane> g-> set-browser-gadget-pane
<scroller> 1 track,
] { 0 1 } build-track ;
] with-gadget
] keep ;
M: browser-gadget call-tool* show-help ;
@ -33,12 +36,10 @@ M: browser-gadget tool-scroller
pane>> find-scroller ;
M: browser-gadget graft*
dup add-definition-observer
delegate graft* ;
[ add-definition-observer ] [ call-next-method ] bi ;
M: browser-gadget ungraft*
dup delegate ungraft*
remove-definition-observer ;
[ call-next-method ] [ remove-definition-observer ] bi ;
: showing-definition? ( defspec assoc -- ? )
[ key? ] 2keep

16
extra/ui/tools/debugger/debugger.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui ui.commands ui.gestures ui.gadgets
USING: accessors arrays ui ui.commands ui.gestures ui.gadgets
ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations
ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks
@ -12,7 +12,7 @@ IN: ui.tools.debugger
: <restart-list> ( restarts restart-hook -- gadget )
[ restart-name ] rot <model> <list> ;
TUPLE: debugger restarts ;
TUPLE: debugger < track restarts ;
: <debugger-display> ( restart-list error -- gadget )
[
@ -21,12 +21,14 @@ TUPLE: debugger restarts ;
] make-filled-pile ;
: <debugger> ( error restarts restart-hook -- gadget )
debugger new
{ 0 1 } debugger new-track
[
[
toolbar,
<restart-list> g-> set-debugger-restarts
swap <debugger-display> <scroller> 1 track,
] { 0 1 } build-track ;
] with-gadget
] keep ;
M: debugger focusable-child* debugger-restarts ;
@ -38,9 +40,9 @@ M: debugger focusable-child* debugger-restarts ;
M: world-error error.
"An error occurred while drawing the world " write
dup world-error-world pprint-short "." print
dup world>> pprint-short "." print
"This world has been deactivated to prevent cascading errors." print
delegate error. ;
error>> error. ;
debugger "gestures" f {
{ T{ button-down } request-focus }

13
extra/ui/tools/deploy/deploy.factor
View File

@ -8,7 +8,7 @@ ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
tools.deploy vocabs ui.tools.workspace system accessors ;
IN: ui.tools.deploy
TUPLE: deploy-gadget vocab settings ;
TUPLE: deploy-gadget < pack vocab settings ;
: bundle-name ( -- )
deploy-name get <field>
@ -105,11 +105,16 @@ deploy-gadget "toolbar" f {
g <toolbar> { 10 10 } over set-pack-gap gadget, ;
: <deploy-gadget> ( vocab -- gadget )
f deploy-gadget boa [
dup <deploy-settings>
deploy-gadget new-gadget
swap >>vocab
{ 0 1 } >>orientation
[
[
g vocab>> <deploy-settings>
g-> set-deploy-gadget-settings gadget,
buttons,
] { 0 1 } build-pack
] with-gadget
] keep
dup deploy-settings-theme
dup com-revert ;

8
extra/ui/tools/inspector/inspector.factor
View File

@ -6,7 +6,7 @@ ui.gadgets.slots ui.gadgets.tracks ui.gestures
ui.gadgets.buttons namespaces ;
IN: ui.tools.inspector
TUPLE: inspector-gadget object pane ;
TUPLE: inspector-gadget < track object pane ;
: refresh ( inspector -- )
dup inspector-gadget-object swap inspector-gadget-pane [
@ -14,11 +14,13 @@ TUPLE: inspector-gadget object pane ;
] with-pane ;
: <inspector-gadget> ( -- gadget )
inspector-gadget new
{ 0 1 } inspector-gadget new-track
[
[
toolbar,
<pane> g-> set-inspector-gadget-pane <scroller> 1 track,
] { 0 1 } build-track ;
] with-gadget
] keep ;
: inspect-object ( obj inspector -- )
[ set-inspector-gadget-object ] keep refresh ;

2
extra/ui/tools/interactor/interactor.factor
View File

@ -4,7 +4,7 @@ USING: arrays assocs combinators continuations documents
hashtables io io.styles kernel math math.order math.vectors
models models.delay namespaces parser lexer prettyprint
quotations sequences strings threads listener classes.tuple
ui.commands ui.gadgets ui.gadgets.editors
ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.status-bar
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
definitions calendar concurrency.flags concurrency.mailboxes
ui.tools.workspace accessors sets destructors ;

2
extra/ui/tools/listener/listener-tests.factor
View File

@ -5,7 +5,7 @@ ui.gadgets.panes vocabs words tools.test.ui slots.private
threads arrays generic threads accessors listener ;
IN: ui.tools.listener.tests
[ f ] [ "word" source-editor command-map empty? ] unit-test
[ f ] [ "word" source-editor command-map commands>> empty? ] unit-test
[ ] [ <listener-gadget> [ ] with-grafted-gadget ] unit-test

22
extra/ui/tools/listener/listener.factor
View File

@ -10,7 +10,7 @@ prettyprint listener debugger threads boxes concurrency.flags
math arrays generic accessors combinators assocs ;
IN: ui.tools.listener
TUPLE: listener-gadget input output stack ;
TUPLE: listener-gadget < track input output stack ;
: listener-output, ( -- )
<scrolling-pane> g-> set-listener-gadget-output
@ -118,15 +118,18 @@ M: engine-word word-completion-string
dup "\n" join pick add-interactor-history
swap select-all ;
TUPLE: stack-display ;
TUPLE: stack-display < track ;
: <stack-display> ( -- gadget )
stack-display new
g workspace-listener swap [
g workspace-listener
{ 0 1 } stack-display new-track
[
[
dup <toolbar> f track,
stack>> [ [ stack. ] curry try ]
t "Data stack" <labelled-pane> 1 track,
] { 0 1 } build-track ;
] with-gadget
] keep ;
M: stack-display tool-scroller
find-workspace workspace-listener tool-scroller ;
@ -169,8 +172,9 @@ M: stack-display tool-scroller
f <model> swap set-listener-gadget-stack ;
: <listener-gadget> ( -- gadget )
listener-gadget new dup init-listener
[ listener-output, listener-input, ] { 0 1 } build-track ;
{ 0 1 } listener-gadget new-track
dup init-listener
[ [ listener-output, listener-input, ] with-gadget ] keep ;
: listener-help ( -- ) "ui-listener" help-window ;
@ -189,7 +193,7 @@ M: listener-gadget handle-gesture* ( gadget gesture delegate -- ? )
[ default-gesture-handler ] [ 3drop f ] if ;
M: listener-gadget graft*
[ delegate graft* ] [ restart-listener ] bi ;
[ call-next-method ] [ restart-listener ] bi ;
M: listener-gadget ungraft*
[ com-end ] [ delegate ungraft* ] bi ;
[ com-end ] [ call-next-method ] bi ;

8
extra/ui/tools/profiler/profiler.factor
View File

@ -5,15 +5,17 @@ ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
ui.gadgets.tracks ui.gestures ui.gadgets.buttons ;
IN: ui.tools.profiler
TUPLE: profiler-gadget pane ;
TUPLE: profiler-gadget < track pane ;
: <profiler-gadget> ( -- gadget )
profiler-gadget new
{ 0 1 } profiler-gadget new-track
[
[
toolbar,
<pane> g-> set-profiler-gadget-pane
<scroller> 1 track,
] { 0 1 } build-track ;
] with-gadget
] keep ;
: with-profiler-pane ( gadget quot -- )
>r profiler-gadget-pane r> with-pane ;

8
extra/ui/tools/search/search.factor
View File

@ -11,7 +11,7 @@ vocabs words vocabs.loader tools.vocabs unicode.case calendar ui
;
IN: ui.tools.search
TUPLE: live-search field list ;
TUPLE: live-search < track field list ;
: search-value ( live-search -- value )
live-search-list list-value ;
@ -60,12 +60,14 @@ search-field H{
swap <list> ;
: <live-search> ( string seq limited? presenter -- gadget )
live-search new
{ 0 1 } live-search new-track
[
[
<search-field> g-> set-live-search-field f track,
<search-list> g-> set-live-search-list
<scroller> 1 track,
] { 0 1 } build-track
] with-gadget
] keep
[ live-search-field set-editor-string ] keep
[ live-search-field end-of-document ] keep ;

2
extra/ui/tools/tools.factor
View File

@ -14,7 +14,7 @@ IN: ui.tools
: <workspace-tabs> ( -- tabs )
g gadget-model
"tool-switching" workspace command-map
"tool-switching" workspace command-map commands>>
[ command-string ] { } assoc>map <enum> >alist
<toggle-buttons> ;

42
extra/ui/tools/walker/walker.factor
View File

@ -1,22 +1,24 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel concurrency.messaging inspector ui.tools.listener
ui.tools.traceback ui.gadgets.buttons ui.gadgets.status-bar
ui.gadgets.tracks ui.commands ui.gadgets models models.filter
ui.tools.workspace ui.gestures ui.gadgets.labels ui threads
namespaces tools.walker assocs combinators ;
USING: accessors kernel concurrency.messaging inspector
ui.tools.listener ui.tools.traceback ui.gadgets.buttons
ui.gadgets.status-bar ui.gadgets.tracks ui.commands ui.gadgets
models models.filter ui.tools.workspace ui.gestures
ui.gadgets.labels ui threads namespaces tools.walker assocs
combinators ;
IN: ui.tools.walker
TUPLE: walker-gadget
TUPLE: walker-gadget < track
status continuation thread
traceback
closing? ;
: walker-command ( walker msg -- )
swap
dup walker-gadget-thread thread-registered?
[ walker-gadget-thread send-synchronous drop ]
[ 2drop ] if ;
dup thread>> thread-registered?
[ thread>> send-synchronous drop ]
[ 2drop ]
if ;
: com-step ( walker -- ) step walker-command ;
@ -31,12 +33,10 @@ closing? ;
: com-abandon ( walker -- ) abandon walker-command ;
M: walker-gadget ungraft*
[ t swap set-walker-gadget-closing? ]
[ com-continue ]
[ delegate ungraft* ] tri ;
[ t >>closing? drop ] [ com-continue ] [ call-next-method ] tri ;
M: walker-gadget focusable-child*
walker-gadget-traceback ;
traceback>> ;
: walker-state-string ( status thread -- string )
[
@ -56,11 +56,17 @@ M: walker-gadget focusable-child*
[ walker-state-string ] curry <filter> <label-control> ;
: <walker-gadget> ( status continuation thread -- gadget )
over <traceback-gadget> f walker-gadget boa [
{ 0 1 } walker-gadget new-track
swap >>thread
swap >>continuation
swap >>status
[
[
toolbar,
g walker-gadget-status self <thread-status> f track,
g walker-gadget-traceback 1 track,
] { 0 1 } build-track ;
g status>> self <thread-status> f track,
g continuation>> <traceback-gadget> 1 track,
] with-gadget
] keep ;
: walker-help ( -- ) "ui-walker" help-window ;
@ -81,7 +87,7 @@ walker-gadget "toolbar" f {
{
{ [ dup walker-gadget? not ] [ 2drop f ] }
{ [ dup walker-gadget-closing? ] [ 2drop f ] }
[ walker-gadget-thread eq? ]
[ thread>> eq? ]
} cond ;
: find-walker-window ( thread -- world/f )

98
extra/ui/ui-docs.factor
View File

@ -1,8 +1,6 @@
USING: ui.gadgets.worlds ui.gadgets ui.backend help.markup
help.syntax strings quotations debugger io.styles namespaces
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids
ui.gadgets.frames ui.gadgets.books ui.gadgets.panes
ui.gadgets.incremental ;
USING: help.markup help.syntax strings quotations debugger
io.styles namespaces ui.backend ui.gadgets ui.gadgets.worlds
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids ;
IN: ui
HELP: windows
@ -239,103 +237,17 @@ $nl
{ $subsection make-gadget }
"Words such as " { $link gadget, } " and " { $link track, } " access the gadget through the " { $link make-gadget } " variable."
$nl
"Combinators whose names are prefixed with " { $snippet "build-" } " take a tuple as input, and construct a new gadget which the tuple will delegate to. The primitive combinator used to define all combinators of this form:"
{ $subsection build-gadget }
"In this case, the new gadget is stored in both the " { $link make-gadget } " and " { $link gadget } " variables."
$nl
"A combinator which stores a gadget in the " { $link gadget } " variable; it is used by " { $link build-gadget } ":"
"A combinator which stores a gadget in the " { $link gadget } " variable:"
{ $subsection with-gadget }
"The following words access the " { $link gadget } " variable; they can be used from " { $link with-gadget } " and " { $link build-gadget } " to store child gadgets in tuple slots:"
"The following words access the " { $link gadget } " variable; they can be used from " { $link with-gadget } " to store child gadgets in tuple slots:"
{ $subsection g }
{ $subsection g-> } ;
ARTICLE: "ui-pack-layout" "Pack layouts"
"Pack gadgets layout their children along a single axis."
{ $subsection pack }
"Creating empty packs:"
{ $subsection <pack> }
{ $subsection <pile> }
{ $subsection <shelf> }
"Creating packs using a combinator:"
{ $subsection make-pile }
{ $subsection make-filled-pile }
{ $subsection make-shelf }
{ $subsection gadget, }
"For more control, custom layouts can reuse portions of pack layout logic:"
{ $subsection pack-pref-dim }
{ $subsection pack-layout } ;
ARTICLE: "ui-track-layout" "Track layouts"
"Track gadgets are like " { $link "ui-pack-layout" } " except each child is resized to a fixed multiple of the track's dimension."
{ $subsection track }
"Creating empty tracks:"
{ $subsection <track> }
"Adding children:"
{ $subsection track-add }
"Creating new tracks using a combinator:"
{ $subsection make-track }
{ $subsection build-track }
{ $subsection track, }
"New gadgets can be defined which delegate to tracks for layout:"
{ $subsection build-track } ;
ARTICLE: "ui-grid-layout" "Grid layouts"
"Grid gadgets layout their children in a rectangular grid."
{ $subsection grid }
"Creating grids from a fixed set of gadgets:"
{ $subsection <grid> }
"Managing chidren:"
{ $subsection grid-add }
{ $subsection grid-remove }
{ $subsection grid-child } ;
ARTICLE: "ui-frame-layout" "Frame layouts"
"Frames resemble " { $link "ui-grid-layout" } " except the size of grid is fixed at 3x3, and the center gadget fills up any available space. Because frames delegate to grids, grid layout words can be used to add and remove children."
{ $subsection frame }
"Creating empty frames:"
{ $subsection <frame> }
"Creating new frames using a combinator:"
{ $subsection make-frame }
{ $subsection build-frame }
{ $subsection frame, }
"New gadgets can be defined which delegate to frames for layout:"
{ $subsection build-frame }
"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add } " or " { $link frame, } ":"
{ $subsection @center }
{ $subsection @left }
{ $subsection @right }
{ $subsection @top }
{ $subsection @bottom }
{ $subsection @top-left }
{ $subsection @top-right }
{ $subsection @bottom-left }
{ $subsection @bottom-right } ;
ARTICLE: "ui-book-layout" "Book layouts"
"Books can contain any number of children, and display one child at a time."
{ $subsection book }
{ $subsection <book> } ;
ARTICLE: "ui-null-layout" "Manual layouts"
"When automatic layout is not appropriate, gadgets can be added to a parent with no layout policy, and then positioned and sized manually:"
{ $subsection set-rect-loc }
{ $subsection set-gadget-dim } ;
ARTICLE: "ui-incremental-layout" "Incremental layouts"
"Incremental layout gadgets are like " { $link "ui-pack-layout" } " except the relayout operation after adding a new child can be done in constant time."
$nl
"With all layouts, relayout requests from consecutive additions and removals are of children are coalesced and result in only one relayout operation being performed, however the run time of the relayout operation itself depends on the number of children."
$nl
"Incremental layout is used by " { $link pane } " gadgets to ensure that new lines of output does not take longer to display when the pane already has previous output."
$nl
"Incremental layouts are not a general replacement for " { $link "ui-pack-layout" } " and there are some limitations to be aware of."
{ $subsection incremental }
{ $subsection <incremental> }
"Children are added and removed with a special set of words which perform necessary relayout immediately:"
{ $subsection add-incremental }
{ $subsection clear-incremental }
"Calling " { $link unparent } " to remove a child of an incremental layout is permitted, however the relayout following the removal will not be performed in constant time, because all gadgets following the removed gadget need to be moved." ;
ARTICLE: "ui-layout-impl" "Implementing layout gadgets"
"The relayout process proceeds top-down, with parents laying out their children, which in turn lay out their children. Custom layout policy is implemented by defining a method on a generic word:"
{ $subsection layout* }