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

diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor
index 838c09c65738ae2061c35a4f95ca67c5ac6be3ac..cf03565770d293ad8cc99e579ed56ef0c079dcc5 100755 (executable)
--- a/basis/io/launcher/launcher.factor
+++ b/basis/io/launcher/launcher.factor
@@ -3,9 +3,9 @@
 USING: system kernel namespaces strings hashtables sequences 
 assocs combinators vocabs.loader init threads continuations
 math accessors concurrency.flags destructors environment
-io io.encodings.ascii io.backend io.timeouts io.pipes
+io io.encodings.utf8 io.backend io.timeouts io.pipes
 io.pipes.private io.encodings io.streams.duplex io.ports
-debugger prettyprint summary calendar ;
+debugger prettyprint summary calendar io.pathnames ;
 IN: io.launcher
 
 TUPLE: process < identity-tuple
@@ -266,4 +266,4 @@ M: object run-pipeline-element
     [ ]
 } cond
 
-: run-desc ( desc -- result ) ascii <process-reader> f swap stream-read-until drop ;
+: run-desc ( desc -- result ) utf8 [ contents [ but-last ] [ f ] if* ] with-process-reader ;
\ No newline at end of file

diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index d60602fc719893a62f07c8b8492e32e0d0759d8a..d03e46bcefc046a6dabc15bc839a99380077624b 100755 (executable)
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel kernel.private slots.private math
+USING: accessors kernel kernel.private locals slots.private math
 math.private math.order ;
 IN: sequences
 
@@ -916,3 +916,10 @@ PRIVATE>
             [ array-flip ] [ generic-flip ] if
         ] [ generic-flip ] if
     ] unless ;
+
+:: reduce-r
+    ( list identity quot: ( obj1 obj2 -- obj ) -- result )
+    list empty?
+    [ identity ]
+    [ list rest identity quot reduce-r list first quot call ] if ;
+    inline recursive
\ No newline at end of file

