Merge branch 'master' into modern-harvey

basis/calendar/model/model.factor

@@ -1,21 +0,0 @@
-! Copyright (C) 2008, 2010 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: calendar namespaces models threads kernel init ;
-IN: calendar.model
-
-SYMBOL: time
-
-: (time-thread) ( -- )
-    now time get set-model
-    1 seconds sleep (time-thread) ;
-
-: time-thread ( -- )
-    [
-        init-namespaces
-        (time-thread)
-    ] "Time model update" spawn drop ;
-
-[
-    f <model> time set-global
-    time-thread
-] "calendar.model" add-startup-hook

basis/calendar/model/summary.txt

@@ -1 +0,0 @@
-Timestamp model updated every second

basis/channels/remote/remote-docs.factor

@@ -43,7 +43,7 @@ HELP: publish
 }
 { $see-also <remote-channel> unpublish } ;
 
-ARTICLE: { "remote-channels" "remote-channels" } "Remote Channels"
+ARTICLE: "channels.remote" "Remote Channels"
 "Remote channels are channels that can be accessed by other Factor instances. It uses distributed concurrency to serialize and send data between channels."
 $nl
 "To start a remote node, distributed concurrency must have been started. This can be done using " { $link start-server } "."
@@ -61,4 +61,4 @@ $nl
 { $snippet "\"myhost.com\" 9001 <node> 123456 <remote-channel>\n\"hello\" over to" }
 ;
 
-ABOUT: { "remote-channels" "remote-channels" }
+ABOUT: "channels.remote"

basis/combinators/smart/smart.factor

@@ -149,7 +149,7 @@ MACRO: smart-map-reduce ( map-reduce-quots -- quot )
     [ keys ] [ [ [ ] concat-as ] [ ] map-as ] bi dup length dup '[
         [ first _ cleave ] keep
         [ @ _ cleave-curry _ spread* ]
-        [ 1 ] 2dip setup-each (each-integer)
+        1 each-from
     ] ;
 
 MACRO: smart-2reduce ( 2reduce-quots -- quot )
@@ -162,5 +162,5 @@ MACRO: smart-2map-reduce ( 2map-reduce-quots -- quot )
     [ keys ] [ [ [ ] concat-as ] [ ] map-as ] bi dup length dup '[
         [ [ first ] bi@ _ 2cleave ] 2keep
         [ @ _ [ cleave-curry ] [ cleave-curry ] bi _ spread* ]
-        [ 1 ] 3dip (2each) (each-integer)
+        1 2each-from
     ] ;

basis/compiler/errors/errors.factor

@@ -39,10 +39,10 @@ T{ error-type-holder
 } define-error-type
 
 : <compiler-error> ( error word -- compiler-error )
-    \ compiler-error <definition-error> ;
+    compiler-error new-source-file-error ;
 
 : <linkage-error> ( error word -- linkage-error )
-    \ linkage-error <definition-error> ;
+    linkage-error new-source-file-error ;
 
 : set-linkage-error ( name message word class -- )
     '[ _ boa ] dip <linkage-error> dup asset>> linkage-errors get set-at ; inline

basis/grouping/grouping.factor

@@ -76,7 +76,7 @@ PRIVATE>
         2 = [
             [ first2-unsafe ] dip call
         ] [
-            [ [ first-unsafe 1 ] [ (setup-each) ] bi ] dip
+            [ [ first-unsafe 1 ] [ setup-each ] bi ] dip
             '[ @ _ keep swap ] (all-integers?) nip
         ] if
     ] if ; inline

basis/help/handbook/handbook.factor

@@ -5,7 +5,7 @@ math system strings sbufs vectors byte-arrays quotations
 io.streams.byte-array classes.builtin parser lexer
 classes.predicate classes.union classes.intersection
 classes.singleton classes.tuple help.vocabs math.parser
-accessors definitions sets ;
+accessors definitions sets lists ;
 IN: help.handbook
 
 ARTICLE: "conventions" "Conventions"

basis/help/lint/lint.factor

@@ -28,7 +28,7 @@ M: help-lint-error error-type drop +help-lint-failure+ ;
 <PRIVATE
 
 : <help-lint-error> ( error topic -- help-lint-error )
-    \ help-lint-error <definition-error> ;
+    help-lint-error new-source-file-error ;
 
 PRIVATE>
 

basis/help/markup/markup.factor

@@ -77,7 +77,7 @@ ALIAS: $slot $snippet
     [ strong-style get print-element* ] ($span) ;
 
 : $url ( children -- )
-    first dup >url [
+    [ ?second ] [ first ] bi [ or ] keep >url [
         dup present href associate url-style get assoc-union
         [ write-object ] with-style
     ] ($span) ;

basis/math/polynomials/polynomials.factor

@@ -36,7 +36,7 @@ ALIAS: n*p n*v
     [ drop length [ <iota> ] keep ]
     [ nip <reversed> ]
     [ drop ] 2tri
-    '[ _ _ <slice> _ v* sum ] map reverse! ;
+    '[ _ _ <slice> _ v. ] map reverse! ;
 
 : p-sq ( p -- p^2 ) dup p* ; inline
 

basis/models/delay/delay-docs.factor

@@ -28,11 +28,11 @@ HELP: <delay>
 { $description "Creates a new instance of " { $link delay } ". The timeout must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." }
 { $examples "See the example in the documentation for " { $link delay } "." } ;
 
-ARTICLE: "models-delay" "Delay models"
+ARTICLE: "models.delay" "Delay models"
 "Delay models are used to implement delayed updating of gadgets in response to user input."
 { $subsections
     delay
     <delay>
 } ;
 
-ABOUT: "models-delay"
+ABOUT: "models.delay"

basis/models/models-docs.factor

@@ -156,8 +156,8 @@ $nl
     "models-impl"
     "models.arrow"
     "models.product"
-    "models-range"
+    "models.range"
-    "models-delay"
+    "models.delay"
 } ;
 
 ARTICLE: "models-impl" "Implementing models"

basis/models/product/product-docs.factor

@@ -5,7 +5,7 @@ IN: models.product
 HELP: product
 { $class-description "Product model values are computed by collecting the values from a sequence of underlying models into a new sequence. Product models are automatically updated when underlying models change. Product models are constructed by " { $link <product> } "."
 $nl
-"A product model whose children are all " { $link "models-range" } " conforms to the " { $link "range-model-protocol" } " and represents a point in n-dimensional space which is bounded by a rectangle." }
+"A product model whose children are all " { $link "models.range" } " conforms to the " { $link "range-model-protocol" } " and represents a point in n-dimensional space which is bounded by a rectangle." }
 { $examples
     "The following code displays a pair of sliders, and an updating label showing their current values:"
     { $code

basis/models/range/range-docs.factor

@@ -40,7 +40,7 @@ HELP: move-by-page
 { $description "Adds a multiple of the page size to a range model's current value." }
 { $side-effects "range" } ;
 
-ARTICLE: "models-range" "Range models"
+ARTICLE: "models.range" "Range models"
 "Range models ensure their value is a real number within a fixed range."
 { $subsections
     range
@@ -63,4 +63,4 @@ ARTICLE: "range-model-protocol" "Range model protocol"
     set-range-max-value
 } ;
 
-ABOUT: "models-range"
+ABOUT: "models.range"

basis/tools/deprecation/deprecation.factor

@@ -12,9 +12,9 @@ SYMBOL: deprecation-notes
 
 deprecation-notes [ H{ } clone ] initialize
 
-TUPLE: deprecation-note-error < source-file-error ;
+TUPLE: deprecation-note < source-file-error ;
 
-M: deprecation-note-error error-type drop +deprecation-note+ ;
+M: deprecation-note error-type drop +deprecation-note+ ;
 
 TUPLE: deprecated-usages asset usages ;
 
@@ -31,13 +31,13 @@ T{ error-type-holder
     { fatal? f }
 } define-error-type
 
-: <deprecation-note-error> ( error word -- deprecation-note )
+: <deprecation-note> ( error word -- deprecation-note )
-    \ deprecation-note-error <definition-error> ;
+    deprecation-note new-source-file-error ;
 
-: deprecation-note ( word usages -- )
+: store-deprecation-note ( word usages -- )
-    [ deprecated-usages boa ]
+    over [ deprecated-usages boa ] dip
-    [ drop <deprecation-note-error> ]
+    [ <deprecation-note> ]
-    [ drop deprecation-notes get-global set-at ] 2tri ;
+    [ deprecation-notes get-global set-at ] bi ;
 
 : clear-deprecation-note ( word -- )
     deprecation-notes get-global delete-at ;
@@ -47,7 +47,8 @@ T{ error-type-holder
         dup { [ "forgotten" word-prop ] [ deprecated? ] } 1||
         [ clear-deprecation-note ] [
             dup def>> uses [ deprecated? ] filter
-            [ clear-deprecation-note ] [ >array deprecation-note ] if-empty
+            [ clear-deprecation-note ]
+            [ store-deprecation-note ] if-empty
         ] if
     ] [ drop ] if ;
 
@@ -74,7 +75,7 @@ M: deprecation-observer definitions-changed
     [ [ check-deprecations ] each ]
     [ drop initialize-deprecation-notes ] if ;
 
-[ \ deprecation-observer add-definition-observer ]
+[ deprecation-observer add-definition-observer ]
 "tools.deprecation" add-startup-hook
 
 initialize-deprecation-notes

basis/tools/errors/errors-docs.factor

@@ -33,7 +33,7 @@ HELP: :linkage
 { :errors :linkage } related-words
 
 HELP: errors.
-{ $values { "errors" "a sequence of " { $link source-file-error } " instances" } }
+{ $values { "errors" { $sequence source-file-error } } }
 { $description "Prints a list of errors, grouped by source file." } ;
 
 ARTICLE: "tools.errors" "Batch error reporting"

basis/tools/errors/errors.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs debugger io kernel sequences source-files.errors
+USING: accessors assocs command-line compiler.errors debugger
-summary accessors continuations make math.parser io.styles namespaces
+io kernel namespaces sequences source-files.errors
-compiler.errors prettyprint source-files.errors.debugger command-line ;
+source-files.errors.debugger summary ;
 IN: tools.errors
 
 ! Tools for source-files.errors. Used by tools.tests and others

basis/tools/errors/model/model.factor

@@ -1,18 +0,0 @@
-! Copyright (C) 2009, 2010 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: models source-files.errors namespaces models.delay init
-kernel calendar ;
-IN: tools.errors.model
-
-SYMBOLS: (error-list-model) error-list-model ;
-
-SINGLETON: updater
-
-M: updater errors-changed
-    drop f (error-list-model) get-global set-model ;
-
-[
-    f <model> (error-list-model) set-global
-    (error-list-model) get-global 100 milliseconds <delay> error-list-model set-global
-    updater add-error-observer
-] "tools.errors.model" add-startup-hook

basis/ui/backend/cocoa/views/views.factor

@@ -2,13 +2,12 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types alien.data alien.strings
 arrays assocs cocoa cocoa.application cocoa.classes
-cocoa.pasteboard cocoa.runtime cocoa.subclassing cocoa.touchbar
+cocoa.pasteboard cocoa.runtime cocoa.subclassing cocoa.types
-cocoa.types cocoa.views combinators core-foundation.strings
+cocoa.views combinators core-foundation.strings core-graphics
-core-graphics core-graphics.types core-text io.encodings.utf8
+core-graphics.types core-text io.encodings.utf8 kernel literals
-kernel literals locals math math.rectangles namespaces opengl
+locals math math.rectangles namespaces opengl sequences threads
-sequences threads ui.gadgets ui.gadgets.private
+ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures
-ui.gadgets.worlds ui.gestures ui.private ui.tools.listener
+ui.private ;
-vocabs.refresh ;
 IN: ui.backend.cocoa.views
 
 : send-mouse-moved ( view event -- )

basis/ui/backend/windows/windows.factor

@@ -506,7 +506,7 @@ SYMBOL: wm-handlers
 
 H{ } clone wm-handlers set-global
 
-: add-wm-handler ( quot wm -- )
+: add-wm-handler ( quot: ( hWnd Msg wParam lParam -- LRESULT ) wm -- )
     dup array?
     [ [ execute( -- wm ) add-wm-handler ] with each ]
     [ wm-handlers get-global set-at ] if ;

basis/ui/gadgets/editors/editors.factor

@@ -13,7 +13,8 @@ IN: ui.gadgets.editors
 TUPLE: editor < line-gadget
     caret-color
     caret mark
-    focused? blink blink-timer ;
+    focused? blink blink-timer
+    default-text ;
 
 <PRIVATE
 
@@ -199,6 +200,13 @@ TUPLE: selected-line start end first? last? ;
         ] 3bi
     ] if ;
 
