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

extra/bake/bake-tests.factor

@@ -26,9 +26,3 @@ IN: bake.tests
 [ { 1 2 3 4 5 6 7 8 9 } ]
 unit-test*
 
-[ 10 20 30 40 `[ , V{ , { , } } , ] ] [ [ 10 V{ 20 { 30 } } 40 ] ] unit-test*
-
-[ { 1 2 3 } { 4 5 6 } { 7 8 9 } `[ , { V{ @ } { , } } ] ]
-[ [ { 1 2 3 } { V{ 4 5 6 } { { 7 8 9 } } } ] ]
-unit-test*
-

extra/bake/bake.factor

@@ -1,6 +1,6 @@
 
 USING: kernel parser namespaces sequences quotations arrays vectors splitting
-       math
+       words math
        macros arrays.lib combinators.lib combinators.conditional newfx ;
 
 IN: bake
@@ -22,6 +22,7 @@ DEFER: [bake]
       { [ comma?    ] [ drop [ >r ]          ] }
       { [ integer?  ] [ [ >r ] prefix-on     ] }
       { [ sequence? ] [ [bake] [ >r ] append ] }
+      { [ word?     ] [ literalize [ >r ] prefix-on ] }
       { [ drop t    ] [ [ >r ] prefix-on     ] }
     }
   1cond ;
@@ -31,8 +32,9 @@ DEFER: [bake]
 : constructor ( seq -- quot )
     {
       { [ array? ]     [ length [ narray ] prefix-on ] }
-      { [ quotation? ] [ length [ ncurry ] prefix-on [ ] prefix ] }
-      { [ vector? ]    [ length [ narray >vector ] prefix-on ] }
+!      { [ quotation? ] [ length [ ncurry ] prefix-on [ ] prefix ] }
+      { [ quotation? ] [ length [ narray >quotation ] prefix-on ] }
+      { [ vector? ]    [ length [ narray >vector    ] prefix-on ] }
     }
   1cond ;
 
@@ -90,4 +92,3 @@ MACRO: bake ( seq -- quot ) [bake] ;
 
 : `{  \ } [ >array     ] parse-literal \ bake parsed ; parsing
 : `V{ \ } [ >vector    ] parse-literal \ bake parsed ; parsing
