Merge branch 'master' of git://factorcode.org/git/factor

extra/builder/util/util.factor

@@ -41,14 +41,6 @@ DEFER: to-strings
 
 : host-name* ( -- name ) host-name "." split first ;
 
-! : datestamp ( -- string )
-!   now `{ ,[ dup timestamp-year   ]
-!          ,[ dup timestamp-month  ]
-!          ,[ dup timestamp-day    ]
-!          ,[ dup timestamp-hour   ]
-!          ,[     timestamp-minute ] }
-!   [ pad-00 ] map "-" join ;
-
 : datestamp ( -- string )
   now
     { year>> month>> day>> hour>> minute>> } <arr>

extra/newfx/newfx.factor

@@ -1,5 +1,5 @@
 
-USING: kernel sequences assocs qualified circular sets ;
+USING: kernel sequences assocs qualified circular sets fry sequences.lib ;
 
 USING: math multi-methods ;
 
@@ -242,4 +242,11 @@ METHOD: as-mutate { object object assoc }       set-at ;
 
 : insert ( seq i obj -- seq ) >r cut r> prefix append ;
 
-: splice ( seq i seq -- seq ) >r cut r> prepend append ;
+: splice ( seq i seq -- seq ) >r cut r> prepend append ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: purge ( seq quot -- seq ) [ not ] compose filter ;
+
+: purge! ( seq quot -- seq )
+  dupd '[ swap @ [ pluck! ] [ drop ] if ] each-index ;

extra/ui/commands/commands-docs.factor

@@ -73,7 +73,7 @@ HELP: command-word
 HELP: command-map
 { $values { "group" string } { "class" "a class word" } { "command-map" "a " { $link command-map } " or " { $link f } } }
 { $description "Outputs a named command map defined on a class." }
-{ $class-description "A command map stores a group of related commands. Instances of this class delegate to arrays so behave like sequences; additionally the " { $link command-map-blurb } " slot stores a string description of the command group, or " { $link f } "."
+{ $class-description "A command map stores a group of related commands. The " { $snippet "commands" } " slot stores an association list mapping gestures to commands, and the " { $snippet "blurb" } " slot stores an optional one-line description string of this command map."
 $nl
 "Command maps are created by calling " { $link <command-map> } " or " { $link define-command-map } "." } ;
 

extra/ui/gadgets/buttons/buttons-docs.factor

@@ -11,7 +11,7 @@ $nl
 
 HELP: <button>
 { $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" "a new " { $link button } } }
-{ $description "Creates a new " { $link button } " which calls the quotation when clicked. The given gadget becomes the button's delegate." } ;
+{ $description "Creates a new " { $link button } " which calls the quotation when clicked. The given gadget becomes the button's only child." } ;
 
 HELP: <roll-button>
 { $values { "label" "a label specifier" } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" button } }

extra/ui/gadgets/buttons/buttons-tests.factor

@@ -16,7 +16,7 @@ TUPLE: foo-gadget ;
 T{ foo-gadget } <toolbar> "t" set
 
 [ 2 ] [ "t" get gadget-children length ] unit-test
-[ "Foo A" ] [ "t" get gadget-child gadget-child gadget-child label-string ] unit-test
+[ "Foo A" ] [ "t" get gadget-child gadget-child label-string ] unit-test
 
 [ ] [
     2 <model> {

extra/ui/gadgets/editors/editors.factor

@@ -480,7 +480,7 @@ multiline-editor "general" f {
     { T{ key-down f f "ENTER" } insert-newline }
 } define-command-map
 
-TUPLE: source-editor < editor ;
+TUPLE: source-editor < multiline-editor ;
 
 : <source-editor> ( -- editor )
     source-editor new-editor ;

extra/ui/gadgets/frames/frames-docs.factor

@@ -3,7 +3,7 @@ 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."
+"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 inherit from grids, grid layout words can be used to add and remove children."
 { $subsection frame }
 "Creating empty frames:"
 { $subsection <frame> }
@@ -38,7 +38,7 @@ HELP: @bottom-right $ui-frame-constant ;
 HELP: frame
 { $class-description "A frame is a gadget which lays out its children in a 3x3 grid. If the frame is enlarged past its preferred size, the center gadget fills up available room."
 $nl
-"Frames are constructed by calling " { $link <frame> } " and since they delegate to " { $link grid } " instances, children can be managed with " { $link grid-add } " and " { $link grid-remove } "." } ;
+"Frames are constructed by calling " { $link <frame> } " and since they inherit from " { $link grid } ", children can be managed with " { $link grid-add } " and " { $link grid-remove } "." } ;
 
 HELP: <frame>
 { $values { "frame" frame } }

extra/ui/gadgets/frames/frames.factor

@@ -39,7 +39,7 @@ M: frame layout*
     grid-layout ;
 
 : make-frame ( quot -- frame )
-    <frame> make-gadget ; inline
+    <frame> swap make-gadget ; inline
 
 : frame, ( gadget i j -- )
-    \ make-gadget get -rot grid-add ;
+    gadget get -rot grid-add ;

extra/ui/gadgets/gadgets-docs.factor

@@ -235,8 +235,8 @@ HELP: 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 } }
+{ $values { "gadget" gadget } { "quot" quotation } }
-{ $description "Calls the quotation in a new scope with the gadget stored in the " { $link make-gadget } " variable." } ;
+{ $description "Calls the quotation in a new scope with the gadget stored in the " { $link gadget } " variable." } ;
 
 HELP: with-gadget
 { $values { "gadget" gadget } { "quot" quotation } } 

extra/ui/gadgets/gadgets-tests.factor

@@ -1,8 +1,8 @@
 IN: ui.gadgets.tests
-USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
+USING: accessors ui.gadgets ui.gadgets.packs ui.gadgets.worlds
-namespaces models kernel dlists dequeues math sets
+tools.test namespaces models kernel dlists dequeues math sets
-math.parser ui sequences hashtables assocs io arrays
+math.parser ui sequences hashtables assocs io arrays prettyprint
-prettyprint io.streams.string ;
+io.streams.string ;
 
 [ T{ rect f { 10 10 } { 20 20 } } ]
 [
@@ -104,10 +104,10 @@ prettyprint io.streams.string ;
 
 [ t ] [ { 25 25 } "g1" get pick-up "g4" get eq? ] unit-test
 
-TUPLE: mock-gadget graft-called ungraft-called ;
+TUPLE: mock-gadget < gadget graft-called ungraft-called ;
 
 : <mock-gadget> ( -- gadget )
-    0 0 mock-gadget boa <gadget> over set-delegate ;
+    mock-gadget new-gadget 0 >>graft-called 0 >>ungraft-called ;
 
 M: mock-gadget graft*
     dup mock-gadget-graft-called 1+

extra/ui/gadgets/gadgets.factor

@@ -391,19 +391,17 @@ M: f request-focus-on 2drop ;
 : focus-path ( world -- seq )
     [ gadget-focus ] follow ;
 
-: make-gadget ( quot gadget -- gadget )
+: gadget, ( gadget -- ) gadget get add-gadget ;
-    [ \ make-gadget rot with-variable ] keep ; inline
-
-: gadget, ( gadget -- ) \ make-gadget get add-gadget ;
 
 : g ( -- gadget ) gadget get ;
 
 : g-> ( x -- x x gadget ) dup g ;
 
 : with-gadget ( gadget quot -- )
-    [
+    gadget swap with-variable ; inline
-        swap dup \ make-gadget set gadget set call
+
-    ] with-scope ; inline
+: make-gadget ( gadget quot -- gadget )
+    [ with-gadget ] [ drop ] 2bi ; inline
 
 ! Deprecated
 : set-gadget-delegate ( gadget tuple -- )

extra/ui/gadgets/incremental/incremental-docs.factor

@@ -2,7 +2,7 @@ USING: ui.gadgets help.markup help.syntax ui.gadgets.packs ;
 IN: ui.gadgets.incremental
 
 HELP: incremental
-{ $class-description "An incremental layout gadget delegates to a " { $link pack } " and implements an optimization which the relayout operation after adding a child to be done in constant time."
+{ $class-description "Incremental layout gadgets inherit from " { $link pack } " and implement an optimization where the relayout operation after adding a child to be done in constant time."
 $nl
 "Incremental layout gadgets are created by calling " { $link <incremental> } "."
 $nl

extra/ui/gadgets/labelled/labelled.factor

@@ -13,11 +13,9 @@ TUPLE: labelled-gadget < track content ;
 : <labelled-gadget> ( gadget title -- newgadget )
     { 0 1 } labelled-gadget new-track
     [
-        [
+        <label> reverse-video-theme f track,
-            <label> reverse-video-theme f track,
+        g-> set-labelled-gadget-content 1 track,
-            g-> set-labelled-gadget-content 1 track,
+    ] make-gadget ;
-        ] with-gadget
-    ] keep ;
 
 M: labelled-gadget focusable-child* labelled-gadget-content ;
 
@@ -54,10 +52,8 @@ TUPLE: closable-gadget < frame content ;
 : <closable-gadget> ( gadget title quot -- gadget )
     closable-gadget new-frame 
     [
-        [
+        <title-bar> @top frame,
-            <title-bar> @top frame,
+        g-> set-closable-gadget-content @center frame,
-            g-> set-closable-gadget-content @center frame,
+    ] make-gadget ;
-        ] with-gadget
-    ] keep ;
 
 M: closable-gadget focusable-child* closable-gadget-content ;

extra/ui/gadgets/packs/packs-docs.factor

@@ -34,13 +34,13 @@ HELP: pack
     { { $link pack-fill } " a rational number between 0 and 1, where 0 gives each gadget its preferred size and 1 fills the dimension perpendicular to the pack's orientation" }
     { { $link pack-gap } " a pair of integers, the horizontal and vertical gap between children" }
 }
-"Gadgets can delegate to packs and implement their own " { $link pref-dim* } " and " { $link layout* } " methods, reusing pack layout logic by calling " { $link pack-pref-dim } " and " { $link pack-layout } "." } ;
+"Custom gadgets can inherit from the " { $link pack } " class and implement their own " { $link pref-dim* } " and " { $link layout* } " methods, reusing pack layout logic by calling " { $link pack-pref-dim } " and " { $link pack-layout } "." } ;
 
 HELP: pack-layout
 { $values { "pack" "a new " { $link pack } } { "sizes" "a sequence of pairs of integers" } }
 { $description "Lays out the pack's children along the " { $link gadget-orientation } " of the pack, with each gadget receiving its size from the corresponding index of the " { $snippet "sizes" } " sequence." }
 { $notes
-    "This word is useful if you are writing your own layout gadget which delegates to a " { $link pack } ". This allows you to reuse layout logic while computing gadget sizes using a custom procedure."
+    "This word is useful if you are writing your own layout gadget which inherits from " { $link pack } ". This allows you to reuse layout logic while computing gadget sizes using a custom procedure."
 } ;
 
 HELP: <pack>
@@ -61,7 +61,7 @@ HELP: pack-pref-dim
 { $values { "gadget" gadget } { "sizes" "a sequence of pairs of integers" } { "dim" "a pair of integers" } }
 { $description "Computes the preferred size of a pack, with each gadget receiving its size from the corresponding index of the " { $snippet "sizes" } " sequence." }
 { $notes
-    "This word is useful if you are writing your own layout gadget which delegates to a " { $link pack } ". This allows you to reuse layout logic while computing gadget sizes using a custom procedure."
+    "This word is useful if you are writing your own layout gadget which inherits from " { $link pack } ". This allows you to reuse layout logic while computing gadget sizes using a custom procedure."
 } ;
 
 HELP: make-pile

extra/ui/gadgets/packs/packs.factor

@@ -62,10 +62,10 @@ M: pack children-on ( rect gadget -- seq )
     [ fast-children-on ] keep <slice> ;
 
 : make-pile ( quot -- pack )
-    <pile> make-gadget ; inline
+    <pile> swap make-gadget ; inline
 
 : make-filled-pile ( quot -- pack )
-    <filled-pile> make-gadget ; inline
+    <filled-pile> swap make-gadget ; inline
 
 : make-shelf ( quot -- pack )
-    <shelf> make-gadget ; inline
+    <shelf> swap make-gadget ; inline

extra/ui/gadgets/scrollers/scrollers.factor

@@ -30,15 +30,15 @@ scroller H{
 } set-gestures
 
 : viewport, ( child -- )
-    g gadget-model <viewport>
+    g model>> <viewport>
     g-> set-scroller-viewport @center frame, ;
 
 : <scroller-model> ( -- model )
     0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
 
-: x-model ( -- model ) g gadget-model model-dependencies first ;
+: x-model ( -- model ) g model>> dependencies>> first ;
 
-: y-model ( -- model ) g gadget-model model-dependencies second ;
+: y-model ( -- model ) g model>> dependencies>> second ;
 
 : new-scroller ( gadget class -- scroller )
     new-frame
@@ -46,12 +46,10 @@ scroller H{
         <scroller-model> >>model
          faint-boundary
     [
-        [
+        x-model <x-slider> g-> set-scroller-x @bottom frame,
-            x-model <x-slider> g-> set-scroller-x @bottom frame,
+        y-model <y-slider> g-> set-scroller-y @right frame,
-            y-model <y-slider> g-> set-scroller-y @right frame,
+        viewport,
-            viewport,
+    ] make-gadget ;
-        ] with-gadget
-    ] keep ;
 
 : <scroller> ( gadget -- scroller )
     scroller new-scroller ;
@@ -78,7 +76,7 @@ scroller H{
     ] keep dup scroller-value rot v+ swap scroll ;
 
 : relative-scroll-rect ( rect gadget scroller -- newrect )
-    scroller-viewport gadget-child relative-loc offset-rect ;
+    viewport>> gadget-child relative-loc offset-rect ;
 
 : find-scroller* ( gadget -- scroller )
     dup find-scroller dup [
@@ -121,13 +119,15 @@ scroller H{
 : scroll>top ( gadget -- )
     <zero-rect> swap scroll>rect ;
 
-: update-scroller ( scroller follows -- )
+GENERIC: update-scroller ( scroller follows -- )
-    {
+
-        { [ dup t eq? ] [ drop (scroll>bottom) ] }
+M: t update-scroller drop (scroll>bottom) ;
-        { [ dup rect? ] [ swap (scroll>rect) ] }
+
-        { [ dup ] [ swap (scroll>gadget) ] }
+M: gadget update-scroller swap (scroll>gadget) ;
-        [ drop dup scroller-value swap scroll ]
+
-    } cond ;
+M: rect update-scroller swap (scroll>rect) ;
+
+M: f update-scroller drop dup scroller-value swap scroll ;
 
 M: scroller layout*
     dup call-next-method

extra/ui/gadgets/sliders/sliders.factor

@@ -149,12 +149,12 @@ M: elevator layout*
 : <right-button> ( -- button )
     { 0 1 } arrow-right 1 <slide-button> ;
 
-: build-x-slider ( slider -- )
+: build-x-slider ( slider -- slider )
     [
         <left-button> @left frame,
         { 0 1 } elevator,
         <right-button> @right frame,
-    ] with-gadget ;
+    ] make-gadget ; inline
 
 : <up-button> ( -- button )
     { 1 0 } arrow-up -1 <slide-button> ;
@@ -162,12 +162,12 @@ M: elevator layout*
 : <down-button> ( -- button )
     { 1 0 } arrow-down 1 <slide-button> ;
 
-: build-y-slider ( slider -- )
+: build-y-slider ( slider -- slider )
     [
         <up-button> @top frame,
         { 1 0 } elevator,
         <down-button> @bottom frame,
-    ] with-gadget ;
+    ] make-gadget ; inline
 
 : <slider> ( range orientation -- slider )
     slider new-frame
@@ -176,10 +176,10 @@ M: elevator layout*
         32 >>line ;
 
 : <x-slider> ( range -- slider )
-    { 1 0 } <slider> dup build-x-slider ;
+    { 1 0 } <slider> build-x-slider ;
 
 : <y-slider> ( range -- slider )
-    { 0 1 } <slider> dup build-y-slider ;
+    { 0 1 } <slider> build-y-slider ;
 
 M: slider pref-dim*
     dup call-next-method

extra/ui/gadgets/slots/slots.factor

@@ -72,12 +72,10 @@ M: value-ref finish-editing
     { 0 1 } slot-editor new-track
         swap >>ref
     [
-        [
+        toolbar,
-            toolbar,
+        <source-editor> g-> set-slot-editor-text
-            <source-editor> g-> set-slot-editor-text
+        <scroller> 1 track,
-            <scroller> 1 track,
+    ] make-gadget
-        ] with-gadget
-    ] keep
     dup revert ;
 
 M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;

extra/ui/gadgets/tabs/tabs.factor

@@ -4,11 +4,11 @@
 USING: accessors kernel fry math math.vectors sequences arrays vectors assocs
        hashtables models models.range models.compose combinators
        ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs
-       ui.gadgets.incremental ui.gadgets.viewports ui.gadgets.books ;
+       ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books ;
 
 IN: ui.gadgets.tabs
 
-TUPLE: tabbed names model toggler content ;
+TUPLE: tabbed < frame names toggler content ;
 
 DEFER: (del-page)
 
@@ -48,8 +48,9 @@ DEFER: (del-page)
     [ names>> index ] 2keep (del-page) ;
 
 : <tabbed> ( assoc -- tabbed )
-    tabbed new
+    tabbed new-frame
-    [ <pile> 1 >>fill g-> (>>toggler) @left frame,
+    [ g 0 <model> >>model
-      [ keys >vector g (>>names) ]
+      <pile> 1 >>fill [ >>toggler ] keep swap @left grid-add
-      [ values 0 <model> [ <book> g-> (>>content) @center frame, ] keep ] bi
+      [ keys g swap >>names ]
-      g swap >>model redo-toggler ] build-frame ;
+      [ values g model>> <book> [ >>content ] keep swap @center grid-add ] bi
+      g redo-toggler g ] with-gadget ;

extra/ui/gadgets/tracks/tracks.factor

@@ -50,10 +50,10 @@ M: track pref-dim*
     over track-sizes push add-gadget ;
 
 : track, ( gadget constraint -- )
-    \ make-gadget get swap track-add ;
+    gadget get swap track-add ;
 
 : make-track ( quot orientation -- track )
-    <track> make-gadget ; inline
+    <track> swap make-gadget ; inline
 
 : track-remove ( gadget track -- )
     over [

extra/ui/gadgets/worlds/worlds-docs.factor

@@ -27,7 +27,7 @@ HELP: focus-path
 { $notes "This word is used to avoid sending " { $link gain-focus } " gestures to a gadget which requests focus on an unfocused top-level window, so that, for instance, a text editing caret does not appear in this case." } ;
 
 HELP: world
-{ $class-description "A gadget which appears at the top of the gadget hieararchy, and in turn may be displayed in a native window. Worlds delegate to " { $link gadget } " instances and have the following slots:"
+{ $class-description "A gadget which appears at the top of the gadget hieararchy, and in turn may be displayed in a native window. Worlds have the following slots:"
     { $list
         { { $snippet "active?" } " - if set to " { $link f } ", the world will not be drawn. This slot is set to " { $link f } " if an error is thrown while drawing the world; this prevents multiple debugger windows from being shown." }
         { { $snippet "glass" } " - a glass pane in front of the primary gadget, used to implement behaviors such as popup menus which are hidden when the mouse is clicked outside the menu." }

extra/ui/render/render-docs.factor

@@ -5,21 +5,21 @@ IN: ui.render
 HELP: gadget
 { $class-description "An object which displays itself on the screen and acts on user input gestures. Gadgets have the following slots:"
     { $list
-        { { $link gadget-pref-dim } " - a cached value for " { $link pref-dim } "; do not read or write this slot directly." }
+        { { $link "pref-dim" } " - a cached value for " { $link pref-dim } "; do not read or write this slot directly." }
-        { { $link gadget-parent } " - the gadget containing this one, or " { $link f } " if this gadget is not part of the visible gadget hierarchy." }
+        { { $link "parent" } " - the gadget containing this one, or " { $link f } " if this gadget is not part of the visible gadget hierarchy." }
-        { { $link gadget-children } " - a vector of child gadgets. Do not modify this vector directly, instead use " { $link add-gadget } ", " { $link add-gadgets } ", " { $link unparent } " or " { $link clear-gadget } "." }
+        { { $link "children" } " - a vector of child gadgets. Do not modify this vector directly, instead use " { $link add-gadget } ", " { $link add-gadgets } ", " { $link unparent } " or " { $link clear-gadget } "." }
-        { { $link gadget-orientation } " - an orientation specifier. This slot is used by layout gadgets." }
+        { { $link "orientation" } " - an orientation specifier. This slot is used by layout gadgets." }
-        { { $link gadget-layout-state } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." }
+        { { $link "layout-state" } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." }
-        { { $link gadget-visible? } " - a boolean indicating if the gadget should display and receive user input." }
+        { { $link "visible?" } " - a boolean indicating if the gadget should display and receive user input." }
-        { { $link gadget-root? } " - if set to " { $link t } ", layout changes in this gadget will not propagate to the gadget's parent." }
+        { { $link "root?" } " - if set to " { $link t } ", layout changes in this gadget will not propagate to the gadget's parent." }
-        { { $link gadget-clipped? } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
+        { { $link "clipped?" } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
-        { { $link gadget-interior } " - an object whose class implements the " { $link draw-interior } " generic word." }
+        { { $link "interior" } " - an object whose class implements the " { $link draw-interior } " generic word." }
-        { { $link gadget-boundary } " - an object whose class implements the " { $link draw-boundary } " generic word." }
+        { { $link "boundary" } " - an object whose class implements the " { $link draw-boundary } " generic word." }
-        { { $link gadget-model } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } }
+        { { $link "model" } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } }
     }
 "Gadgets subclass the " { $link rect } " class, and thus all instances have " { $snippet "loc" } " and " { $snippet "dim" } " instances holding their location and dimensions." }
 { $notes
-"Other classes may delegate to " { $link gadget } " in order to re-implement generic words such as " { $link draw-gadget* } " and " { $link user-input* } ", or to define gestures with " { $link set-gestures } "." } ;
+"Other classes may inherit from " { $link gadget } " in order to re-implement generic words such as " { $link draw-gadget* } " and " { $link user-input* } ", or to define gestures with " { $link set-gestures } "." } ;
 
 HELP: clip
 { $var-description "The current clipping rectangle." } ;

extra/ui/tools/browser/browser.factor

@@ -23,12 +23,10 @@ TUPLE: browser-gadget < track pane history ;
     { 0 1 } browser-gadget new-track
     dup init-history
     [
-        [
+        toolbar,
-            toolbar,
+        g <help-pane> g-> set-browser-gadget-pane
-            g <help-pane> g-> set-browser-gadget-pane
+        <scroller> 1 track,
-            <scroller> 1 track,
+    ] make-gadget ;
-        ] with-gadget
-    ] keep ;
 
 M: browser-gadget call-tool* show-help ;
 

extra/ui/tools/debugger/debugger.factor

@@ -23,12 +23,10 @@ TUPLE: debugger < track restarts ;
 : <debugger> ( error restarts restart-hook -- gadget )
     { 0 1 } debugger new-track
     [
-        [
+        toolbar,
-            toolbar,
+        <restart-list> g-> set-debugger-restarts
-            <restart-list> g-> set-debugger-restarts
+        swap <debugger-display> <scroller> 1 track,
-            swap <debugger-display> <scroller> 1 track,
+    ] make-gadget ;
-        ] with-gadget
-    ] keep ;
 
 M: debugger focusable-child* debugger-restarts ;
 

extra/ui/tools/deploy/deploy.factor

@@ -109,12 +109,10 @@ deploy-gadget "toolbar" f {
         swap >>vocab
         { 0 1 } >>orientation
     [
-        [
+        g vocab>> <deploy-settings>
-            g vocab>> <deploy-settings>
+        g-> set-deploy-gadget-settings gadget,
-            g-> set-deploy-gadget-settings gadget,
+        buttons,
-            buttons,
+    ] make-gadget
-        ] with-gadget
-    ] keep
     dup deploy-settings-theme
     dup com-revert ;
 

extra/ui/tools/inspector/inspector.factor

@@ -16,11 +16,9 @@ TUPLE: inspector-gadget < track object pane ;
 : <inspector-gadget> ( -- gadget )
     { 0 1 } inspector-gadget new-track
     [
-        [
+        toolbar,
-            toolbar,
+        <pane> g-> set-inspector-gadget-pane <scroller> 1 track,
-            <pane> g-> set-inspector-gadget-pane <scroller> 1 track,
+    ] make-gadget ;
-        ] with-gadget
-    ] keep ;
 
 : inspect-object ( obj inspector -- )
     [ set-inspector-gadget-object ] keep refresh ;

extra/ui/tools/listener/listener.factor

@@ -124,12 +124,10 @@ TUPLE: stack-display < track ;
     g workspace-listener
     { 0 1 } stack-display new-track
     [
-        [
+        dup <toolbar> f track,
-            dup <toolbar> f track,
+        stack>> [ [ stack. ] curry try ]
-            stack>> [ [ stack. ] curry try ]
+        t "Data stack" <labelled-pane> 1 track,
-            t "Data stack" <labelled-pane> 1 track,
+    ] make-gadget ;
-        ] with-gadget
-    ] keep ;
 
 M: stack-display tool-scroller
     find-workspace workspace-listener tool-scroller ;
@@ -174,7 +172,7 @@ M: stack-display tool-scroller
 : <listener-gadget> ( -- gadget )
     { 0 1 } listener-gadget new-track
     dup init-listener
-    [ [ listener-output, listener-input, ] with-gadget ] keep ;
+    [ listener-output, listener-input, ] make-gadget ;
 
 : listener-help ( -- ) "ui-listener" help-window ;
 

extra/ui/tools/profiler/profiler.factor

@@ -10,12 +10,10 @@ TUPLE: profiler-gadget < track pane ;
 : <profiler-gadget> ( -- gadget )
     { 0 1 } profiler-gadget new-track
     [
-        [
+        toolbar,
-            toolbar,
+        <pane> g-> set-profiler-gadget-pane
-            <pane> g-> set-profiler-gadget-pane
+        <scroller> 1 track,
-            <scroller> 1 track,
+    ] make-gadget ;
-        ] with-gadget
-    ] keep ;
 
 : with-profiler-pane ( gadget quot -- )
     >r profiler-gadget-pane r> with-pane ;

extra/ui/tools/search/search.factor

@@ -62,12 +62,10 @@ search-field H{
 : <live-search> ( string seq limited? presenter -- gadget )
     { 0 1 } live-search new-track
     [
-        [
+        <search-field> g-> set-live-search-field f track,
-            <search-field> g-> set-live-search-field f track,
+        <search-list> g-> set-live-search-list
-            <search-list> g-> set-live-search-list
+        <scroller> 1 track,
-            <scroller> 1 track,
+    ] make-gadget
-        ] with-gadget
-    ] keep
     [ live-search-field set-editor-string ] keep
     [ live-search-field end-of-document ] keep ;
 

extra/ui/tools/tools.factor

@@ -30,15 +30,13 @@ IN: ui.tools
     { 0 1 } workspace new-track
         0 <model> >>model
     [
-        [
+        <listener-gadget> g set-workspace-listener
-            <listener-gadget> g set-workspace-listener
+        <workspace-book> g set-workspace-book
-            <workspace-book> g set-workspace-book
+        <workspace-tabs> f track,
-            <workspace-tabs> f track,
+        g workspace-book 1/5 track,
-            g workspace-book 1/5 track,
+        g workspace-listener 4/5 track,
-            g workspace-listener 4/5 track,
+        toolbar,
-            toolbar,
+    ] make-gadget ;
-        ] with-gadget
-    ] keep ;
 
 : resize-workspace ( workspace -- )
     dup track-sizes over control-value zero? [

extra/ui/tools/traceback/traceback.factor

@@ -27,15 +27,17 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
     { 0 1 } traceback-gadget new-track
         swap >>model
     [
+        g model>>
         [
             [
-                g gadget-model <datastack-display> 1/2 track,
+                [ <datastack-display> 1/2 track, ]
-                g gadget-model <retainstack-display> 1/2 track,
+                [ <retainstack-display> 1/2 track, ]
+                bi
             ] { 1 0 } make-track 1/3 track,
-            g gadget-model <callstack-display> 2/3 track,
+        ]
-            toolbar,
+        [ <callstack-display> 2/3 track, ] bi
-        ] with-gadget
+        toolbar,
-    ] keep ;
+    ] make-gadget ;
 
 : <namestack-display> ( model -- gadget )
     [ [ continuation-name namestack. ] when* ]

extra/ui/tools/walker/walker.factor

@@ -60,13 +60,12 @@ M: walker-gadget focusable-child*
         swap >>thread
         swap >>continuation
         swap >>status
+        dup continuation>> <traceback-gadget> >>traceback
     [
-        [
+        toolbar,
-            toolbar,
+        g status>> self <thread-status> f track,
-            g status>> self <thread-status> f track,
+        g traceback>> 1 track,
-            g continuation>> <traceback-gadget> 1 track,
+    ] make-gadget ;
-        ] with-gadget
-    ] keep ;
 
 : walker-help ( -- ) "ui-walker" help-window ;
 

extra/ui/ui-docs.factor

@@ -74,14 +74,14 @@ ARTICLE: "ui-glossary" "UI glossary"
             }
         }
     }
-    { "gadget" { "a graphical element which responds to user input. Gadgets are tuples which (directly or indirectly) delegate to " { $link gadget } " instances." } }
+    { "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" } }
     { "point" "a pair of integers denoting a pixel location on screen" }
 } ;
 
 ARTICLE: "building-ui" "Building user interfaces"
-"A gadget is a graphical element which responds to user input. Gadgets are implemented as tuples which (directly or indirectly) delegate to instances of " { $link gadget } ", which in turn delegates to " { $link rect } "."
+"A gadget is a graphical element which responds to user input. Gadgets are implemented as tuples which (directly or indirectly) inherit from " { $link gadget } ", which in turn inherits from " { $link rect } "."
 { $subsection gadget }
 "Gadgets are arranged in a hierarchy, and all visible gadgets except for instances of " { $link world } " are contained in a parent gadget, stored in the " { $link gadget-parent } " slot."
 { $subsection "ui-geometry" }
@@ -104,7 +104,7 @@ ARTICLE: "gadgets" "Pre-made UI gadgets"
 { $subsection "ui.gadgets.lists" } ;
 
 ARTICLE: "ui-geometry" "Gadget geometry"
-"Instances of " { $link gadget } " (and thus all gadgets) delegate to rectangles which specify the gadget's bounding box:"
+"The " { $link gadget } " class inherits from the " { $link rect } " class, and thus all gadgets have a bounding box:"
 { $subsection rect }
 "Rectangles can be taken apart:"
 { $subsection rect-loc }
@@ -235,7 +235,7 @@ $nl
 $nl
 "Gadget construction combinators whose names are prefixed with " { $snippet "make-" } " construct new gadgets and push them on the stack. The primitive combinator used to define all combinators of this form:"
 { $subsection make-gadget }
-"Words such as " { $link gadget, } " and " { $link track, } " access the gadget through the " { $link make-gadget } " variable."
+"Words such as " { $link gadget, } " and " { $link track, } " access the gadget through the " { $link gadget } " variable."
 $nl
 "A combinator which stores a gadget in the " { $link gadget } " variable:"
 { $subsection with-gadget }
@@ -261,7 +261,7 @@ ARTICLE: "ui-layout-impl" "Implementing layout gadgets"
 { $subsection max-dim }
 { $subsection dim-sum }
 { $warning
-    "When implementing the " { $link layout* } " generic word for a gadget which intends to delegate to another layout, the " { $link children-on } " word might have to be re-implemented as well."
+    "When implementing the " { $link layout* } " generic word for a gadget which inherits from another layout, the " { $link children-on } " word might have to be re-implemented as well."
     $nl
     "For example, suppose you want a " { $link grid } " layout which also displays a popup gadget on top. The implementation of " { $link children-on } " for the " { $link grid } " class determines which children of the grid are visible at one time, and this will never include your popup, so it will not be rendered, nor will it respond to gestures. The solution is to re-implement " { $link children-on } " on your class."
 } ;

extra/ui/x11/x11.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2005, 2007 Eduardo Cavazos and Slava Pestov
+! Copyright (C) 2005, 2008 Eduardo Cavazos and Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types arrays ui ui.gadgets ui.gestures
+USING: accessors alien alien.c-types arrays ui ui.gadgets
-ui.backend ui.clipboards ui.gadgets.worlds ui.render assocs
+ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render
-kernel math namespaces opengl sequences strings x11.xlib
+assocs kernel math namespaces opengl sequences strings x11.xlib
 x11.events x11.xim x11.glx x11.clipboard x11.constants
 x11.windows io.encodings.string io.encodings.ascii
 io.encodings.utf8 combinators debugger command-line qualified

extra/update/backup/backup.factor

@@ -1,5 +1,5 @@
 
-USING: namespaces io.files bootstrap.image builder.util ;
+USING: namespaces debugger io.files bootstrap.image builder.util ;
 
 IN: update.backup
 
@@ -20,6 +20,9 @@ IN: update.backup
 
 : backup ( -- )
   datestamp "datestamp" set
-  backup-boot-image
+    [
-  backup-image
+      backup-boot-image
-  backup-vm ;
+      backup-image
+      backup-vm
+    ]
+  try ;

extra/wordtimer/authors.txt

@@ -0,0 +1 @@
+Phil Dawes

extra/wordtimer/summary.txt

@@ -0,0 +1 @@
+Microsecond precision code timer/profiler.

extra/wordtimer/wordtimer-docs.factor

@@ -0,0 +1,41 @@
+USING: help.syntax help.markup kernel prettyprint sequences ;
+IN: wordtimer
+
+HELP: reset-word-timer
+{ $description "resets the global wordtimes datastructure. Must be called before calling any word-timer annotated code"
+} ;
+
+HELP: add-timer
+{ $values { "word" "a word" } } 
+{ $description "annotates the word with timing code which stores timing information globally. You can then view the info with print-word-timings"
+} ;
+
+HELP: add-timers
+{ $values { "vocab" "a string" } } 
+{ $description "annotates all the words in the vocab with timer code. After profiling you can remove the annotations with reset-vocab"
+} ;
+
+
+HELP: reset-vocab
+{ $values { "vocab" "a string" } } 
+{ $description "removes the annotations from all the words in the vocab"
+} ;
+
+HELP: print-word-timings
+{ $description "Displays the timing information for each word-timer annotated word. Columns are: total time taken in microseconds, number of invocations, wordname"
+} ;
+
+HELP: correct-for-timing-overhead
+{ $description "attempts to correct the timings to take into account the overhead of the timing function. This is pretty error-prone but can be handy when you're timing words that only take a handful of milliseconds but are called a lot" } ;
+
+HELP: profile-vocab
+{ $values { "vocabspec" "string name of a vocab" }
+          { "quot" "a quotation to run" } }
+{ $description "Annotates the words in the vocab with timing code then runs the quotation. Finally resets the words and prints the timings information."
+} ;
+
+    
+ARTICLE: "wordtimer" "Word Timer"
+"The " { $vocab-link "wordtimer" } " vocabulary measures accumulated execution time for words. If you just want to profile the accumulated time taken by all words in a vocab you can use " { $vocab-link "profile-vocab" } ". If you need more fine grained control then do the following: First annotate individual words with the " { $link add-timer } " word or whole vocabularies with " { $link add-timers } ". Then reset the clock with " { $link reset-word-timer } " and execute your code. Finally you can view the timings with " { $link print-word-timings } ". If you have functions that are quick and called often you may want to " { $link correct-for-timing-overhead } ". To remove all the annotations in the vocab you can use " { $link reset-vocab } ". Alternatively if you just want to time the contents of a vocabulary you can use profile-vocab." ;
+    
+ABOUT: "wordtimer"

extra/wordtimer/wordtimer-tests.factor

@@ -0,0 +1,10 @@
+USING: tools.test wordtimer math kernel tools.annotations prettyprint ;
+IN: wordtimer.tests
+
+: testfn ( a b c d -- a+b c+d )
+  + [ + ] dip ;
+    
+[ 3 7 ]
+[ reset-word-timer
+  \ testfn [ reset ] [ add-timer ] bi
+  1 2 3 4 testfn ] unit-test

extra/wordtimer/wordtimer.factor

@@ -0,0 +1,81 @@
+USING: kernel sequences namespaces math assocs words arrays tools.annotations vocabs sorting prettyprint io micros math.statistics accessors ;
+IN: wordtimer
+
+SYMBOL: *wordtimes*
+SYMBOL: *calling*
+
+: reset-word-timer ( -- ) 
+  H{ } clone *wordtimes* set-global
+  H{ } clone *calling* set-global ;
+    
+: lookup-word-time ( wordname -- utime n )
+  *wordtimes* get-global [ drop { 0 0 } ] cache first2 ;
+
+: update-times ( utime current-utime current-numinvokes -- utime' invokes' )
+  rot [ + ] curry [ 1+ ] bi* ;
+
+: register-time ( utime word -- )
+  name>>
+  [ lookup-word-time update-times 2array ] keep *wordtimes* get-global set-at ;
+
+: calling ( word -- )
+  dup *calling* get-global set-at ; inline
+
+: finished ( word -- )
+  *calling* get-global delete-at ; inline
+
+: called-recursively? ( word -- t/f )
+  *calling* get-global at ; inline
+    
+: timed-call ( quot word -- )
+  [ calling ] [ >r micro-time r> register-time ] [ finished ] tri ; inline
+
+: time-unless-recursing ( quot word -- )
+  dup called-recursively? not
+  [ timed-call ] [ drop call ] if ; inline
+    
+: (add-timer) ( word quot -- quot' )
+  [ swap time-unless-recursing ] 2curry ; 
+
+: add-timer ( word -- )
+  dup [ (add-timer) ] annotate ;
+
+: add-timers ( vocabspec -- )
+  words [ add-timer ] each ;
+
+: reset-vocab ( vocabspec -- )
+  words [ reset ] each ;
+
+: dummy-word ( -- ) ;
+
+: time-dummy-word ( -- n )
+  [ 100000 [ [ dummy-word ] micro-time , ] times ] { } make median ;
+
+: subtract-overhead ( {oldtime,n} overhead -- {newtime,n} )
+  [ first2 ] dip
+  swap [ * - ] keep 2array ;
+  
+: change-global ( variable quot -- )
+  global swap change-at ;
+
+: (correct-for-timing-overhead) ( timingshash -- timingshash )
+  time-dummy-word [ subtract-overhead ] curry assoc-map ;  
+
+: correct-for-timing-overhead ( -- )
+  *wordtimes* [ (correct-for-timing-overhead) ] change-global ;
+    
+: print-word-timings ( -- )
+  *wordtimes* get-global [ swap suffix ] { } assoc>map natural-sort reverse pprint ;
+
+
+: profile-vocab ( vocabspec quot -- )
+  "annotating vocab..." print flush
+  over [ reset-vocab ] [ add-timers ] bi
+  reset-word-timer
+  "executing quotation..." print flush
+  [ call ] micro-time >r
+  "resetting annotations..." print flush
+  reset-vocab
+  correct-for-timing-overhead
+  "total time:" write r> pprint
+  print-word-timings ;