+: draw-default-text? ( editor -- ? )
+    { [ default-text>> ] [ model>> doc-string empty? ] } 1&& ;
+
+: draw-default-text ( editor -- )
+    [ font>> clone line-color >>foreground ]
+    [ default-text>> ] bi draw-text ;
+
 PRIVATE>
 
 M: editor draw-line ( line index editor -- )
@@ -206,13 +214,19 @@ M: editor draw-line ( line index editor -- )
     [ draw-selected-line ] [ nip draw-unselected-line ] if ;
 
 M: editor draw-gadget*
+    dup draw-default-text? [
+        [ draw-default-text ] [ draw-caret ] bi
+    ] [
         dup compute-selection selected-lines [
             [ draw-lines ] [ draw-caret ] bi
-    ] with-variable ;
+        ] with-variable
+    ] if ;
 
 M: editor pref-dim*
     ! Add some space for the caret.
-    [ font>> ] [ control-value ] bi text-dim { 1 0 } v+ ;
+    [ font>> ] keep dup draw-default-text?
+    [ default-text>> ] [ control-value ] if
+    text-dim { 1 0 } v+ ;
 
 M: editor baseline font>> font-metrics ascent>> ;
 
@@ -627,6 +641,10 @@ M: field pref-dim*
     [ [ line-gadget-width ] [ drop second ] 2bi 2array ]
     tri border-pref-dim ;
 
+M: field default-text>> editor>> default-text>> ;
+
+M: field default-text<< editor>> default-text<< ;
+
 TUPLE: model-field < field field-model ;
 
 : <model-field> ( model -- gadget )
@@ -644,48 +662,14 @@ M: model-field ungraft*
 M: model-field model-changed
     nip [ editor>> editor-string ] [ field-model>> ] bi set-model ;
 
-TUPLE: action-editor < editor default-text ;
-
-: <action-editor> ( -- editor )
-    action-editor new-editor ;
-
-<PRIVATE
-
-: draw-default-text? ( editor -- ? )
-    { [ default-text>> ] [ model>> doc-string empty? ] } 1&& ;
-
-: draw-default-text ( editor -- )
-    [ font>> clone line-color >>foreground ]
-    [ default-text>> ] bi draw-text ;
-
-PRIVATE>
-
-M: action-editor draw-gadget*
-    dup draw-default-text? [
-        [ draw-default-text ] [ draw-caret ] bi
-    ] [
-        call-next-method
-    ] if ;
-
-M: action-editor pref-dim*
-    dup draw-default-text? [
-        [ font>> ] [ default-text>> ] bi text-dim { 1 0 } v+
-    ] [
-        call-next-method
-    ] if ;
-
 TUPLE: action-field < field quot ;
 
 : <action-field> ( quot: ( string -- ) -- gadget )
-    action-field [ <action-editor> ] dip new-border
+    action-field [ <editor> ] dip new-border
         dup gadget-child >>editor
         field-theme
         swap >>quot ;
 
-M: action-field default-text>> editor>> default-text>> ;
-
-M: action-field default-text<< editor>> default-text<< ;
-
 : invoke-action-field ( field -- )
     [ editor>> editor-string ]
     [ editor>> clear-editor ]

basis/ui/gadgets/labeled/labeled-docs.factor

@@ -6,7 +6,7 @@ HELP: labeled-gadget
 { $class-description "A labeled gadget can be created by calling " { $link <labeled-gadget> } "." } ;
 
 HELP: <labeled-gadget>
-{ $values { "gadget" gadget } { "title" string } { "labeled" "a new " { $link <labeled-gadget> } } }
+{ $values { "gadget" gadget } { "title" string } { "color" "a color" } { "labeled" "a new " { $link <labeled-gadget> } } }
 { $description "Creates a new " { $link labeled-gadget } " display " { $snippet "gadget" } " with " { $snippet "title" } " on top." } ;
 
 ARTICLE: "ui.gadgets.labeled" "Labeled gadgets"
@@ -14,6 +14,7 @@ ARTICLE: "ui.gadgets.labeled" "Labeled gadgets"
 { $subsections
     labeled-gadget
     <labeled-gadget>
+    <framed-labeled-gadget>
 } ;
 
 ABOUT: "ui.gadgets.labeled"

basis/ui/gadgets/labeled/labeled.factor

@@ -1,9 +1,8 @@
 ! Copyright (C) 2006, 2009 Slava Pestov, 2015 Nicolas Pénet.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors colors.constants kernel system ui.gadgets
+USING: accessors kernel system ui.gadgets ui.gadgets.borders
-ui.gadgets.borders ui.gadgets.labels ui.gadgets.packs
+ui.gadgets.labels ui.gadgets.packs ui.gadgets.tracks
-ui.theme ui.gadgets.tracks ui.pens.gradient
+ui.pens.gradient ui.pens.solid ui.theme ;
-ui.pens.solid ui.tools.common ;
 IN: ui.gadgets.labeled
 
 TUPLE: labeled-gadget < track content color ;
@@ -43,24 +42,12 @@ M: labeled-gadget focusable-child* content>> ;
 
 PRIVATE>
 
-: <labeled> ( gadget title color -- labeled )
+: <labeled-gadget> ( gadget title color -- labeled )
-    vertical labeled-gadget new-track with-lines
+    vertical labeled-gadget new-track
     swap >>color
     add-title-bar
     swap >>content
     add-content-area ;
 
-: <framed-labeled> ( gadget title color -- labeled )
+: <framed-labeled-gadget> ( gadget title color -- labeled )
-    <labeled> labeled-border-color <solid> >>boundary ;
+    <labeled-gadget> labeled-border-color <solid> >>boundary ;
-
-: <labeled-gadget> ( gadget title -- labeled )
-    vertical labeled-gadget new-track with-lines
-    add-title-bar
-    swap [ >>content ] keep
-    vertical <track>
-    add-content
-    { 5 5 } <border>
-    content-background <solid> >>interior
-    1 track-add
-    labeled-border-color <solid> >>boundary
-    { 3 3 } <border> ;

basis/ui/gadgets/menus/menus.factor

@@ -2,10 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators kernel locals math math.rectangles
 math.vectors memoize models namespaces opengl sequences sorting
-ui.commands ui.gadgets ui.gadgets.buttons ui.gadgets.glass
+ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.buttons
-ui.gadgets.packs ui.gadgets.worlds ui.gadgets.wrappers ui.gestures
+ui.gadgets.glass ui.gadgets.packs ui.gadgets.worlds
-ui.operations ui.pens ui.pens.solid ui.theme ui.tools.common ;
+ui.gadgets.wrappers ui.gestures ui.operations ui.pens
-
+ui.pens.solid ui.theme ;
 FROM: ui.gadgets.wrappers => wrapper ;
 
 IN: ui.gadgets.menus