-: `[  \ ] [ >quotation ] parse-literal \ bake parsed ; parsing

extra/bake/fry/fry-tests.factor

@@ -0,0 +1,89 @@
+
+USING: tools.test math prettyprint kernel io arrays vectors sequences
+       arrays.lib bake bake.fry ;
+
+IN: bake.fry.tests
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: unit-test* ( input output -- ) swap unit-test ;
+
+: must-be-t ( in -- ) [ t ] swap unit-test ;
+: must-be-f ( in -- ) [ f ] swap unit-test ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+[ [ 3 + ] ] [ 3 `[ , + ] ] unit-test
+
+[ [ 1 3 + ] ] [ 1 3 `[ , , + ] ] unit-test
+
+[ [ 1 + ] ] [ 1 [ + ] `[ , @ ] ] unit-test
+
+[ [ 1 + . ] ] [ 1 [ + ] `[ , @ . ] ] unit-test
+
+[ [ + - ] ] [ [ + ] [ - ] `[ @ @ ] ] unit-test
+
+[ [ "a" write "b" print ] ]
+[ "a" "b" `[ , write , print ] ] unit-test
+
+[ [ 1 2 + 3 4 - ] ]
+[ [ + ] [ - ] `[ 1 2 @ 3 4 @ ] ] unit-test
+
+[ 1/2 ] [
+    1 `[ , _ / ] 2 swap call
+] unit-test
+
+[ { { 1 "a" "A" } { 1 "b" "B" } { 1 "c" "C" } } ] [
+    1 `[ , _ _ 3array ]
+    { "a" "b" "c" } { "A" "B" "C" } rot 2map
+] unit-test
+
+[ { { 1 "a" } { 1 "b" } { 1 "c" } } ] [
+    `[ 1 _ 2array ]
+    { "a" "b" "c" } swap map
+] unit-test
+
+[ 1 2 ] [
+    1 2 `[ _ , ] call
+] unit-test
+
+[ { { 1 "a" 2 } { 1 "b" 2 } { 1 "c" 2 } } ] [
+    1 2 `[ , _ , 3array ]
+    { "a" "b" "c" } swap map
+] unit-test
+
+: funny-dip `[ @ _ ] call ; inline
+
+[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test
+
+[ { 1 2 3 } ] [
+    3 1 `[ , [ , + ] map ] call
+] unit-test
+
+[ { 1 { 2 { 3 } } } ] [
+    1 2 3 `[ , [ , [ , 1array ] call 2array ] call 2array ] call
+] unit-test
+
+{ 1 1 } [ `[ [ [ , ] ] ] ] must-infer-as
+
+[ { { { 3 } } } ] [
+    3 `[ [ [ , 1array ] call 1array ] call 1array ] call
+] unit-test
+
+[ { { { 3 } } } ] [
+    3 `[ [ [ , 1array ] call 1array ] call 1array ] call
+] unit-test
+
+! [ 10 20 30 40 `[ , V{ , { , } } , ] ] [ [ 10 V{ 20 { 30 } } 40 ] ] unit-test*
+
+[ 10 20 30 40 `[ , V{ , { , } } , ] ]
+[ [ 10 20 30 >r r> 1 narray >r >r r> r> 2 narray >vector 40 ] ]
+unit-test*
+
+[ { 1 2 3 } { 4 5 6 } { 7 8 9 } `[ , { V{ @ } { , } } ] call ]
+[
+  { 1 2 3 }
+  { V{ 4 5 6 } { { 7 8 9 } } }
+]
+unit-test*
+

extra/bake/fry/fry.factor

@@ -0,0 +1,80 @@
+
+USING: kernel combinators arrays vectors quotations sequences splitting
+       parser macros sequences.deep
+       combinators.short-circuit combinators.conditional bake newfx ;
+
+IN: bake.fry
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: _
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: (shallow-fry)
+DEFER: shallow-fry
+
+: ((shallow-fry)) ( accum quot adder -- result )
+  >r shallow-fry r>
+  append swap dup empty?
+    [ drop ]
+    [ [ prepose ] curry append ]
+  if ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (shallow-fry) ( accum quot -- result )
+  dup empty?
+    [ drop 1quotation ]
+    [
+      unclip
+        {
+          { \ , [ [ curry   ] ((shallow-fry)) ] }
+          { \ @ [ [ compose ] ((shallow-fry)) ] }
+          [ swap >r suffix r> (shallow-fry) ]
+        }
+      case
+    ]
+  if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: deep-fry ( quot -- quot )
+  { _ } last-split1 dup
+    [
+      shallow-fry [ >r ] rot
+      deep-fry    [ [ dip ] curry r> compose ] 4array concat
+    ]
+    [ drop shallow-fry ]
+  if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bakeable? ( obj -- ? ) { [ array? ] [ vector? ] } 1|| ;
+
+: fry-specifier? ( obj -- ? ) { , @ } member-of? ;
+
+: count-inputs ( quot -- n ) flatten [ fry-specifier? ] count ;
+
+: commas ( n -- seq ) , <repetition> ;
+
+: [fry] ( quot -- quot' )
+    [
+        {
+          { [ callable? ] [ [ count-inputs commas ] [ [fry]  ] bi append ] }
+          { [ bakeable? ] [ [ count-inputs commas ] [ [bake] ] bi append ] }
+          { [ drop t    ] [ 1quotation                                   ] }
+        }
+      1cond
+    ]
+  map concat deep-fry ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MACRO: fry ( seq -- quot ) [fry] ;
+
+: `[ \ ] [ >quotation ] parse-literal \ fry parsed ; parsing

extra/benchmark/mandel/mandel.factor

@@ -1,19 +1,19 @@
-IN: benchmark.mandel
 USING: arrays io kernel math math.order namespaces sequences
-byte-arrays byte-vectors math.functions math.parser io.files
-colors.hsv io.encodings.binary ;
+       byte-arrays byte-vectors math.functions math.parser io.files
+       colors.hsv io.encodings.binary ;
 
-: max-color 360 ; inline
-: zoom-fact 0.8 ; inline
-: width 640 ; inline
-: height 480 ; inline
-: nb-iter 40 ; inline
-: center -0.65 ; inline
+IN: benchmark.mandel
+
+: max-color 360   ; inline
+: zoom-fact 0.8   ; inline
+: width     640   ; inline
+: height    480   ; inline
+: nb-iter   40    ; inline
+: center    -0.65 ; inline
 
 : scale 255 * >fixnum ; inline
 
-: scale-rgb ( r g b -- n )
-    rot scale rot scale rot scale 3array ;
+: scale-rgb ( r g b -- n ) [ scale ] tri@ 3array ;
 
 : sat 0.85 ; inline
 : val 0.85 ; inline
@@ -30,7 +30,7 @@ colors.hsv io.encodings.binary ;
 
 SYMBOL: cols
 
-: x-inc width 200000 zoom-fact * / ; inline
+: x-inc width  200000 zoom-fact * / ; inline
 : y-inc height 150000 zoom-fact * / ; inline
 
 : c ( i j -- c )

extra/koszul/koszul.factor

@@ -265,9 +265,10 @@ DEFER: (d)
 
 : bigraded-triple ( u-deg z-deg bigraded-basis -- triple )
     #! d: C(u,z) ---> C(u+2,z-1)
-    [ >r >r 2 - r> 1 + r> ?nth ?nth ] 3keep
-    [ ?nth ?nth ] 3keep
-    >r >r 2 + r> 1 - r> ?nth ?nth
+    [ [ 2 - ] [ 1 + ] [ ] tri* ?nth ?nth ] 
+    [ ?nth ?nth ] 
+    [ [ 2 + ] [ 1 - ] [ ] tri* ?nth ?nth ]
+    3tri
     3array ;
 
 : bigraded-triples ( grid -- triples )

extra/math/quaternions/quaternions.factor

@@ -24,7 +24,7 @@ PRIVATE>
 
 : q* ( u v -- u*v )
     #! Multiply quaternions.
-    [ q*a ] 2keep q*b 2array ;
+    [ q*a ] [ q*b ] 2bi 2array ;
 
 : qconjugate ( u -- u' )
     #! Quaternion conjugate.
@@ -74,5 +74,4 @@ PRIVATE>
     >r -0.5 * dup cos c>q swap sin r> n*v v- ;
 
 : euler ( phi theta psi -- q )
-    qk (euler) >r qj (euler) >r qi (euler) r> q* r> q* ;
-
+  [ qi (euler) ] [ qj (euler) ] [ qk (euler) ] tri* q* q* ;