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

Conflicts:
	extra/spheres/spheres.factor

basis/formatting/formatting.factor

@@ -4,7 +4,7 @@
 USING: accessors arrays ascii assocs calendar combinators fry kernel 
 generalizations io io.encodings.ascii io.files io.streams.string
 macros math math.functions math.parser peg.ebnf quotations
-sequences splitting strings unicode.case vectors ;
+sequences splitting strings unicode.case vectors combinators.smart ;
 
 IN: formatting
 
@@ -113,7 +113,6 @@ MACRO: printf ( format-string -- )
 : sprintf ( format-string -- result )
     [ printf ] with-string-writer ; inline
 
-
 <PRIVATE
 
 : pad-00 ( n -- string ) number>string 2 CHAR: 0 pad-head ; inline
@@ -129,12 +128,15 @@ MACRO: printf ( format-string -- )
     [ pad-00 ] map "/" join ; inline
 
 : >datetime ( timestamp -- string )
-    { [ day-of-week day-abbreviation3 ]
+    [
+       {
+          [ day-of-week day-abbreviation3 ]
           [ month>> month-abbreviation ]
           [ day>> pad-00 ]
           [ >time ]
           [ year>> number>string ]
-    } cleave 5 narray " " join ; inline
+       } cleave
+    ] output>array " " join ; inline
 
 : (week-of-year) ( timestamp day -- n )
     [ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when
@@ -187,5 +189,3 @@ PRIVATE>
 MACRO: strftime ( format-string -- )
     parse-strftime [ length ] keep [ ] join
     '[ _ <vector> @ reverse concat nip ] ;
-
-

basis/literals/literals-tests.factor

@@ -19,3 +19,9 @@ IN: literals.tests
 [ { 0.5 2.0 } ] [ { $[ 1.0 2.0 / ] 2.0 } ] unit-test
 
 [ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test
+
+<<
+CONSTANT: constant-a 3
+>>
+
+[ { 3 10 "ftw" } ] [ ${ constant-a 10 "ftw" } ] unit-test

basis/literals/literals.factor

@@ -1,6 +1,8 @@
 ! (c) Joe Groff, see license for details
-USING: accessors continuations kernel parser words quotations vectors ;
+USING: accessors continuations kernel parser words quotations
+combinators.smart vectors sequences ;
 IN: literals
 
 SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ;
 SYNTAX: $[ parse-quotation with-datastack >vector ;
+SYNTAX: ${ \ } [ [ ?execute ] { } map-as ] parse-literal ;

basis/windows/errors/errors.factor

@@ -1,7 +1,7 @@
 USING: alien.c-types kernel locals math math.bitwise
 windows.kernel32 sequences byte-arrays unicode.categories
 io.encodings.string io.encodings.utf16n alien.strings
-arrays ;
+arrays literals ;
 IN: windows.errors
 
 CONSTANT: ERROR_SUCCESS                               0
@@ -732,11 +732,13 @@ ERROR: error-message-failed id ;
         win32-error-string throw
     ] when ;
 
-: expected-io-errors ( -- seq )
+CONSTANT: expected-io-errors
+    ${
         ERROR_SUCCESS
         ERROR_IO_INCOMPLETE
         ERROR_IO_PENDING
-    WAIT_TIMEOUT 4array ; foldable
+        WAIT_TIMEOUT
+    }
 
 : expected-io-error? ( error-code -- ? )
     expected-io-errors member? ;

extra/file-trees/file-trees.factor

@@ -1,10 +1,10 @@
-USING: accessors delegate delegate.protocols io.pathnames
-kernel locals namespaces sequences vectors
-tools.annotations prettyprint ;
+USING: accessors arrays delegate delegate.protocols
+io.pathnames kernel locals namespaces prettyprint sequences
+ui.frp vectors ;
 IN: file-trees
 
 TUPLE: tree node children ;
-CONSULT: sequence-protocol tree children>> [ node>> ] map ;
+CONSULT: sequence-protocol tree children>> ;
 
 : <tree> ( start -- tree ) V{ } clone
    [ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ;
@@ -21,3 +21,8 @@ DEFER: (tree-insert)
    ] if* ;
 : create-tree ( file-list -- tree ) [ path-components ] map
    t <tree> [ [ tree-insert ] curry each ] keep ;
+
+: <dir-table> ( tree-model -- table )
+   <frp-list*> [ node>> 1array ] >>quot
+   [ selected-value>> <switch> ]
+   [ swap >>model ] bi ;

extra/spheres/spheres.factor

@@ -134,13 +134,13 @@ M: spheres-world distance-step ( gadget -- dz )
         GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri
         GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri
         GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_R GL_CLAMP glTexParameteri
-        {
-            $ GL_TEXTURE_CUBE_MAP_POSITIVE_X
-            $ GL_TEXTURE_CUBE_MAP_POSITIVE_Y
-            $ GL_TEXTURE_CUBE_MAP_POSITIVE_Z
-            $ GL_TEXTURE_CUBE_MAP_NEGATIVE_X
-            $ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
-            $ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z
+        ${
+            GL_TEXTURE_CUBE_MAP_POSITIVE_X
+            GL_TEXTURE_CUBE_MAP_POSITIVE_Y
+            GL_TEXTURE_CUBE_MAP_POSITIVE_Z
+            GL_TEXTURE_CUBE_MAP_NEGATIVE_X
+            GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
+            GL_TEXTURE_CUBE_MAP_NEGATIVE_Z
         }
         [ 0 GL_RGBA8 (reflection-dim) 0 GL_RGBA GL_UNSIGNED_BYTE f glTexImage2D ]
         each

extra/str-fry/str-fry.factor

@@ -1,4 +1,7 @@
-USING: kernel sequences splitting strings.parser ;
+USING: combinators effects kernel math sequences splitting
+strings.parser ;
 IN: str-fry
-: str-fry ( str -- quot ) "_" split unclip [ [ rot glue ] reduce ] 2curry ;
+: str-fry ( str -- quot ) "_" split
+    [ unclip [ [ rot glue ] reduce ] 2curry ]
+    [ length 1 - 1 <effect> [ call-effect ] 2curry ] bi ;
 SYNTAX: I" parse-string rest str-fry over push-all ;

extra/ui/frp/frp-docs.factor

@@ -36,7 +36,7 @@ HELP: <fold>
 { $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model'" model } }
 { $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
 
-HELP: switch
+HELP: <switch>
 { $values { "signal1" model } { "signal2" model } { "signal'" model } }
 { $description "Creates a model that starts with the behavior of model1 and switches to the behavior of model2 on its update" } ;
 

extra/ui/frp/frp.factor

@@ -1,7 +1,7 @@
-USING: accessors arrays colors fonts fry kernel models
+USING: accessors arrays colors fonts kernel 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.tracks ui.render ui.gadgets.scrollers ;
 QUALIFIED: make
 IN: ui.frp
 
@@ -18,8 +18,11 @@ M: frp-table row-color color-quot>> [ call( a -- b ) ]  [ drop f ] if* ;
     frp-table new-line-gadget dup >>renderer [ ] >>quot swap >>model
     f <model> >>selected-value sans-serif-font >>font
     focus-border-color >>focus-border-color
-    transparent >>column-line-color ;
+    transparent >>column-line-color [ ] >>val-quot ;
+: <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> ;
 
 ! Layout utilities
@@ -27,6 +30,8 @@ M: frp-table row-color color-quot>> [ call( a -- b ) ]  [ drop f ] if* ;
 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>> ;
 
 GENERIC: , ( uiitem -- )
 M: gadget , make:, ;
@@ -41,13 +46,16 @@ M: table -> dup , selected-value>> ;
    [ { } make:make ] dip <track> swap [ f 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
+! !!! Model utilities
 TUPLE: multi-model < model ;
-! M: multi-model model-activated dup model-changed ;
 : <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> ;
@@ -57,15 +65,21 @@ M: filter-model model-changed [ value>> ] dip [ quot>> call( val -- bool ) ] 2ke
    [ 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 ;
+: <fold> ( oldval quot model -- model' ) 1array fold-model <multi-model> swap >>quot
+   swap [ >>oldval ] [ >>value ] bi ;
 
-TUPLE: switch-model < multi-model switcher on ;
-M: switch-model model-changed tuck [ switcher>> = ] 2keep
-   '[ on>> [ _ value>> _ set-model ] when ] [ t swap (>>on) ] if ;
-: switch ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] keep >>switcher ;
+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 ;
 
@@ -87,4 +101,4 @@ INSTANCE: gadget-monad monad
 INSTANCE: gadget monad
 M: gadget monad-of drop gadget-monad ;
 M: gadget-monad return drop <gadget> swap >>model ;
-M: gadget >>= model>> '[ _ swap call( x -- y ) ] ; 
+M: gadget >>= output-model [ swap call( x -- y ) ] curry ;