@@ -140,7 +140,7 @@ menu H{
 : <menu> ( gadgets -- menu )
     <menu-items> [
         { 0 3 } >>gap
-        margins
+        { 5 5 } <filled-border>
         menu-border-color <solid> >>boundary
         menu-background <solid> >>interior
         menu new-wrapper

basis/ui/gadgets/search-tables/search-tables.factor

@@ -32,8 +32,8 @@ TUPLE: search-field < track field ;
         0 >>fill
         { 5 5 } >>gap
         +baseline+ >>align
-        swap <model-field> 10 >>min-cols >>field
+        swap <model-field> 10 >>min-cols "Search" >>default-text
-        dup field>> "Search:" label-on-left 1 track-add
+        [ >>field ] keep 1 track-add
         dup <clear-button> f track-add ;
 
 M: search-field focusable-child* field>> ;
@@ -46,26 +46,6 @@ M: search-field handle-gesture
         { [ pass-to-table ] [ call-next-method ] } 2&&
     ] [ call-next-method ] if ;
 
-! A protocol with customizable slots
-SLOT-PROTOCOL: table-protocol
-renderer
-action
-hook
-font
-selection-color
-focus-border-color
-mouse-color
-column-line-color
-selection-required?
-single-click?
-selection
-min-rows
-min-cols
-max-rows
-max-cols ;
-
-CONSULT: table-protocol search-table table>> ;
-
 :: <search-table> ( values renderer quot -- gadget )
     f <model> :> search
     vertical search-table new-track

basis/ui/gadgets/sliders/sliders-docs.factor

@@ -6,7 +6,7 @@ HELP: elevator
 { $class-description "An elevator is the part of a " { $link slider } " between the up/down arrow buttons, where a " { $link thumb } " may be moved up and down." } ;
 
 HELP: slider
-{ $class-description "A slider is a control for graphically manipulating a " { $link "models-range" } "."
+{ $class-description "A slider is a control for graphically manipulating a " { $link "models.range" } "."
 $nl
 "Sliders are created by calling " { $link <slider> } "." } ;
 

basis/ui/gadgets/slots/authors.txt

@@ -1 +0,0 @@
-Slava Pestov

basis/ui/gadgets/slots/slots-tests.factor

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

basis/ui/pixel-formats/pixel-formats-tests.factor

@@ -1,14 +1,24 @@
-USING: specialized-arrays.instances.alien.c-types.int tools.test
+USING: alien.c-types literals specialized-arrays tools.test
 ui.pixel-formats ;
+SPECIALIZED-ARRAY: int
 IN: ui.pixel-formats.tests
 
 CONSTANT: attrib-table {
     { windowed { 99 } }
     { double-buffered { 7 } }
+    { samples { 100001 } }
 }
 
+SYMBOL: garbageword
+CONSTANT: garbageint 234
+
 ! pixel-format-attributes>int-array
-{ int-array{ 9 2 99 7 0 } } [
+! it should ignore garbage, even the color-bits because it's not
-    { windowed double-buffered } { 9 2 } attrib-table
+! in the table
+{ int-array{ 9 2 99 7 100001 2 0 } } [
+    {
+        windowed "garbage" $ garbageint double-buffered
+        garbageword T{ samples f 2 } T{ color-bits f 24 }
+    } { 9 2 } attrib-table
     pixel-format-attributes>int-array
 ] unit-test

basis/ui/pixel-formats/pixel-formats.factor

@@ -1,5 +1,6 @@
-USING: accessors alien.c-types alien.data assocs destructors fry
+USING: accessors alien.c-types alien.data assocs classes
-kernel math sequences specialized-arrays ui.backend ;
+combinators destructors fry kernel math sequences
+specialized-arrays ui.backend words ;
 SPECIALIZED-ARRAY: int
 IN: ui.pixel-formats
 
@@ -57,8 +58,18 @@ TUPLE: pixel-format < disposable world handle ;
 M: pixel-format dispose*
     [ (free-pixel-format) ] [ f >>handle drop ] bi ;
 
+: (pixel-format-attribute) ( attribute table -- arr/f )
+    [ dup class-of ] dip at [ swap value>> suffix ] [ drop f ] if* ;
+
+: pixel-format-attribute>array ( obj table -- arr/f )
+    {
+        { [ over pixel-format-attribute? ] [ (pixel-format-attribute) ] }
+        { [ over word? ] [ at ] }
+        [ 2drop f ]
+    } cond ;
+
 : pixel-format-attributes>int-array ( attrs perm table -- arr )
-    swapd '[ _ at ] map sift concat append
+    swapd '[ _ pixel-format-attribute>array ] map sift concat append
     ! 0 happens to work as a sentinel value for all ui backends.
     0 suffix int >c-array ;
 

basis/ui/tools/browser/popups/popups.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs colors.constants
+USING: accessors arrays assocs definitions.icons fry help
-definitions.icons fry help help.topics kernel math.rectangles
+help.topics kernel math.rectangles models.arrow namespaces
-models.arrow namespaces sequences tools.crossref ui.gadgets
+sequences tools.crossref ui.gadgets ui.gadgets.glass
-ui.gadgets.glass ui.gadgets.labeled ui.gadgets.search-tables
+ui.gadgets.labeled ui.gadgets.search-tables ui.gadgets.tables
-ui.gadgets.tables ui.gadgets.wrappers ui.gestures ui.images
+ui.gadgets.wrappers ui.gestures ui.images ui.operations ui.theme
-ui.operations ui.pens.solid ui.theme ui.theme.images ;
+ui.tools.common ;
 FROM: ui.gadgets.wrappers => wrapper ;
 IN: ui.tools.browser.popups
 
@@ -22,18 +22,18 @@ TUPLE: links-popup < wrapper ;
     '[
         @ sort-articles
         [ dup article-title ] { } map>assoc
-    ] <arrow> link-renderer [ second ] <search-table>
+    ] <arrow> link-renderer [ second ] <search-table> dup table>>
         [ invoke-primary-operation ] >>action
         [ hide-glass ] >>hook
         t >>selection-required?
         10 >>min-rows
         10 >>max-rows
         30 >>min-cols
-        30 >>max-cols ;
+        30 >>max-cols drop ;
 
 : <links-popup> ( model quot title -- gadget )
-    [ <links-table> content-background <solid> >>interior ] dip
+    [ <links-table> white-interior ] dip
-    popup-color <labeled> links-popup new-wrapper ;
+    popup-color <framed-labeled-gadget> links-popup new-wrapper ;
 
 links-popup H{
     { T{ key-down f f "ESC" } [ hide-glass ] }

basis/ui/tools/common/common.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors classes combinators.short-circuit kernel ui.gadgets
+USING: accessors classes combinators.short-circuit kernel ui
-ui.gadgets.borders ui.gadgets.scrollers ui.gadgets.tracks
+ui.gadgets ui.gadgets.borders ui.gadgets.scrollers
-ui.pens.solid ui.theme words ;
+ui.gadgets.tracks ui.pens.solid ui.theme words ;
+
 IN: ui.tools.common
 
 : set-tool-dim ( class dim -- )
@@ -18,8 +19,11 @@ M: tool pref-dim*
 
 M: tool layout*
     [ call-next-method ]
-    [ [ class-of ] [ dim>> ] bi set-tool-dim ]
+    [
-    bi ;
+        dup fullscreen? [ drop ] [
+            [ class-of ] [ dim>> ] bi set-tool-dim
+        ] if
+    ] bi ;
 
 SLOT: scroller
 

basis/ui/tools/deploy/deploy.factor

@@ -1,11 +1,12 @@
 ! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: colors kernel models tools.deploy.config
+USING: accessors assocs fry kernel models models.mapping
-tools.deploy.config.editor tools.deploy vocabs namespaces
+namespaces sequences tools.deploy tools.deploy.config
-models.mapping sequences system accessors fry ui.gadgets ui.render
+tools.deploy.config.editor ui ui.commands ui.gadgets
-ui.gadgets.packs ui.gadgets.labels ui.gadgets.editors ui.gadgets.borders ui.gadgets.buttons ui.gadgets.toolbar ui.gestures ui.commands assocs
+ui.gadgets.borders ui.gadgets.buttons ui.gadgets.editors
-ui.gadgets.tracks ui ui.tools.listener ui.tools.browser
+ui.gadgets.labels ui.gadgets.packs ui.gadgets.toolbar
-ui.tools.common ui.gadgets.worlds ;
+ui.gadgets.worlds ui.gestures ui.tools.browser ui.tools.common
+ui.tools.listener vocabs ;
 IN: ui.tools.deploy
 
 TUPLE: deploy-gadget < pack vocab settings ;

basis/ui/tools/error-list/error-list.factor

@@ -1,17 +1,17 @@
 ! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays sequences sorting assocs colors.constants fry
+USING: accessors arrays assocs calendar colors.constants
-combinators combinators.smart combinators.short-circuit editors make
+combinators combinators.smart compiler.errors debugger editors
-memoize compiler.units fonts kernel io.pathnames prettyprint
+fry init io.pathnames kernel locals math.parser memoize models
-source-files.errors source-files.errors.debugger math.parser init math.order
+models.arrow models.arrow.smart models.delay models.mapping
-models models.arrow models.arrow.smart models.search models.mapping debugger
+models.search namespaces prettyprint sequences sorting
-namespaces summary locals ui ui.commands ui.gadgets ui.gadgets.panes
+source-files.errors source-files.errors.debugger summary ui
-ui.gadgets.tables ui.gadgets.labeled ui.gadgets.tracks ui.gestures
+ui.commands ui.gadgets ui.gadgets.buttons ui.gadgets.labeled
-ui.operations ui.tools.browser ui.tools.common ui.gadgets.scrollers
+ui.gadgets.labels ui.gadgets.packs ui.gadgets.panes
-ui.tools.inspector ui.gadgets.buttons ui.gadgets.borders ui.gadgets.labels
+ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.tables
-ui.gadgets.packs ui.theme ui.gadgets.toolbar ui.gadgets.status-bar
+ui.gadgets.toolbar ui.gadgets.tracks ui.gestures ui.images
-ui.baseline-alignment ui.images
+ui.operations ui.theme ui.tools.browser ui.tools.common
-compiler.errors tools.errors tools.errors.model ;
+ui.tools.inspector ;
 IN: ui.tools.error-list
 
 CONSTANT: source-file-icon
@@ -156,7 +156,7 @@ error-display "toolbar" f {
     [ swap '[ error-type _ at ] filter ] <smart-arrow> ;
 
 :: <error-list-gadget> ( model -- gadget )
-    vertical \ error-list-gadget new-track
+    vertical error-list-gadget new-track
         <error-toggle> [ >>error-toggle ] [ >>visible-errors ] bi*
         dup visible-errors>> model <error-model> >>model
         f <model> >>source-file
@@ -168,16 +168,23 @@ error-display "toolbar" f {
     error-list vertical <track> with-lines
         error-list <error-list-toolbar> f track-add
         error-list source-file-table>> margins <scroller> white-interior
-        "Source files" source-files-color <labeled> 1/4 track-add
+        "Source files" source-files-color <labeled-gadget> 1/4 track-add
         error-list error-table>> margins <scroller> white-interior
-        "Errors" errors-color <labeled> 1/4 track-add
+        "Errors" errors-color <labeled-gadget> 1/4 track-add
         error-list error-display>>
-        "Details" details-color <labeled> 1/2 track-add
+        "Details" details-color <labeled-gadget> 1/2 track-add
     1 track-add ;
 
 M: error-list-gadget focusable-child*
     source-file-table>> ;
 
+SYMBOLS: error-list-model ;
+
+SINGLETON: error-list-updater
+
+M: error-list-updater errors-changed
+    drop f error-list-model get-global model>> set-model ;
+
 : error-list-help ( -- ) "ui.tools.error-list" com-browse ;
 
 \ error-list-help H{ { +nullary+ t } } define-command
@@ -186,14 +193,17 @@ M: error-list-gadget focusable-child*
     { T{ key-down f f "F1" } error-list-help }
 } define-command-map
 
-MEMO: get-error-list-gadget ( -- gadget )
+: error-list-window ( -- )
     error-list-model get-global [ drop all-errors ] <arrow>
-    <error-list-gadget> ;
+    <error-list-gadget> "Errors" open-status-window ;
-
-[ \ get-error-list-gadget reset-memoized ] "ui.tools.error-list" add-startup-hook
 
 : show-error-list ( -- )
-    [ get-error-list-gadget eq? ] find-window
+    [ error-list-gadget? ] find-window
-    [ raise-window ] [ get-error-list-gadget "Errors" open-status-window ] if* ;
+    [ raise-window ] [ error-list-window ] if* ;
 
 \ show-error-list H{ { +nullary+ t } } define-command
+
+[
+    f <model> 100 milliseconds <delay> error-list-model set-global
+    error-list-updater add-error-observer
+] "ui.tools.error-list" add-startup-hook

basis/ui/tools/inspector/inspector-docs.factor

@@ -1,5 +1,5 @@
-USING: help.markup help.syntax ui.commands ui.gadgets.slots
+USING: help.markup help.syntax ui.commands
-ui.gadgets.panes ui.gadgets.editors kernel ;
+ui.gadgets.panes ui.gadgets.editors ui.tools.inspector.slots kernel ;
 IN: ui.tools.inspector
 
 ARTICLE: "ui-inspector-edit" "Editing slot values in the inspector"

basis/ui/tools/inspector/inspector.factor

@@ -2,13 +2,13 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs classes combinators fonts fry
 hashtables inspector io io.styles kernel math.vectors mirrors
-models models.arrow namespaces prettyprint refs sequences
+models models.arrow namespaces prettyprint sequences sorting ui
-sorting ui ui.commands ui.gadgets ui.gadgets.labeled
+ui.commands ui.gadgets ui.gadgets.labeled ui.gadgets.panes
-ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.slots
+ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.tables
-ui.gadgets.status-bar ui.gadgets.tables
 ui.gadgets.tables.private ui.gadgets.toolbar ui.gadgets.tracks
-ui.gadgets.worlds ui.gestures ui.operations ui.theme
+ui.gestures ui.operations ui.theme ui.tools.browser
-ui.tools.browser ui.tools.common ;
+ui.tools.common ui.tools.inspector.slots ;
+
 IN: ui.tools.inspector
 
 TUPLE: inspector-gadget < tool table ;
@@ -100,8 +100,10 @@ M: inspector-table compute-column-widths
         add-toolbar
         swap >>model
         dup model>> <inspector-table> >>table
-        dup model>> <summary-gadget> margins white-interior "Object" object-color <labeled> f track-add
+        dup model>> <summary-gadget> margins white-interior
-        dup table>> <scroller> margins white-interior "Contents" contents-color <labeled> 1 track-add ;
+        "Object" object-color <labeled-gadget> f track-add
+        dup table>> <scroller> margins white-interior
+        "Contents" contents-color <labeled-gadget> 1 track-add ;
 
 M: inspector-gadget focusable-child*
     table>> ;
@@ -114,15 +116,6 @@ M: inspector-gadget focusable-child*
 
 \ com-push H{ { +listener+ t } } define-command
 
-: slot-editor-window ( close-hook update-hook assoc key key-string -- )
-    [ <value-ref> <slot-editor> ]
-    [
-        <world-attributes>
-            swap "Slot editor: " prepend >>title
-            [ { dialog-window } append ] change-window-controls
-    ] bi*
-    open-status-window ;
-
 : com-edit-slot ( inspector -- )
     [ close-window ] swap
     [ '[ _ com-refresh ] ]

basis/ui/tools/inspector/slots/slots-tests.factor

@@ -0,0 +1,6 @@
+USING: assocs tools.test ui.tools.inspector.slots refs ;
+
+{ t } [
+    [ ] [ ] { { 1 1 } { 2 2 } { 3 3 } } 2 <value-ref>
+    <slot-editor> slot-editor?
+] unit-test

basis/ui/tools/inspector/slots/slots.factor

@@ -2,9 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors eval kernel math.vectors parser prettyprint
 refs sequences ui.commands ui.gadgets ui.gadgets.editors
-ui.gadgets.scrollers ui.gadgets.toolbar ui.gadgets.tracks
+ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.toolbar
-ui.gestures ui.tools.common ;
+ui.gadgets.tracks ui.gadgets.worlds ui.gestures ui.tools.common
-IN: ui.gadgets.slots
+;
+IN: ui.tools.inspector.slots
 
 TUPLE: slot-editor < track ref close-hook update-hook text ;
 
@@ -55,14 +56,14 @@ TUPLE: slot-editor < track ref close-hook update-hook text ;
 } define-command
 
 : <slot-editor> ( close-hook update-hook ref -- gadget )
-    vertical slot-editor new-track
+    vertical slot-editor new-track with-lines
         swap >>ref
         swap >>update-hook
         swap >>close-hook
         add-toolbar
         <source-editor> >>text
-        dup text>> margins <scroller> 1 track-add
+        dup text>> margins <scroller> white-interior 1 track-add
-        dup revert white-interior ;
+        dup revert ;
 
 M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
 
@@ -75,3 +76,12 @@ slot-editor "toolbar" f {
     { f delete }
     { T{ key-down f f "ESC" } close }
 } define-command-map
+
+: slot-editor-window ( close-hook update-hook assoc key key-string -- )
+    [ <value-ref> <slot-editor> ]
+    [
+        <world-attributes>
+            swap "Slot editor: " prepend >>title
+            [ { dialog-window } append ] change-window-controls
+    ] bi*
+    open-status-window ;

basis/ui/tools/listener/completion/completion.factor

@@ -150,13 +150,13 @@ GENERIC#: accept-completion-hook 1 ( item popup -- )
         dup '[ _ accept-completion ] >>action ;
 
 : <completion-scroller> ( completion-popup -- scroller )
-    table>> <scroller> content-background <solid> >>interior ;
+    table>> <scroller> white-interior ;
 
 : <completion-popup> ( interactor completion-mode -- popup )
     [ vertical completion-popup new-track ] 2dip
     [ [ >>interactor ] [ >>completion-mode ] bi* ] [ <completion-table> >>table ] 2bi
     dup [ <completion-scroller> ] [ completion-mode>> completion-banner ] bi
-    completion-color <framed-labeled> 1 track-add ;
+    completion-color <framed-labeled-gadget> 1 track-add ;
 
 completion-popup H{
     { T{ key-down f f "TAB" } [ table>> row-action ] }

basis/ui/tools/listener/listener.factor

@@ -1,17 +1,18 @@
 ! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs calendar combinators
-combinators.short-circuit concurrency.flags concurrency.mailboxes
+combinators.short-circuit concurrency.flags
-continuations destructors documents documents.elements fonts fry
+concurrency.mailboxes continuations destructors documents
-hashtables help help.markup help.tips io io.styles kernel lexer
+documents.elements fonts fry hashtables help help.markup
-listener literals locals math math.vectors models models.arrow
+help.tips io io.styles kernel lexer listener literals locals
-models.delay namespaces parser prettyprint sequences
+math math.vectors models models.arrow models.delay namespaces
-source-files.errors strings system threads tools.errors.model ui
+parser prettyprint sequences source-files.errors strings system
-ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.glass
+threads ui ui.commands ui.gadgets ui.gadgets.editors
-ui.gadgets.labeled ui.gadgets.panes ui.gadgets.scrollers
+ui.gadgets.glass ui.gadgets.labeled ui.gadgets.panes
-ui.gadgets.status-bar ui.gadgets.toolbar ui.gadgets.tracks ui.gestures
+ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.toolbar
-ui.operations ui.pens.solid ui.theme ui.tools.browser ui.tools.common
+ui.gadgets.tracks ui.gestures ui.operations ui.pens.solid
-ui.tools.debugger ui.tools.error-list ui.tools.listener.completion
+ui.theme ui.tools.browser ui.tools.common ui.tools.debugger
+ui.tools.error-list ui.tools.listener.completion
 ui.tools.listener.history ui.tools.listener.popups vocabs
 vocabs.loader vocabs.parser vocabs.refresh words ;
 IN: ui.tools.listener
@@ -347,7 +348,7 @@ M: object accept-completion-hook 2drop ;
     ] ;
 
 : frame-debugger ( debugger -- labeled )
-    "Error" debugger-color <framed-labeled> ;
+    "Error" debugger-color <framed-labeled-gadget> ;
 
 :: <debugger-popup> ( error continuation interactor -- popup )
     error
@@ -485,8 +486,9 @@ PRIVATE>
     family size make-font-style
     inter output>> make-span-stream :> ostream
     ostream inter output<<
-    inter font>> clone
+    inter [
+        clone
         family >>name
         size >>size
-    inter font<<
+    ] change-font f >>line-height drop
     ostream output-stream set ;

basis/ui/tools/traceback/traceback.factor

@@ -33,12 +33,12 @@ M: stack-entry-renderer row-value drop object>> ;
 
 : <stack-display> ( model quot title color -- gadget )
     [ '[ dup _ when ] <arrow> <stack-table> margins <scroller> white-interior ] 2dip
-    <labeled> ;
+    <labeled-gadget> ;
 
 : <callstack-display> ( model -- gadget )
     [ [ call>> callstack. ] when* ]
     <pane-control> t >>scrolls? margins <scroller> white-interior
-    "Call stack" call-stack-color <labeled> ;
+    "Call stack" call-stack-color <labeled-gadget> ;
 
 : <datastack-display> ( model -- gadget )
     [ data>> ] "Data stack" data-stack-color <stack-display> ;

basis/ui/traverse/traverse-tests.factor

@@ -1,19 +1,17 @@
-USING: accessors ui.gadgets ui.gadgets.labels namespaces make
+USING: accessors arrays compiler.units definitions kernel make
-sequences kernel math arrays tools.test io ui.gadgets.panes
+sequences tools.test ui.traverse ;
-ui.traverse definitions compiler.units ;
 IN: ui.traverse.tests
 
 M: array children>> ;
 
-GENERIC: (flatten-tree) ( node -- )
+GENERIC: flatten-tree% ( node -- )
 
-M: node (flatten-tree)
+M: node flatten-tree% children>> [ flatten-tree% ] each ;
-    children>> [ (flatten-tree) ] each ;
 
-M: object (flatten-tree) , ;
+M: object flatten-tree% , ;
 
 : flatten-tree ( seq -- newseq )
-    [ [ (flatten-tree) ] each ] { } make ;
+    [ [ flatten-tree% ] each ] { } make ;
 
 : gadgets-in-range ( frompath topath gadget -- seq )
     gadget-subtree flatten-tree ;

basis/ui/traverse/traverse.factor

@@ -1,73 +1,59 @@
 ! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces make sequences kernel math arrays io
+USING: accessors arrays combinators fry generic io kernel locals
-ui.gadgets generic combinators fry sets ;
+make math namespaces sequences sets ui.gadgets ;
 IN: ui.traverse
 
 TUPLE: node value children ;
 
 : traverse-step ( path gadget -- path' gadget' )
-    [ unclip ] dip children>> ?nth ;
+    [ unclip-slice ] dip children>> ?nth ;
 
-: make-node ( quot -- ) { } make node boa , ; inline
+: make-node ( value quot -- node ) { } make node boa ; inline
 
-: traverse-to-path ( topath gadget -- )
+:: traverse-to-path ( topath gadget -- )
-    dup not [
+    gadget [
-        2drop
+        topath empty? [
-    ] [
-        over empty? [
-            nip ,
-        ] [
             [
-                [ children>> swap first head-slice % ]
+                gadget children>> topath first head-slice %
-                [ nip ]
+                topath gadget traverse-step traverse-to-path
-                [ traverse-step traverse-to-path ]
-                2tri
             ] make-node
-        ] if
+        ] unless ,
-    ] if ;
+    ] when* ;
 
-: traverse-from-path ( frompath gadget -- )
+:: traverse-from-path ( frompath gadget -- )
-    dup not [
+    gadget [
-        2drop
+        frompath empty? [
-    ] [
-        over empty? [
-            nip ,
-        ] [
             [
-                [ traverse-step traverse-from-path ]
+                frompath gadget traverse-step traverse-from-path
-                [ nip ]
+                gadget children>> frompath first 1 + tail-slice %
-                [ children>> swap first 1 + tail-slice % ]
-                2tri
             ] make-node
-        ] if
+        ] unless ,
-    ] if ;
+    ] when* ;
 
 : traverse-pre ( frompath gadget -- )
     traverse-step traverse-from-path ;
 
-: (traverse-middle) ( frompath topath gadget -- )
-    [ first 1 + ] [ first ] [ children>> ] tri* <slice> % ;
-
 : traverse-post ( topath gadget -- )
     traverse-step traverse-to-path ;
 
-: traverse-middle ( frompath topath gadget -- )
+:: traverse-middle ( frompath topath gadget -- )
-    [
+    gadget [
-        3dup nip traverse-pre
+        frompath gadget traverse-pre
-        3dup (traverse-middle)
+        frompath first 1 + topath first gadget children>> <slice> %
-        2dup traverse-post
+        topath gadget traverse-post
-        2nip
+    ] make-node , ;
-    ] make-node ;
 
-DEFER: (gadget-subtree)
+DEFER: gadget-subtree%
 
-: traverse-child ( frompath topath gadget -- )
+:: traverse-child ( frompath topath gadget -- )
-    [ 2nip ] 3keep
+    gadget [
-    [ [ rest-slice ] 2dip traverse-step (gadget-subtree) ]
+        frompath rest-slice
-    make-node ;
+        topath gadget traverse-step
+        gadget-subtree%
+    ] make-node , ;
 
-: (gadget-subtree) ( frompath topath gadget -- )
+: gadget-subtree% ( frompath topath gadget -- )
     {
         { [ dup not ] [ 3drop ] }
         { [ pick empty? pick empty? and ] [ 2nip , ] }
@@ -78,7 +64,7 @@ DEFER: (gadget-subtree)
     } cond ;
 
 : gadget-subtree ( frompath topath gadget -- seq )
-    [ (gadget-subtree) ] { } make ;
+    [ gadget-subtree% ] { } make ;
 
 M: node gadget-text*
     [ children>> ] [ value>> ] bi gadget-seq-text ;

basis/windows/ole32/ole32.factor

@@ -17,6 +17,7 @@ TYPEDEF: GUID IID
 TYPEDEF: GUID CLSID
 
 TYPEDEF: REFGUID LPGUID
+TYPEDEF: REFGUID LPCGUID
 TYPEDEF: REFGUID REFIID
 TYPEDEF: REFGUID REFCLSID
 

basis/windows/user32/user32.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2005, 2006 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.syntax parser namespaces
+USING: accessors alien alien.c-types alien.syntax classes.struct
-kernel math windows.types generalizations math.bitwise
+generalizations kernel literals math math.bitwise namespaces
-classes.struct literals windows.kernel32 system accessors ;
+parser system windows.com.syntax windows.kernel32 windows.ole32
+windows.types ;
 IN: windows.user32
 
 ! HKL for ActivateKeyboardLayout
@@ -1880,5 +1881,69 @@ FUNCTION: BOOL UpdateWindow ( HWND hWnd )
 ! FUNCTION: wvsprintfA
 ! FUNCTION: wvsprintfW
 
+TYPEDEF: HANDLE HPOWERNOTIFY
+
+FUNCTION: HPOWERNOTIFY RegisterPowerSettingNotification ( HANDLE  hRecipient, LPCGUID PowerSettingGuid, DWORD Flags )
+FUNCTION: BOOL UnregisterPowerSettingNotification ( HPOWERNOTIFY Handle )
+
+CONSTANT: GUID_ACDC_POWER_SOURCE
+    GUID: {5d3e9a59-e9D5-4b00-a6bd-ff34ff516548}
+
+CONSTANT: GUID_BATTERY_PERCENTAGE_REMAINING
+    GUID: {a7ad8041-b45a-4cae-87a3-eecbb468a9e1}
+
+CONSTANT: GUID_CONSOLE_DISPLAY_STATE
+    GUID: {6fe69556-704a-47a0-8f24-c28d936fda47}
+
+CONSTANT: GUID_GLOBAL_USER_PRESENCE
+    GUID: {786e8a1d-b427-4344-9207-09e70bdcbea9}
+
+CONSTANT: GUID_IDLE_BACKGROUND_TASK
+    GUID: {515c31d8-f734-163d-a0fd-11a0-8c91e8f1}
+
+CONSTANT: GUID_MONITOR_POWER_ON
+    GUID: {02731015-4510-4526-99e6-e5a17ebd1aea}
+
+CONSTANT: GUID_POWER_SAVING_STATUS
+    GUID: {e00958c0-c213-4ace-ac77-fecced2eeea5}
+
+CONSTANT: GUID_POWERSCHEME_PERSONALITY
+    GUID: {245d8541-3943-4422-b025-13a7-84f679b7}
+
+CONSTANT: GUID_MIN_POWER_SAVINGS
+    GUID: {8c5e7fda-e8bf-4a96-9a85-a6e23a8c635c}
+
+CONSTANT: GUID_MAX_POWER_SAVINGS
+    GUID: {a1841308-3541-4fab-bc81-f71556f20b4a}
+
+CONSTANT: GUID_TYPICAL_POWER_SAVINGS
+    GUID: {381b4222-f694-41f0-9685-ff5bb260df2e}
+
+CONSTANT: GUID_SESSION_DISPLAY_STATUS
+    GUID: {2b84c20e-ad23-4ddf-93db-05ffbd7efca5}
+
+CONSTANT: GUID_SESSION_USER_PRESENCE
+    GUID: {3c0f4548-c03f-4c4d-b9f2-237ede686376}
+
+CONSTANT: GUID_SYSTEM_AWAYMODE
+    GUID: {98a7f580-01f7-48aa-9c0f-44352c29e5C0}
+
+! This notification fires when the Lid Close Action is
+! changed by user in the Power Manager (Control Panel).
+CONSTANT: GUID_LIDCLOSE_ACTION
+    GUID: {5ca83367-6e45-459f-a27b-476b1d01c936}
+
+! This notifies when the laptop lid is physically opened or closed.
+CONSTANT: GUID_LIDSWITCH_STATE_CHANGE
+    GUID: {ba3e0f4d-b817-4094-a2d1-d56379e6a0f3}
+
+CONSTANT: PBT_POWERSETTINGCHANGE 0x8013
+
+STRUCT: POWERBROADCAST_SETTING
+    { PowerSetting GUID  }
+    { DataLength   DWORD }
+    { Data         UCHAR }
+;
+
 : msgbox ( str -- )
     f swap "DebugMsg" MB_OK MessageBox drop ;

core/sequences/sequences.factor

@@ -388,14 +388,14 @@ PRIVATE>
 
 <PRIVATE
 
-: (setup-each) ( seq -- n quot )
+: setup-each ( seq -- n quot )
     [ length check-length ] keep [ nth-unsafe ] curry ; inline
 
-: setup-each ( seq quot -- n quot' )
+: (each) ( seq quot -- n quot' )
-    [ (setup-each) ] dip compose ; inline
+    [ setup-each ] dip compose ; inline
 
 : (each-index) ( seq quot -- n quot' )
-    [ (setup-each) [ keep ] curry ] dip compose ; inline
+    [ setup-each [ keep ] curry ] dip compose ; inline
 
 : (collect) ( quot into -- quot' )
     [ [ keep ] dip set-nth-unsafe ] 2curry ; inline
@@ -404,7 +404,7 @@ PRIVATE>
     (collect) each-integer ; inline
 
 : map-into ( seq quot into -- )
-    [ setup-each ] dip collect ; inline
+    [ (each) ] dip collect ; inline
 
 : 2nth-unsafe ( n seq1 seq2 -- elt1 elt2 )
     [ nth-unsafe ] bi-curry@ bi ; inline
@@ -418,17 +418,18 @@ PRIVATE>
 : 3nth-unsafe ( n seq1 seq2 seq3 -- elt1 elt2 elt3 )
     [ nth-unsafe ] tri-curry@ tri ; inline
 
-: (3each) ( seq1 seq2 seq3 quot -- n quot' )
+: setup-3each ( seq1 seq2 seq3 -- n quot )
-    [
     [ [ length ] tri@ min min check-length ]
-        [ [ 3nth-unsafe ] 3curry ] 3bi
+    [ [ 3nth-unsafe ] 3curry ] 3bi ; inline
-    ] dip compose ; inline
+
+: (3each) ( seq1 seq2 seq3 quot -- n quot' )
+    [ setup-3each ] dip compose ; inline
 
 : finish-find ( i seq -- i elt )
     over [ dupd nth-unsafe ] [ drop f ] if ; inline
 
 : (find) ( seq quot quot' -- i elt )
-    pick [ [ setup-each ] dip call ] dip finish-find ; inline
+    pick [ [ (each) ] dip call ] dip finish-find ; inline
 
 : (find-from) ( n seq quot quot' -- i elt )
     [ 2dup bounds-check? ] 2dip
@@ -454,10 +455,10 @@ PRIVATE>
 PRIVATE>
 
 : each ( ... seq quot: ( ... x -- ... ) -- ... )
-    setup-each each-integer ; inline
+    (each) each-integer ; inline
 
 : each-from ( ... seq quot: ( ... x -- ... ) i -- ... )
-    -rot setup-each (each-integer) ; inline
+    -rot (each) (each-integer) ; inline
 
 : reduce ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... result )
     swapd each ; inline
@@ -466,7 +467,7 @@ PRIVATE>
     [ over ] dip [ [ collect ] keep ] new-like ; inline
 
 : map-as ( ... seq quot: ( ... elt -- ... newelt ) exemplar -- ... newseq )
-    [ setup-each ] dip map-integers ; inline
+    [ (each) ] dip map-integers ; inline
 
 : map ( ... seq quot: ( ... elt -- ... newelt ) -- ... newseq )
     over map-as ; inline
@@ -544,7 +545,7 @@ PRIVATE>
     [ find-integer ] (find-index) ; inline
 
 : all? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? )
-    setup-each all-integers? ; inline
+    (each) all-integers? ; inline
 
 : push-if ( ..a elt quot: ( ..a elt -- ..b ? ) accum -- ..b )
     [ keep ] dip rot [ push ] [ 2drop ] if ; inline
@@ -1006,12 +1007,10 @@ PRIVATE>
     [ rest-slice ] [ first-unsafe ] bi ; inline
 
 : map-reduce ( ..a seq map-quot: ( ..a elt -- ..b intermediate ) reduce-quot: ( ..b prev intermediate -- ..a next ) -- ..a result )
-    [ [ dup first ] dip [ call ] keep ] dip compose
+    [ [ [ first ] keep ] dip [ dip ] keep ] dip compose 1 each-from ; inline
-    swapd 1 each-from ; inline
 
 : 2map-reduce ( ..a seq1 seq2 map-quot: ( ..a elt1 elt2 -- ..b intermediate ) reduce-quot: ( ..b prev intermediate -- ..a next ) -- ..a result )
-    [ [ 2dup [ first ] bi@ ] dip [ call ] keep ] dip compose
+    [ [ [ [ first ] bi@ ] 2keep ] dip [ 2dip ] keep ] dip compose 1 2each-from ; inline
-    [ -rot ] dip 1 2each-from ; inline
 
 <PRIVATE
 
@@ -1116,7 +1115,7 @@ PRIVATE>
 : generic-flip ( matrix -- newmatrix )
     [
         [ first-unsafe length 1 ] keep
-        [ length min ] setup-each (each-integer) <iota>
+        [ length min ] (each) (each-integer) <iota>
     ] keep
     [ [ nth-unsafe ] with { } map-as ] curry { } map-as ; inline
 
@@ -1129,7 +1128,7 @@ USE: arrays
     { array } declare
     [
         [ first-unsafe array-length 1 ] keep
-        [ array-length min ] setup-each (each-integer) <iota>
+        [ array-length min ] (each) (each-integer) <iota>
     ] keep
     [ [ { array } declare array-nth ] with { } map-as ] curry { } map-as ;
 

core/source-files/errors/errors-docs.factor

@@ -32,11 +32,11 @@ HELP: error-file
 { $values { "error" "an error" } { "file" "a file path" } }
 { $description "File in which the error occurred." } ;
 
-HELP: <definition-error>
+HELP: new-source-file-error
 { $values
-  { "error" "an error." }
+  { "error" "an error" }
-  { "definition" "an asset that contains the error." }
+  { "asset" "an asset that contains the error" }
-  { "class" "a tuple class deriving source-file-error." }
+  { "class" "a tuple class deriving source-file-error" }
   { "source-file-error" source-file-error }
 }
 { $description "Creates a new " { $link source-file-error } " instance." } ;

core/source-files/errors/errors.factor

@@ -19,6 +19,13 @@ M: source-file-error error-file [ error>> error-file ] [ path>> ] bi or ;
 M: source-file-error error-line [ error>> error-line ] [ line#>> ] bi or ;
 M: source-file-error compute-restarts error>> compute-restarts ;
 
+: new-source-file-error ( error asset class -- source-file-error )
+    new
+        swap
+        [ >>asset ]
+        [ where [ first2 [ >>path ] [ >>line# ] bi* ] when* ] bi
+        swap >>error ; inline
+
 : sort-errors ( errors -- alist )
     [ [ line#>> 0 or ] sort-with ] { } assoc-map-as sort-keys ;
 
@@ -29,13 +36,6 @@ TUPLE: error-type-holder type word plural icon quot forget-quot { fatal? initial
 
 GENERIC: error-type ( error -- type )
 
-: <definition-error> ( error definition class -- source-file-error )
-    new
-        swap
-        [ >>asset ]
-        [ where [ first2 [ >>path ] [ >>line# ] bi* ] when* ] bi
-        swap >>error ; inline
-
 SYMBOL: error-types
 
 error-types [ V{ } clone ] initialize

extra/arrays/shaped/shaped.factor

@@ -208,10 +208,10 @@ ERROR: shaped-bounds-error seq shape ;
 
 ! Inefficient
 : calculate-row-major-index ( seq shape -- i )
-    1 [ * ] accumulate nip reverse v* sum ;
+    1 [ * ] accumulate nip reverse v. ;
 
 : calculate-column-major-index ( seq shape -- i )
-    1 [ * ] accumulate nip v* sum ;
+    1 [ * ] accumulate nip v. ;
 
 : set-shaped-row-major ( obj seq shaped -- )
     shaped-bounds-check [ shape calculate-row-major-index ] [ underlying>> ] bi set-nth ;

extra/boids/boids.factor

@@ -1,13 +1,13 @@
 ! Copyright (C) 2008 Eduardo Cavazos.
 ! Copyright (C) 2011 Anton Gorenko.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays boids.simulation calendar classes kernel
+USING: accessors arrays boids.simulation calendar classes
-literals locals math math.functions math.trig models opengl
+colors.constants combinators.smart.syntax kernel locals math
-opengl.demo-support opengl.gl sequences threads ui ui.gadgets
+math.functions math.trig models opengl opengl.gl
+processing.shapes sequences threads ui ui.gadgets
 ui.gadgets.borders ui.gadgets.buttons ui.gadgets.frames
 ui.gadgets.grids ui.gadgets.labeled ui.gadgets.labels
-ui.gadgets.packs ui.gadgets.sliders ui.render
+ui.gadgets.packs ui.gadgets.sliders ui.render ui.tools.common ;
-combinators.smart.syntax ;
 QUALIFIED-WITH: models.range mr
 IN: boids
 
@@ -76,7 +76,7 @@ M: range-observer model-changed
     range-observer boa swap add-connection ;
 
 :: behavior-panel ( behavior -- gadget )
-    2 3 <frame> { 2 4 } >>gap { 0 0 } >>filled-cell
+    2 3 <frame> white-interior { 2 4 } >>gap { 0 0 } >>filled-cell
 
     "weight" <label> { 0 0 } grid-add
     behavior weight>> 100 * >fixnum 0 0 200 1 mr:<range>
@@ -93,7 +93,9 @@ M: range-observer model-changed
     dup [ deg>rad cos behavior angle-cos<< ] connect
     horizontal <slider> { 1 2 } grid-add
 
-    behavior class-of name>> <labeled-gadget> ;
+    { 5 5 } <border> white-interior
+
+    behavior class-of name>> color: gray <framed-labeled-gadget> ;
 
 :: set-population ( n boids-gadget -- )
     boids-gadget [
@@ -110,9 +112,9 @@ M: range-observer model-changed
     [ length random-boids ] change-boids drop ;
 
 :: simulation-panel ( boids-gadget -- gadget )
-    <pile> { 2 2 } >>gap
+    <pile> white-interior
 
-    2 2 <frame> { 4 4 } >>gap { 0 0 } >>filled-cell
+    2 2 <frame> { 2 4 } >>gap { 0 0 } >>filled-cell
 
     "population" <label> { 0 0 } grid-add
     initial-population 0 0 200 10 mr:<range>
@@ -124,7 +126,7 @@ M: range-observer model-changed
     dup [ boids-gadget dt<< ] connect
     horizontal <slider> { 1 1 } grid-add
 
-    add-gadget
+    { 5 5 } <border> add-gadget
 
     <shelf> { 2 2 } >>gap
     "pause" [ drop boids-gadget pause-toggle ]
@@ -132,9 +134,9 @@ M: range-observer model-changed
     "randomize" [ drop boids-gadget randomize-boids ]
     <border-button> add-gadget
 
-    add-gadget
+    { 5 5 } <border> add-gadget
 
-    "simulation" <labeled-gadget> ;
+    "simulation" color: gray <framed-labeled-gadget> ;
 
 :: create-gadgets ( -- gadgets )
     <shelf>
@@ -142,7 +144,7 @@ M: range-observer model-changed
     boids-gadget [ start-boids-thread ] keep
     add-gadget
 
-    <pile> { 2 2 } >>gap 1.0 >>fill
+    <pile> { 5 5 } >>gap 1.0 >>fill
 
     boids-gadget simulation-panel
     add-gadget
@@ -150,8 +152,7 @@ M: range-observer model-changed
     boids-gadget behaviours>>
     [ behavior-panel add-gadget ] each
 
-    add-gadget
+    { 5 5 } <border> add-gadget ;
-    { 2 2 } <border> ;
 
 MAIN-WINDOW: boids { { title "Boids" } }
     create-gadgets

extra/color-table/color-table.factor

@@ -3,7 +3,7 @@
 USING: accessors colors.constants colors.hex combinators
 combinators.smart formatting kernel literals models
 sorting.human sorting.slots strings ui ui.gadgets.scrollers
-ui.gadgets.tables ;
+ui.gadgets.search-tables ui.gadgets.tables ;
 IN: color-table
 
 ! ui.gadgets.tables demo
@@ -41,11 +41,11 @@ M: color-renderer row-value
 : <color-table> ( -- table )
     named-colors { human<=> } sort-by <model>
     color-renderer
-    <table>
+    [ ] <search-table> dup table>>
         5 >>gap
         color: dark-gray >>column-line-color
         10 >>min-rows
-        10 >>max-rows ;
+        10 >>max-rows drop ;
 
 MAIN-WINDOW: color-table-demo { { title "Colors" } { pref-dim { 500 300 } } }
     <color-table> <scroller> >>gadgets ;

extra/cpu/8080/8080-docs.factor

@@ -4,7 +4,7 @@ USING: help.markup help.syntax sequences strings cpu.8080.emulator ;
 IN: cpu.8080
 
 
-ARTICLE: { "cpu-8080" "cpu-8080" } "Intel 8080 CPU Emulator"
+ARTICLE: "cpu.8080" "Intel 8080 CPU Emulator"
 "The cpu-8080 library provides an emulator for the Intel 8080 CPU"
 " instruction set. It is complete enough to emulate some 8080"
 " based arcade games." $nl
@@ -13,4 +13,4 @@ ARTICLE: { "cpu-8080" "cpu-8080" } "Intel 8080 CPU Emulator"
 "the " { $link rom-root } " variable to be set to the path "
 "containing the ROM file's." ;
 
-ABOUT: { "cpu-8080" "cpu-8080" }
+ABOUT: "cpu.8080"

extra/euler/modeling/modeling.factor

@@ -65,7 +65,7 @@ sharp-continue ;
 
 :: project-pt-line ( p p0 p1 -- q )
     p1 p0 v- :> vt
-    p p0 v- vt v* sum
+    p p0 v- vt v.
     vt norm-sq /
     vt n*v p0 v+ ; inline
 

extra/gml/coremath/coremath.factor

@@ -191,7 +191,7 @@ GML: aNormal ( x -- y )
     } cond ;
 
 : det2 ( x y -- z )
-    { 1 0 } vshuffle double-2{ 1 -1 } v* v* sum ; inline
+    { 1 0 } vshuffle double-2{ 1 -1 } v* v. ; inline
 
 : det3 ( x y z -- w )
     [ cross ] dip v. ; inline

extra/gml/ui/ui.factor

@@ -1,11 +1,12 @@
 ! Copyright (C) 2010 Slava Pestov.
-USING: arrays accessors euler.b-rep fry gml gml.runtime gml.viewer
+USING: arrays accessors colors.constants euler.b-rep fry gml
-gml.printer io.directories io.encodings.utf8 io.files
+gml.runtime gml.viewer gml.printer io.directories
-io.pathnames io.streams.string kernel locals models namespaces
+io.encodings.utf8 io.files io.pathnames io.streams.string kernel
-sequences ui ui.gadgets ui.gadgets.buttons ui.gadgets.editors
+locals models namespaces sequences ui ui.gadgets
-ui.gadgets.frames ui.gadgets.grids ui.gadgets.labels
+ui.gadgets.buttons ui.gadgets.editors ui.gadgets.frames
-ui.gadgets.packs ui.gadgets.scrollers ui.gadgets.worlds
+ui.gadgets.grids ui.gadgets.labels ui.gadgets.packs
-ui.gadgets.tables ui.gadgets.labeled unicode ;
+ui.gadgets.scrollers ui.gadgets.worlds ui.gadgets.tables
+ui.gadgets.labeled unicode ;
 FROM: gml => gml ;
 IN: gml.ui
 
@@ -25,7 +26,8 @@ M: stack-entry-renderer row-value
         40 >>max-cols ;
 
 : <stack-display> ( model -- gadget )
-    <stack-table> <scroller> "Operand stack" <labeled-gadget> ;
+    <stack-table> <scroller> "Operand stack"
+    COLOR: dark-gray <labeled-gadget> ;
 
 TUPLE: gml-editor < frame editor gml stack-model b-rep b-rep-model ;
 
@@ -97,7 +99,7 @@ CONSTANT: example-dir "vocab:gml/examples/"
         30 >>max-rows
         40 >>min-cols
         40 >>max-cols
-    <scroller> "Editor" <labeled-gadget> ;
+    <scroller> "Editor" COLOR: dark-gray <labeled-gadget> ;
 
 : <gml-editor> ( -- gadget )
     2 3 gml-editor new-frame

extra/images/testing/testing-docs.factor

@@ -14,7 +14,7 @@ HELP: encode-test
 { $values
     { "path" "a pathname string" } { "image-class" object }
 }
-{ $description "Runs a unit-test on the image at " { $snippet "path" } " to test the image encoder. The image is decoded, encoded, and then decoded again to verify that the final decoded output matches the original decoded output. Before comparison for equality, the images are normalized in order to accomodate differences in representation between the two potential encoders." }
+{ $description "Runs a unit-test on the image at " { $snippet "path" } " to test the image encoder. The image is decoded, encoded, and then decoded again to verify that the final decoded output matches the original decoded output. Before comparison for equality, the images are normalized in order to accommodate differences in representation between the two potential encoders." }
 { $warning "This test assumes that the image decoder is working correctly. If the image fails both the " { $link decode-test } " and the " { $link encode-test } ", then you should first debug the decoder. Once the decoder is working correctly, proceed with testing the encoder." } ;
 
 HELP: images.

extra/lcd/lcd.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors calendar.format calendar.model fonts fry
+USING: accessors calendar calendar.format fonts fry grouping
-grouping kernel math models.arrow namespaces sequences ui
+kernel math sequences timers threads ui ui.gadgets
 ui.gadgets.labels ;
 IN: lcd
 
@@ -19,10 +19,19 @@ IN: lcd
 : lcd ( digit-str -- string )
     4 <iota> [ lcd-row ] with map "\n" join ;
 
-: <time-display> ( model -- gadget )
+TUPLE: time-display < label timer ;
-    [ timestamp>hms lcd ] <arrow> <label-control>
+
-    "99:99:99" lcd >>string
+: <time-display> ( -- gadget )
-    monospace-font >>font ;
+    "99:99:99" lcd time-display new-label
+        monospace-font >>font
+        dup '[ now timestamp>hms lcd _ string<< ]
+        f 1 seconds <timer> >>timer ;
+
+M: time-display graft*
+    [ timer>> start-timer yield ] [ call-next-method ] bi ;
+
+M: time-display ungraft*
+    [ timer>> stop-timer ] [ call-next-method ] bi ;
 
 MAIN-WINDOW: time-window { { title "Time" } }
-    time get <time-display> >>gadgets ;
+    <time-display> >>gadgets ;

extra/math/distances/distances.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2012 John Benediktsson
 ! See http://factorcode.org/license.txt for BSD license
 
-USING: kernel math math.functions math.statistics math.vectors
+USING: kernel math math.functions math.similarity
-sequences sequences.extras ;
+math.statistics math.vectors sequences sequences.extras ;
 
 IN: math.distances
 
@@ -22,7 +22,7 @@ IN: math.distances
     v- vabs supremum ;
 
 : cosine-distance ( a b -- n )
-    [ v* sum ] [ [ norm ] bi@ * ] 2bi / 1 swap - ;
+    cosine-similarity 1 swap - ;
 
 : canberra-distance ( a b -- n )
     [ v- vabs ] [ [ vabs ] bi@ v+ ] 2bi v/ sum ;
@@ -31,4 +31,4 @@ IN: math.distances
     [ v- ] [ v+ ] 2bi [ vabs sum ] bi@ / ;
 
 : correlation-distance ( a b -- n )
-    [ demean ] bi@ [ v* sum ] [ [ norm ] bi@ * ] 2bi / 1 swap - ;
+    [ demean ] bi@ cosine-distance ;

extra/math/similarity/similarity-tests.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2012 John Benediktsson
 ! See http://factorcode.org/license.txt for BSD license
 
-USING: math.functions math.similarity tools.test ;
+USING: math.functions math.similarity math.vectors tools.test ;
 
 IN: math.similarity.tests
 
@@ -12,7 +12,16 @@ CONSTANT: b { 0 0 0 0 2 3 1 }
 { t } [ a b euclidian-similarity 0.1336766024001917 1e-10 ~ ] unit-test
 
 { t } [ a a pearson-similarity 1.0 1e-10 ~ ] unit-test
+{ t } [ a a vneg pearson-similarity 0.0 1e-10 ~ ] unit-test
 { t } [ a b pearson-similarity 0.2376861940759582 1e-10 ~ ] unit-test
 
 { t } [ a a cosine-similarity 1.0 1e-10 ~ ] unit-test
-{ t } [ a b cosine-similarity 0.5472455591261534 1e-10 ~ ] unit-test
+{ t } [ a a vneg cosine-similarity -1.0 1e-10 ~ ] unit-test
+{ t } [ a b cosine-similarity 0.0944911182523068 1e-10 ~ ] unit-test
+
+
+{ 3/100 } [
+    { 0 0 0 10 10 } { 0 0 1 1 1 } { 0 0 0 1 2 }
+    weighted-cosine-similarity
+] unit-test
+

extra/math/similarity/similarity.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2012 John Benediktsson
 ! See http://factorcode.org/license.txt for BSD license
 
-USING: kernel math math.statistics math.vectors sequences sets ;
+USING: kernel math math.functions math.statistics math.vectors
+sequences sequences.extras ;
 
 IN: math.similarity
 
@@ -18,3 +19,17 @@ IN: math.similarity
     [ intersect cardinality dup ]
     [ [ cardinality ] bi@ + swap - ] 2bi
     [ drop 0 ] [ /f ] if-zero ;
+
+<PRIVATE
+
+: weighted-v. ( w a b -- n )
+    [ * * ] [ + ] 3map-reduce ;
+
+: weighted-norm ( w a -- n )
+    [ absq * ] [ + ] 2map-reduce ;
+
+PRIVATE>
+
+: weighted-cosine-similarity ( w a b -- n )
+    [ weighted-v. ]
+    [ [ over ] dip [ weighted-norm ] 2bi@ * ] 3bi / ;

extra/merger/merger.factor

@@ -1,8 +1,7 @@
-USING: accessors arrays fry io.directories kernel
+USING: accessors arrays colors.constants file-picker fry
-models sequences sets ui
+io.directories kernel math.rectangles models sequences sets ui
-ui.gadgets ui.gadgets.buttons ui.gadgets.labeled
+ui.gadgets ui.gadgets.buttons ui.gadgets.glass
-ui.gadgets.tracks ui.gadgets.labels ui.gadgets.glass
+ui.gadgets.labeled ui.gadgets.labels ui.gadgets.tracks ;
-math.rectangles cocoa.dialogs ;
 IN: merger
 
 MAIN-WINDOW: merger-window {
@@ -14,20 +13,26 @@ MAIN-WINDOW: merger-window {
     [
         [
             "…" [
-            open-panel [ first
+                open-file-dialog [
+                    first
                     [ <label> 1array >>children drop ]
-            [ swap set-control-value ] 2bi ] [ drop ] if*
+                    [ swap set-control-value ] 2bi
-         ] <border-button> swap >>model swap <labeled-gadget>
+                ] [ drop ] if*
+            ] <border-button> swap >>model swap
+            COLOR: black <labeled-gadget>
             1 track-add
         ] 2each
     ] keep
     dup first2
-    '[ _ [ value>> ] all? [ parent>> "processing..." <label> [
+    '[
+        _ [ value>> ] all? [
+            parent>> "processing..." <label> [
                 <zero-rect> show-glass
                 _ value>> [
-            "." _ value>> [ [ directory-files ] bi@ diff ] keep copy-files-into
+                    "." _ value>>
+                    [ [ directory-files ] bi@ diff ] keep copy-files-into
                 ] with-directory
             ] keep hide-glass
-    ] [ drop ] if ]
+        ] [ drop ] if
-    "merge" swap <border-button> 0.4 track-add
+    ] "merge" swap <border-button> 0.4 track-add
     >>gadgets ;

extra/merger/platforms.txt

@@ -1 +0,0 @@
-macosx

extra/models/history/history-docs.factor

@@ -23,7 +23,7 @@ HELP: add-history
 { $values { "history" history } }
 { $description "Adds the current value to the history." } ;
 
-ARTICLE: "models-history" "History models"
+ARTICLE: "models.history" "History models"
 "History models record previous values."
 { $subsections
     history
@@ -37,4 +37,4 @@ ARTICLE: "models-history" "History models"
     go-forward
 } ;
 
-ABOUT: "models-history"
+ABOUT: "models.history"

extra/semantic-versioning/semantic-versioning-docs.factor

@@ -39,10 +39,10 @@ HELP: version>=
     { "?" boolean }
 } ;
 
-ARTICLE: { "Versioning" "Semantic Versioning" } "Semantic Versioning"
+ARTICLE: "semantic-versioning" "Semantic Versioning"
 { $vocab-link "semantic-versioning" }
 $nl
 { "See " { $url "http://semver.org/" } " for a detailed description of semantic versioning." }
 ;
 
-ABOUT: { "Versioning" "Semantic Versioning" }
+ABOUT: "semantic-versioning"

extra/sequences/extras/extras.factor

@@ -293,6 +293,14 @@ PRIVATE>
 : 2count ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ? ) -- ... n )
     [ 1 0 ? ] compose 2map-sum ; inline
 
+: 3each-from
+    ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... ) i -- ... )
+    [ (3each) ] dip -rot (each-integer) ; inline
+
+: 3map-reduce
+    ( ..a seq1 seq2 seq3 map-quot: ( ..a elt1 elt2 elt3 -- ..b intermediate ) reduce-quot: ( ..b prev intermediate -- ..a next ) -- ..a result )
+    [ [ [ [ first ] tri@ ] 3keep ] dip [ 3dip ] keep ] dip compose 1 3each-from ; inline
+
 : round-robin ( seq -- newseq )
     [ { } ] [
         [ longest length <iota> ] keep

extra/slides/slides.factor

@@ -27,7 +27,7 @@ CONSTANT: stylesheet
         }
         { code-style
             H{
-                { page-color T{ rgba f 0.4 0.4 0.4 0.3 } }
+                { page-color T{ rgba f 0.9 0.9 0.9 1 } }
             }
         }
         { snippet-style

extra/snake-game/snake-game-docs.factor

@@ -1,8 +1,7 @@
 USING: help.markup help.syntax ;
 IN: snake-game
 
-ARTICLE: { "snake-game" "about" } "About Snake Game"
+ARTICLE: "snake-game" "Snake Game"
-{ $heading "About" }
 "A remake of the popular Snake game. To start the game:"
 { $code "play-snake-game" }
 { $heading "Keys" }
@@ -22,4 +21,4 @@ ARTICLE: { "snake-game" "about" } "About Snake Game"
 HELP: play-snake-game
 { $description "Starts the game!" } ;
 
-ABOUT: { "snake-game" "about" }
+ABOUT: "snake-game"

extra/talks/galois-talk/galois-talk.factor

@@ -147,7 +147,7 @@ CONSTANT: galois-slides
         "Very slow! Let's profile it..."
     }
     { $slide "Example: memoization"
-        { "Let's use " { $link postpone: \: } " instead of " { $link postpone: \MEMO: } }
+        { "Let's use " { $link postpone: \MEMO: } " instead of " { $link postpone: \MEMO: } }
         { $code
             "MEMO: fib ( m -- n )"
             "    dup 1 > ["
@@ -172,8 +172,8 @@ CONSTANT: galois-slides
         { { $link postpone: \EBNF: } ": a complex parsing word" }
         "Implements a custom syntax for expressing parsers: like OMeta!"
         { "Example: " { $vocab-link "printf-example" } }
-        { $code "\"vegan\" \"cheese\" \"%s is not %s\\n\" printf" }
+        { $code "\"cheese\" \"vegan\" \"%s is not %s\\n\" printf" }
-        { $code "5 \"Factor\" \"%s is %d years old\\n\" printf" }
+        { $code "\"Factor\" 5 \"%s is %d years old\\n\" printf" }
     }
     { $slide "Example: simple web browser"
         { $vocab-link "webkit-demo" }
@@ -273,7 +273,7 @@ CONSTANT: galois-slides
     }
     { $slide "Compiler: low-level optimizer"
         "Redundant stack operations eliminated, intermediate floats unboxed..."
-        { $code "[ c pixel ] test-mr mr." }
+        { $code "[ c pixel ] regs." }
     }
     { $slide "Garbage collection"
         "All roots are identified precisely"

extra/talks/google-tech-talk/google-tech-talk.factor

@@ -335,8 +335,8 @@ CONSTANT: google-slides
         { { $link postpone: \EBNF: } ": a complex parsing word" }
         "Implements a custom syntax for expressing parsers"
         { "Example: " { $vocab-link "printf-example" } }
-        { $code "\"vegan\" \"cheese\" \"%s is not %s\\n\" printf" }
+        { $code "\"cheese\" \"vegan\" \"%s is not %s\\n\" printf" }
-        { $code "5 \"Factor\" \"%s is %d years old\\n\" printf" }
+        { $code "\"Factor\" 5 \"%s is %d years old\\n\" printf" }
     }
     { $slide "Input/output library"
         "One of Factor's strongest points: portable, full-featured, efficient"
@@ -455,9 +455,9 @@ CONSTANT: google-slides
     { $slide "Compiler: low level IR"
         "Register-based SSA"
         "Stack operations expand into low-level instructions"
-        { $code "[ 5 ] test-mr mr." }
+        { $code "[ 5 ] regs." }
-        { $code "[ swap ] test-mr mr." }
+        { $code "[ swap ] regs." }
-        { $code "[ append reverse ] test-mr mr." }
+        { $code "[ append reverse ] regs." }
     }
     { $slide "Compiler: low-level optimizer"
         "5 optimization passes"
@@ -469,7 +469,7 @@ CONSTANT: google-slides
         { "Example: " { $link 2array } }
         { { $link <array> } " fills array with initial value" }
         "What if we immediately store new values into the array?"
-        { $code "\\ 2array test-mr mr." }
+        { $code "\\ 2array regs." }
         "Mandelbrot: we optimize stack operations"
     }
     { $slide "Compiler: value numbering"
@@ -508,7 +508,7 @@ CONSTANT: google-slides
         "Simple IR rewrite step"
         "After register allocation, one vreg may have several live intervals, and different physical registers at different points in time"
         "Hence, \"second chance\""
-        { "Mandelbrot: " { $code "[ c pixel ] test-mr mr." } }
+        { "Mandelbrot: " { $code "[ c pixel ] regs." } }
     }
     { $slide "Compiler: code generation"
         "Iterate over list of instructions"

extra/talks/minneapolis-talk/minneapolis-talk.factor

@@ -105,7 +105,7 @@ CONSTANT: minneapolis-slides
         }
         "It is slow:"
         { $code
-            "35 [ fib ] map ."
+            "35 <iota> [ fib ] map ."
         }
         "Let's profile it!"
     }
@@ -126,7 +126,7 @@ CONSTANT: minneapolis-slides
         }
         "It is faster:"
         { $code
-            "35 [ fib ] map ."
+            "35 <iota> [ fib ] map ."
         }
     }
     { $slide "The Factor UI"

extra/talks/otug-talk/otug-talk.factor

@@ -66,7 +66,7 @@ CONSTANT: otug-slides
     { $slide "Combinators"
         { "A " { $emphasis "combinator" } " is a word taking quotations as input" }
         { "Used for control flow, data flow, iteration" }
-        { $code "100 [ 5 mod 3 = [ \"Fizz!\" print ] when ] each" }
+        { $code "100 <iota> [ 5 mod 3 = [ \"Fizz!\" print ] when ] each" }
         { "Control flow: " { $link if } ", " { $link when } ", " { $link unless } ", " { $link cond } }
         { "Iteration: " { $link map } ", " { $link filter } ", " { $link all? } ", ..." }
     }
@@ -250,7 +250,7 @@ var price = (order == null ? null : order.price);" }
     1 >>fill
     \"Hello world!\" <label> add-gadget
     \"Click me!\" [ drop beep ]
-    <bevel-button> add-gadget
+    <border-button> add-gadget
     <editor> <scroller> add-gadget
 \"UI test\" open-window" }
     }

extra/talks/tc-lisp-talk/tc-lisp-talk.factor

@@ -333,7 +333,7 @@ var price = (order == null ? null : order.price);" }
     }
     { $slide "Macro example"
         "Return the caaar of a sequence"
-        { "Return " { $snippet f } " on failure" }
+        { "Return " { $snippet "f" } " on failure" }
         { $code ": caaar ( seq/f -- x/f )
     {
         [ first ]

extra/talks/vpri-talk/vpri-talk.factor

@@ -192,8 +192,8 @@ CONSTANT: vpri-slides
         { { $link postpone: \EBNF: } ": a complex parsing word" }
         "Implements a custom syntax for expressing parsers: like OMeta!"
         { "Example: " { $vocab-link "printf-example" } }
-        { $code "\"vegan\" \"cheese\" \"%s is not %s\\n\" printf" }
+        { $code "\"cheese\" \"vegan\" \"%s is not %s\\n\" printf" }
-        { $code "5 \"Factor\" \"%s is %d years old\\n\" printf" }
+        { $code "\"Factor\" 5 \"%s is %d years old\\n\" printf" }
     }
     { $slide "Example: simple web browser"
         { $vocab-link "webkit-demo" }
@@ -359,9 +359,9 @@ CONSTANT: vpri-slides
     { $slide "Compiler: low level IR"
         "Register-based SSA"
         "Stack operations expand into low-level instructions"
-        { $code "[ 5 ] test-mr mr." }
+        { $code "[ 5 ] regs." }
-        { $code "[ swap ] test-mr mr." }
+        { $code "[ swap ] regs." }
-        { $code "[ append reverse ] test-mr mr." }
+        { $code "[ append reverse ] regs." }
     }
     { $slide "Compiler: low-level optimizer"
         "5 optimization passes"
@@ -373,7 +373,7 @@ CONSTANT: vpri-slides
         { "Example: " { $link 2array } }
         { { $link <array> } " fills array with initial value" }
         "What if we immediately store new values into the array?"
-        { $code "\\ 2array test-mr mr." }
+        { $code "\\ 2array regs." }
         "Mandelbrot: we optimize stack operations"
     }
     { $slide "Compiler: value numbering"
@@ -412,7 +412,7 @@ CONSTANT: vpri-slides
         "Simple IR rewrite step"
         "After register allocation, one vreg may have several live intervals, and different physical registers at different points in time"
         "Hence, \"second chance\""
-        { "Mandelbrot: " { $code "[ c pixel ] test-mr mr." } }
+        { "Mandelbrot: " { $code "[ c pixel ] regs." } }
     }
     { $slide "Compiler: code generation"
         "Iterate over list of instructions"

extra/unicode/control-pictures/authors.txt

@@ -0,0 +1 @@
+Pi

extra/unicode/control-pictures/control-pictures-docs.factor

@@ -0,0 +1,16 @@
+! Copyright (C) 2017 Pi.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax strings ;
+IN: unicode.control-pictures
+
+HELP: control-pictures
+{ $values
+    { "string" string }
+}
+{ $description "Transforms C0 control characters into their corresponding Control Picture block codepoints." } ;
+
+ARTICLE: "unicode.control-pictures" "Control Pictures"
+"The " { $vocab-link "unicode.control-pictures" } " vocabulary provides a utility word " { $link control-pictures } " for transforming characters in the nonprintable " { $url "http://www.unicode.org/charts/PDF/U0000.pdf" "ASCII C0 block" } " to their representations in the " { $url "http://www.unicode.org/charts/PDF/U2400.pdf" "Control Pictures" } " block. It has no effect on any other characters."
+;
+
+ABOUT: "unicode.control-pictures"

extra/unicode/control-pictures/control-pictures-tests.factor

@@ -0,0 +1,5 @@
+USING: sequences strings tools.test unicode.control-pictures ;
+
+{ "␀␁␂␃␄␅␆␇␈␉␊␋␌␍␎␏␐␑␒␓␔␕␖␗␘␙␚␛␜␝␞␟ !\"#$%&'()*+,-./" } [
+    48 <iota> >string control-pictures
+] unit-test

extra/unicode/control-pictures/control-pictures.factor

@@ -0,0 +1,18 @@
+! Copyright (C) 2017 Pi.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators kernel math sequences ;
+IN: unicode.control-pictures
+
+<PRIVATE
+
+: char>control-picture ( char -- char' )
+    {
+        { [ dup 0x20 < ] [ 0x2400 bitor ] }
+        { [ dup 0x7f = ] [ drop 0x2421 ] }
+        [ ]
+    } cond ;
+
+PRIVATE>
+
+: control-pictures ( string -- string )
+    [ char>control-picture ] map ;