From 40d52ac227ff81512dffe037bd5ed18c9f501ef8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Jul 2008 00:00:31 -0500 Subject: [PATCH 1/2] Fix typo --- extra/fry/fry-docs.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/fry/fry-docs.factor b/extra/fry/fry-docs.factor index 7a444fecbc..eba2f95727 100755 --- a/extra/fry/fry-docs.factor +++ b/extra/fry/fry-docs.factor @@ -40,9 +40,9 @@ $nl } "Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following three lines are equivalent:" { $code - "{ 10 20 30 } [ sq ] '[ @ . ] map" - "{ 10 20 30 } [ sq ] [ . ] compose map" - "{ 10 20 30 } [ sq . ] map" + "{ 10 20 30 } [ sq ] '[ @ . ] each" + "{ 10 20 30 } [ sq ] [ . ] compose each" + "{ 10 20 30 } [ sq . ] each" } "The " { $link , } " and " { $link @ } " specifiers may be freely mixed:" { $code From 64a2b0c7a5ce13ee5fd34476c2bec0cab3516907 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Jul 2008 00:01:22 -0500 Subject: [PATCH 2/2] Remove more delegation usage from UI: build-* words, various misc things --- core/kernel/kernel.factor | 3 - extra/ui/commands/commands-docs.factor | 19 ++-- extra/ui/commands/commands.factor | 11 +-- extra/ui/gadgets/books/books-docs.factor | 7 ++ extra/ui/gadgets/buttons/buttons.factor | 2 +- extra/ui/gadgets/editors/editors-tests.factor | 9 +- extra/ui/gadgets/frames/frames-docs.factor | 29 ++++-- extra/ui/gadgets/frames/frames.factor | 3 - extra/ui/gadgets/gadgets-docs.factor | 10 +- extra/ui/gadgets/gadgets.factor | 18 ++-- extra/ui/gadgets/grids/grids-docs.factor | 12 +++ .../incremental/incremental-docs.factor | 17 ++++ extra/ui/gadgets/labelled/labelled.factor | 24 +++-- extra/ui/gadgets/packs/packs-docs.factor | 18 ++++ extra/ui/gadgets/packs/packs.factor | 4 - extra/ui/gadgets/panes/panes.factor | 39 ++++---- extra/ui/gadgets/paragraphs/paragraphs.factor | 6 +- .../presentations/presentations-docs.factor | 4 +- .../presentations/presentations.factor | 11 ++- extra/ui/gadgets/slots/slots-tests.factor | 2 + extra/ui/gadgets/slots/slots.factor | 37 +++---- .../gadgets/status-bar/status-bar-docs.factor | 6 +- extra/ui/gadgets/tracks/tracks-docs.factor | 19 +++- extra/ui/gadgets/tracks/tracks.factor | 5 +- extra/ui/gadgets/worlds/worlds.factor | 6 +- extra/ui/operations/operations.factor | 19 ++-- extra/ui/tools/browser/browser.factor | 23 ++--- extra/ui/tools/debugger/debugger.factor | 22 +++-- extra/ui/tools/deploy/deploy.factor | 17 ++-- extra/ui/tools/inspector/inspector.factor | 12 ++- extra/ui/tools/interactor/interactor.factor | 2 +- extra/ui/tools/listener/listener-tests.factor | 2 +- extra/ui/tools/listener/listener.factor | 28 +++--- extra/ui/tools/profiler/profiler.factor | 14 +-- extra/ui/tools/search/search.factor | 14 +-- extra/ui/tools/tools.factor | 2 +- extra/ui/tools/walker/walker.factor | 44 +++++---- extra/ui/ui-docs.factor | 98 +------------------ 38 files changed, 312 insertions(+), 306 deletions(-) diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 6b785a61ba..bcf75b9e0f 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -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 diff --git a/extra/ui/commands/commands-docs.factor b/extra/ui/commands/commands-docs.factor index 83628cc171..134488fa8f 100644 --- a/extra/ui/commands/commands-docs.factor +++ b/extra/ui/commands/commands-docs.factor @@ -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." } ; diff --git a/extra/ui/commands/commands.factor b/extra/ui/commands/commands.factor index 39eed24ada..2677c496ec 100755 --- a/extra/ui/commands/commands.factor +++ b/extra/ui/commands/commands.factor @@ -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 ) : ( 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 ; diff --git a/extra/ui/gadgets/books/books-docs.factor b/extra/ui/gadgets/books/books-docs.factor index 197ef7d4a2..01426b4457 100755 --- a/extra/ui/gadgets/books/books-docs.factor +++ b/extra/ui/gadgets/books/books-docs.factor @@ -9,3 +9,10 @@ $nl HELP: { $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 } ; + +ABOUT: "ui-book-layout" diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor index ab71081c87..e38676c375 100755 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/extra/ui/gadgets/buttons/buttons.factor @@ -225,7 +225,7 @@ M: radio-control model-changed : ( target -- toolbar ) [ - "toolbar" over class command-map swap + "toolbar" over class command-map commands>> swap [ -rot gadget, ] curry assoc-each ] make-shelf ; diff --git a/extra/ui/gadgets/editors/editors-tests.factor b/extra/ui/gadgets/editors/editors-tests.factor index f3a6b9fd5d..166e6c264b 100755 --- a/extra/ui/gadgets/editors/editors-tests.factor +++ b/extra/ui/gadgets/editors/editors-tests.factor @@ -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" set @@ -44,5 +45,5 @@ documents ui.gestures tools.test.ui models ; "hello" "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 diff --git a/extra/ui/gadgets/frames/frames-docs.factor b/extra/ui/gadgets/frames/frames-docs.factor index c593358841..26f72bcc57 100755 --- a/extra/ui/gadgets/frames/frames-docs.factor +++ b/extra/ui/gadgets/frames/frames-docs.factor @@ -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 } +"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: { $values { "frame" frame } } { $description "Creates a new " { $link frame } " for laying out gadgets in a 3x3 grid." } ; -{ make-frame build-frame } related-words +{ 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" diff --git a/extra/ui/gadgets/frames/frames.factor b/extra/ui/gadgets/frames/frames.factor index 77e9d79035..df1b7aa654 100644 --- a/extra/ui/gadgets/frames/frames.factor +++ b/extra/ui/gadgets/frames/frames.factor @@ -41,8 +41,5 @@ M: frame layout* : make-frame ( quot -- frame ) make-gadget ; inline -: build-frame ( tuple quot -- tuple ) - build-gadget ; inline - : frame, ( gadget i j -- ) \ make-gadget get -rot grid-add ; diff --git a/extra/ui/gadgets/gadgets-docs.factor b/extra/ui/gadgets/gadgets-docs.factor index cf923a8bea..f05126fec3 100755 --- a/extra/ui/gadgets/gadgets-docs.factor +++ b/extra/ui/gadgets/gadgets-docs.factor @@ -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 diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 5b26f7424d..58b58d4fdc 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -71,9 +71,6 @@ M: gadget model-changed 2drop ; : ( -- gadget ) gadget new-gadget ; -: construct-gadget ( class -- tuple ) - >r 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 { set-delegate } r> construct ; inline diff --git a/extra/ui/gadgets/grids/grids-docs.factor b/extra/ui/gadgets/grids/grids-docs.factor index a3a65f633f..eb7affdb80 100755 --- a/extra/ui/gadgets/grids/grids-docs.factor +++ b/extra/ui/gadgets/grids/grids-docs.factor @@ -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 } +"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" diff --git a/extra/ui/gadgets/incremental/incremental-docs.factor b/extra/ui/gadgets/incremental/incremental-docs.factor index f7129ebbff..cbeb34bf74 100755 --- a/extra/ui/gadgets/incremental/incremental-docs.factor +++ b/extra/ui/gadgets/incremental/incremental-docs.factor @@ -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 } +"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" diff --git a/extra/ui/gadgets/labelled/labelled.factor b/extra/ui/gadgets/labelled/labelled.factor index 4aea7210a0..ee27620273 100755 --- a/extra/ui/gadgets/labelled/labelled.factor +++ b/extra/ui/gadgets/labelled/labelled.factor @@ -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 ; : ( gadget title -- newgadget ) - labelled-gadget new + { 0 1 } labelled-gadget new-track [ -