diff --git a/extra/closures/closures.factor b/extra/closures/closures.factor
new file mode 100644 (file)
index 0000000..1411fa9
--- /dev/null
+++ b/extra/closures/closures.factor
@@ -0,0 +1,4 @@
+USING: fry namespaces kernel sequences parser ;
+IN: closures
+: delayed-bind ( quot -- quot' ) '[ namestack [ set-namestack @ ] curry ] ;
+SYNTAX: C[ parse-quotation delayed-bind over push-all ;

diff --git a/extra/file-trees/file-trees.factor b/extra/file-trees/file-trees.factor
index eadfccdc4c0adfabb5372e49404786254749d329..90916baa5609e14531206e979ef1800413347412 100644 (file)
--- a/extra/file-trees/file-trees.factor
+++ b/extra/file-trees/file-trees.factor
@@ -1,17 +1,25 @@
 USING: accessors arrays delegate delegate.protocols
-io.pathnames kernel locals namespaces prettyprint sequences
-ui.frp vectors ;
+io.pathnames kernel locals sequences
+ui.frp vectors make ;
 IN: file-trees
 
-TUPLE: tree node children ;
+TUPLE: walkable-vector vector father ;
+CONSULT: sequence-protocol walkable-vector vector>> ;
+
+M: walkable-vector set-nth [ vector>> set-nth ] 3keep nip
+   father>> swap children>> vector>> push ;
+
+TUPLE: tree node comment children ;
 CONSULT: sequence-protocol tree children>> ;
 
-: <tree> ( start -- tree ) V{ } clone
-   [ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ;
+: file? ( tree -- ? ) children>> [ node>> ".." = not ] filter empty? ;
+
+: <dir-tree> ( {start,comment} -- tree ) first2 walkable-vector new vector new >>vector
+   [ tree boa dup children>> ] [ ".." -rot tree boa ] 2bi swap (>>father) ;
 
 DEFER: (tree-insert)
 
-: tree-insert ( path tree -- ) [ unclip <tree> ] [ children>> ] bi* (tree-insert) ;
+: tree-insert ( path tree -- ) [ unclip <dir-tree> ] [ children>> ] bi* (tree-insert) ;
 :: (tree-insert) ( path-rest path-head tree-children -- )
    tree-children [ node>> path-head node>> = ] find nip
    [ path-rest swap tree-insert ]
@@ -19,8 +27,12 @@ DEFER: (tree-insert)
       path-head tree-children push
       path-rest [ path-head tree-insert ] unless-empty
    ] if* ;
-: create-tree ( file-list -- tree ) [ path-components ] map
-   t <tree> [ [ tree-insert ] curry each ] keep ;
+
+: add-paths ( pathseq -- {{name,path}} )
+   "" [ [ "/" glue dup ] keep swap 2array , ] [ reduce drop ] f make ;
+
+: create-tree ( file-list -- tree ) [ path-components add-paths ] map
+   { "/" "/" } <dir-tree> [ [ tree-insert ] curry each ] keep ;
 
 : <dir-table> ( tree-model -- table )
    <frp-list*> [ node>> 1array ] >>quot

diff --git a/extra/file-trees/file-trees.factor copy b/extra/file-trees/file-trees.factor copy
new file mode 100644 (file)
index 0000000..e3324d9
--- /dev/null
+++ b/extra/file-trees/file-trees.factor copy
@@ -0,0 +1,34 @@
+USING: accessors arrays delegate delegate.protocols
+io.pathnames kernel locals namespaces prettyprint sequences
+ui.frp vectors ;
+IN: file-trees
+
+! There should be optional extra information you can provide
+TUPLE: tree node children ;
+CONSULT: sequence-protocol tree children>> ;
+
+: <dir-tree> ( start -- tree ) V{ } clone
+   [ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ;
+
+DEFER: (tree-insert)
+
+: tree-insert ( path tree -- ) [ unclip <dir-tree> ] [ children>> ] bi* (tree-insert) ;
+:: (tree-insert) ( path-rest path-head tree-children -- )
+   tree-children [ node>> path-head node>> = ] find nip
+   [ path-rest swap tree-insert ]
+   [ 
+      path-head tree-children push
+      path-rest [ path-head tree-insert ] unless-empty
+   ] if* ;
+
+: create-tree ( file-list -- tree ) [ path-components ] map
+   t <dir-tree> [ [ tree-insert ] curry each ] keep ;
+
+: find-path ( tree -- string ) dup node>> tuck t =
+   [ 2drop f ] [ children>> first find-path "/" glue ] if ;
+
+: <dir-table> ( tree-model -- table )
+   <frp-list*> [ node>> 1array ] >>quot
+   [ selected-value>> <switch> ]
+   [ swap >>model ] bi
+   [ find-path ] >>val-quot ;
\ No newline at end of file

diff --git a/extra/models/mapped/mapped.factor b/extra/models/mapped/mapped.factor
new file mode 100644 (file)
index 0000000..9b8dd9c
--- /dev/null
+++ b/extra/models/mapped/mapped.factor
@@ -0,0 +1,11 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: macros ui.frp models.product fry
+generalizations kernel sequences ;
+IN: models.mapped
+
+MACRO: <n-mapped> ( int -- quot ) dup
+   '[ [ _ narray <product> ] dip [ _ firstn ] prepend <mapped> ] ;
+
+: <2mapped> ( a b quot -- arrow ) 2 <n-mapped> ; inline
+: <3mapped> ( a b c quot -- arrow ) 3 <n-mapped> ; inline
\ No newline at end of file

diff --git a/extra/str-fry/str-fry.factor b/extra/str-fry/str-fry.factor
index bfe74f37eb9b279a4f2ad66c6feb2b9b1fe51592..55dba1285dd10a7d85f74ae95402f94a7bb682d6 100644 (file)
--- a/extra/str-fry/str-fry.factor
+++ b/extra/str-fry/str-fry.factor
@@ -2,6 +2,6 @@ USING: combinators effects kernel math sequences splitting
 strings.parser ;
 IN: str-fry
 : str-fry ( str -- quot ) "_" split
-    [ unclip [ [ rot glue ] reduce ] 2curry ]
+    [ unclip-last [ [ spin glue ] reduce-r ] 2curry ] ! not rot
     [ length 1 - 1 <effect> [ call-effect ] 2curry ] bi ;
 SYNTAX: I" parse-string rest str-fry over push-all ;
\ No newline at end of file

diff --git a/extra/ui/frp/frp.factor b/extra/ui/frp/frp.factor
index 699d034c72794a15a9736f5be54c3993329d711d..e682691a0ddc5ae668eb95005c92dc12d054a56f 100644 (file)
--- a/extra/ui/frp/frp.factor
+++ b/extra/ui/frp/frp.factor
@@ -1,13 +1,57 @@
-USING: accessors arrays colors fonts kernel models
+USING: accessors arrays colors fonts fry kernel math models
 models.product monads sequences ui.gadgets ui.gadgets.buttons
 ui.gadgets.editors ui.gadgets.line-support ui.gadgets.tables
-ui.gadgets.tracks ui.render ui.gadgets.scrollers ;
+ui.gadgets.tracks ui.render ui.gadgets.scrollers ui.baseline-alignment
+math.parser lexer ;
 QUALIFIED: make
 IN: ui.frp
 
+! !!! Model utilities
+TUPLE: multi-model < model ;
+GENERIC: (model-changed) ( model observer -- )
+: <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
+M: multi-model model-changed over value>> [ (model-changed) ] [ 2drop ] if ;
+
+TUPLE: basic-model < multi-model ;
+M: basic-model (model-changed) [ value>> ] dip set-model ;
+: <merge> ( models -- model ) basic-model <multi-model> ;
+
+TUPLE: filter-model < multi-model quot ;
+M: filter-model (model-changed) [ value>> ] dip 2dup quot>> call( a -- ? )
+   [ set-model ] [ 2drop ] if ;
+: <filter> ( model quot -- filter-model ) [ 1array filter-model <multi-model> ] dip >>quot ;
+
+TUPLE: fold-model < multi-model oldval quot ;
+M: fold-model (model-changed) [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi*
+   call( val oldval -- newval ) ] keep set-model ;
+: <fold> ( oldval quot model -- model' ) 1array fold-model <multi-model> swap >>quot
+   swap [ >>oldval ] [ >>value ] bi ;
+
+TUPLE: switch-model < multi-model original switcher on ;
+M: switch-model (model-changed) 2dup switcher>> =
+   [ [ value>> ] [ t >>on ] bi* set-model ]
+   [ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ;
+: <switch> ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] 2keep
+   [ >>original ] [ >>switcher ] bi* ;
+M: switch-model model-activated [ original>> ] keep model-changed ;
+
+
+TUPLE: mapped-model < multi-model model quot ;
+ 
+: <mapped> ( model quot -- mapped )
+    f mapped-model new-model
+        swap >>quot
+        over >>model
+        [ add-dependency ] keep ;
+M: mapped-model (model-changed)
+    [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
+    set-model ;
+M: mapped-model model-activated [ model>> ] keep model-changed ;
+
+
 ! Gadgets
 : <frp-button> ( text -- button ) [ t swap set-control-value ] <border-button> f <model> >>model ;
-TUPLE: frp-table < table quot val-quot color-quot column-titles column-alignment ;
+TUPLE: frp-table < table { quot initial: [ ] } { val-quot initial: [ ] } color-quot column-titles column-alignment ;
 M: frp-table column-titles column-titles>> ;
 M: frp-table column-alignment column-alignment>> ;
 M: frp-table row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ;
@@ -15,84 +59,45 @@ M: frp-table row-value val-quot>> [ call( a -- b ) ]  [ drop f ] if* ;
 M: frp-table row-color color-quot>> [ call( a -- b ) ]  [ drop f ] if* ;
 
 : <frp-table> ( model -- table )
-    frp-table new-line-gadget dup >>renderer [ ] >>quot swap >>model
-    f <model> >>selected-value sans-serif-font >>font
+    frp-table new-line-gadget dup >>renderer swap >>model
+    f basic-model new-model >>selected-value sans-serif-font >>font
     focus-border-color >>focus-border-color
-    transparent >>column-line-color [ ] >>val-quot ;
+    transparent >>column-line-color ;
 : <frp-table*> ( -- table ) f <model> <frp-table> ;
 : <frp-list> ( model -- table ) <frp-table> [ 1array ] >>quot ;
 : <frp-list*> ( -- table ) f <model> <frp-list> ;
 
-: <frp-field> ( -- field ) f <model> <model-field> ;
+: <frp-field> ( -- field ) "" <model> <model-field> ;
 
 ! Layout utilities
+TUPLE: layout gadget width ; C: <layout> layout
 
 GENERIC: output-model ( gadget -- model )
 M: gadget output-model model>> ;
 M: frp-table output-model selected-value>> ;
 M: model-field output-model field-model>> ;
-M: scroller output-model children>> first model>> ;
+M: scroller output-model viewport>> children>> first output-model ;
 
 GENERIC: , ( uiitem -- )
-M: gadget , make:, ;
+M: gadget , f <layout> make:, ;
 M: model , activate-model ;
 
+SYNTAX: ,% scan string>number [ <layout> make:, ] curry over push-all ;
+SYNTAX: ->% scan string>number '[ [ _ <layout> make:, ] [ output-model ] bi ] over push-all ;
+
 GENERIC: -> ( uiitem -- model )
-M: gadget -> dup make:, output-model ;
+M: gadget -> dup , output-model ;
 M: model -> dup , ;
-M: table -> dup , selected-value>> ;
 
+: <spacer> ( -- ) <gadget> 1 <layout> make:, ;
 : <box> ( gadgets type -- track )
-   [ { } make:make ] dip <track> swap [ f track-add ] each ; inline
+   [ { } make:make ] dip <track> +baseline+ >>align swap [ [ gadget>> ] [ width>> ] bi track-add ] each ; inline
 : <box*> ( gadgets type -- track ) [ <box> ] [ [ model>> ] map <product> ] bi >>model ; inline
 : <hbox> ( gadgets -- track ) horizontal <box> ; inline
 : <hbox*> ( gadgets -- track ) horizontal <box*> ; inline
 : <vbox> ( gadgets -- track ) vertical <box> ; inline
 : <vbox*> ( gadgets -- track ) vertical <box*> ; inline
 
-! !!! Model utilities
-TUPLE: multi-model < model ;
-: <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
-
-! Events- discrete model utilities
-
-TUPLE: merge-model < multi-model ;
-M: merge-model model-changed [ value>> ] dip set-model ;
-: <merge> ( models -- model ) merge-model <multi-model> ;
-
-TUPLE: filter-model < multi-model quot ;
-M: filter-model model-changed [ value>> ] dip [ quot>> call( val -- bool ) ] 2keep
-   [ set-model ] [ 2drop ] if ;
-: <filter> ( model quot -- filter-model ) [ 1array filter-model <multi-model> ] dip >>quot ;
-
-! Behaviors - continuous model utilities
-
-TUPLE: fold-model < multi-model oldval quot ;
-M: fold-model model-changed [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi*
-   call( val oldval -- newval ) ] keep set-model ;
-: <fold> ( oldval quot model -- model' ) 1array fold-model <multi-model> swap >>quot
-   swap [ >>oldval ] [ >>value ] bi ;
-
-TUPLE: switch-model < multi-model original switcher on ;
-M: switch-model model-changed 2dup switcher>> =
-   [ over value>> [ [ value>> ] [ t >>on ] bi* set-model ] [ 2drop ] if ]
-   [ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ;
-M: switch-model model-activated [ original>> ] keep model-changed ;
-: <switch> ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] 2keep
-   [ >>original ] [ >>switcher ] bi* ;
-
-TUPLE: mapped < model model quot ;
-
-: <mapped> ( model quot -- arrow )
-    f mapped new-model
-        swap >>quot
-        over >>model
-        [ add-dependency ] keep ;
-
-M: mapped model-changed
-    [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
-    set-model ;
-
 ! Instances
 M: model fmap <mapped> ;
 

diff --git a/extra/ui/gadgets/comboboxes/comboboxes.factor b/extra/ui/gadgets/comboboxes/comboboxes.factor
index b0dbe34d1665381a6cbf0c10cad9007b2ceb233d..a937b73d35f5734cd6cc33e6ef6d034dc6945c57 100644 (file)
--- a/extra/ui/gadgets/comboboxes/comboboxes.factor
+++ b/extra/ui/gadgets/comboboxes/comboboxes.factor
@@ -1,6 +1,6 @@
 USING: accessors arrays kernel math.rectangles models sequences
 ui.frp ui.gadgets ui.gadgets.glass ui.gadgets.labels
-ui.gadgets.tables ui.gestures ;
+ui.gadgets.tables ui.gestures colors.constants fonts ;
 IN: ui.gadgets.comboboxes
 
 TUPLE: combo-table < table spawner ;
@@ -19,4 +19,4 @@ combobox H{
 
 : <combobox> ( options -- combobox ) [ first [ combobox new-label ] keep <model> >>model ] keep
    [ 1array ] map <model> trivial-renderer combo-table new-table
-   >>table ;
\ No newline at end of file
+   >>table dup font>> COLOR: gray >>background 12 >>size >>font ;
\ No newline at end of file