From 54d0cdde4f15910e066a4da83eeb44e7e0971191 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 4 Jul 2008 15:01:53 -0500
Subject: [PATCH] Add bake.fry and tests

---
 extra/bake/fry/fry-tests.factor | 89 +++++++++++++++++++++++++++++++++
 extra/bake/fry/fry.factor       | 85 +++++++++++++++++++++++++++++++
 2 files changed, 174 insertions(+)
 create mode 100755 extra/bake/fry/fry-tests.factor
 create mode 100644 extra/bake/fry/fry.factor

diff --git a/extra/bake/fry/fry-tests.factor b/extra/bake/fry/fry-tests.factor
new file mode 100755
index 0000000000..289e1b12fe
--- /dev/null
+++ b/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*
+
diff --git a/extra/bake/fry/fry.factor b/extra/bake/fry/fry.factor
new file mode 100644
index 0000000000..e5d0813e02
--- /dev/null
+++ b/extra/bake/fry/fry.factor
@@ -0,0 +1,85 @@
+
+USING: kernel combinators arrays vectors quotations sequences splitting
+       parser macros sequences.deep 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 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fry-specifier? ( obj -- ? ) { , @ } member-of? ;
+
+: count-inputs ( quot -- n ) flatten [ fry-specifier? ] count ;
+
+: [fry] ( quot -- quot' )
+    [
+      {
+        {
+          [ callable? ]
+          [ [ count-inputs \ , <repetition> ] [ [fry] ] bi append ]
+        }
+        {
+          [ array? ]
+          [ [ count-inputs \ , <repetition> ] [ [bake] ] bi append ]
+        }
+        {
+          [ vector? ]
+          [ [ count-inputs \ , <repetition> ] [ [bake] ] bi append ]
+        }
+        { [ drop t ] [ 1quotation   ] }
+      }
+        1cond
+    ]
+  map concat deep-fry ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MACRO: fry ( seq -- quot ) [fry] ;
+
+: `[ \ ] [ >quotation ] parse-literal \ fry parsed ; parsing
\ No newline at end of file