From 69da074d207107381607d2715f2b18aea2dc548f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 23 Feb 2008 02:09:41 -0600
Subject: [PATCH] Pictured partial application and composition

---
 extra/fry/authors.txt      |  2 ++
 extra/fry/fry-tests.factor | 42 ++++++++++++++++++++++++++++++++++++++
 extra/fry/fry.factor       | 39 +++++++++++++++++++++++++++++++++++
 extra/fry/summary.txt      |  1 +
 extra/fry/tags.txt         |  1 +
 5 files changed, 85 insertions(+)
 create mode 100644 extra/fry/authors.txt
 create mode 100755 extra/fry/fry-tests.factor
 create mode 100755 extra/fry/fry.factor
 create mode 100644 extra/fry/summary.txt
 create mode 100644 extra/fry/tags.txt

diff --git a/extra/fry/authors.txt b/extra/fry/authors.txt
new file mode 100644
index 0000000000..e1907c6d91
--- /dev/null
+++ b/extra/fry/authors.txt
@@ -0,0 +1,2 @@
+Slava Pestov
+Eduardo Cavazos
diff --git a/extra/fry/fry-tests.factor b/extra/fry/fry-tests.factor
new file mode 100755
index 0000000000..fd21a4a4cd
--- /dev/null
+++ b/extra/fry/fry-tests.factor
@@ -0,0 +1,42 @@
+IN: temporary
+USING: fry tools.test math prettyprint kernel io arrays
+sequences ;
+
+[ [ 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 "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
diff --git a/extra/fry/fry.factor b/extra/fry/fry.factor
new file mode 100755
index 0000000000..0b0b91f0d0
--- /dev/null
+++ b/extra/fry/fry.factor
@@ -0,0 +1,39 @@
+! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences combinators parser splitting
+quotations ;
+IN: fry
+
+: , "Only valid inside a fry" throw ;
+: @ "Only valid inside a fry" throw ;
+: _ "Only valid inside a fry" throw ;
+
+DEFER: (fry)
+
+: ((fry)) ( accum quot adder -- result )
+    >r [ ] swap (fry) r>
+    append swap dup empty? [ drop ] [
+        [ swap compose ] curry append
+    ] if ; inline
+
+: (fry) ( accum quot -- result )
+    dup empty? [
+        drop 1quotation
+    ] [
+        unclip {
+            { , [ [ curry ] ((fry)) ] }
+            { @ [ [ compose ] ((fry)) ] }
+            [ swap >r add r> (fry) ]
+        } case
+    ] if ;
+
+: trivial-fry ( quot -- quot' ) [ ] swap (fry) ;
+
+: fry ( quot -- quot' )
+    { _ } last-split1 [
+        >r fry [ [ dip ] curry ] r> trivial-fry [ compose ] compose 3compose
+    ] [
+        trivial-fry
+    ] if* ;
+
+: '[ \ ] parse-until fry over push-all ; parsing
diff --git a/extra/fry/summary.txt b/extra/fry/summary.txt
new file mode 100644
index 0000000000..340948a43c
--- /dev/null
+++ b/extra/fry/summary.txt
@@ -0,0 +1 @@
+Syntax for pictured partial application and composition
diff --git a/extra/fry/tags.txt b/extra/fry/tags.txt
new file mode 100644
index 0000000000..f4274299b1
--- /dev/null
+++ b/extra/fry/tags.txt
@@ -0,0 +1 @@
+extensions