From d83e1103c1ad51ca74a11a6d38c8c6792a4df63b Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 1 Jul 2008 09:11:37 -0500
Subject: [PATCH 1/9] rewrite-closures: remove old code
---
extra/rewrite-closures/rewrite-closures.factor | 6 ------
1 file changed, 6 deletions(-)
diff --git a/extra/rewrite-closures/rewrite-closures.factor b/extra/rewrite-closures/rewrite-closures.factor
index 6e30a11cfc..31b88eeaa4 100644
--- a/extra/rewrite-closures/rewrite-closures.factor
+++ b/extra/rewrite-closures/rewrite-closures.factor
@@ -14,16 +14,10 @@ IN: rewrite-closures
\ set-parameters [ [set-parameters] ] 1 define-transform
-! : parametric-quot ( parameters quot -- quot )
-! [ [ swap ] set-parameters [ ] call ] make* ;
-
: parametric-quot ( parameters quot -- quot ) '[ , set-parameters , call ] ;
: scoped-quot ( quot -- quot ) [ with-scope ] curry ;
-! : closed-quot ( quot -- quot )
-! [ namestack >r [ namestack ] set-namestack [ ] call r> set-namestack ] make* ;
-
: closed-quot ( quot -- quot )
namestack swap '[ namestack [ , set-namestack @ ] dip set-namestack ] ;
From 765607bc9a63af61ea08455e3fb649fef3bebd35 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 1 Jul 2008 09:31:52 -0500
Subject: [PATCH 2/9] rewrite-closures: Minor improvements
---
extra/rewrite-closures/rewrite-closures.factor | 13 +++++--------
1 file changed, 5 insertions(+), 8 deletions(-)
diff --git a/extra/rewrite-closures/rewrite-closures.factor b/extra/rewrite-closures/rewrite-closures.factor
index 31b88eeaa4..198e1744bc 100644
--- a/extra/rewrite-closures/rewrite-closures.factor
+++ b/extra/rewrite-closures/rewrite-closures.factor
@@ -1,22 +1,19 @@
-USING: kernel parser math quotations namespaces sequences namespaces.lib
- inference.transforms fry ;
+USING: kernel parser math quotations namespaces sequences macros fry ;
IN: rewrite-closures
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! : set-parameters ( seq -- ) reverse [ set ] each ;
+: [set-parameters] ( seq -- quot ) reverse [ [ set ] curry ] map concat ;
-: [set-parameters] ( seq -- quot ) [ [ set ] curry ] map concat ;
+MACRO: set-parameters ( seq -- quot ) [set-parameters] ;
-: set-parameters ( seq -- ) [set-parameters] call ;
-
-\ set-parameters [ [set-parameters] ] 1 define-transform
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: parametric-quot ( parameters quot -- quot ) '[ , set-parameters , call ] ;
-: scoped-quot ( quot -- quot ) [ with-scope ] curry ;
+: scoped-quot ( quot -- quot ) '[ , with-scope ] ;
: closed-quot ( quot -- quot )
namestack swap '[ namestack [ , set-namestack @ ] dip set-namestack ] ;
From 5aa78554adfe55db44266fc8ab506125336074f8 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 1 Jul 2008 15:36:38 -0500
Subject: [PATCH 3/9] newfx: pluck and snip
---
extra/newfx/newfx.factor | 21 ++++++++++++++++++++-
1 file changed, 20 insertions(+), 1 deletion(-)
diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor
index b59e204e0c..0e24ff2507 100644
--- a/extra/newfx/newfx.factor
+++ b/extra/newfx/newfx.factor
@@ -199,4 +199,23 @@ METHOD: as-mutate { object object assoc } set-at ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: start ( seq subseq -- i ) swap sequences:start ;
\ No newline at end of file
+: start ( seq subseq -- i ) swap sequences:start ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pluck ( seq i -- seq ) cut-slice rest-slice append ;
+: pluck-from ( i seq -- seq ) swap pluck ;
+: pluck! ( seq i -- seq ) over delete-nth ;
+: pluck-from! ( i seq -- seq ) tuck delete-nth ;
+: plucked! ( seq i -- ) swap delete-nth ;
+: plucked-from! ( i seq -- ) delete-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: snip ( seq a b -- seq ) >r over r> [ head ] [ tail ] 2bi* append ;
+: snip-this ( a b seq -- seq ) -rot snip ;
+: snip! ( seq a b -- seq ) pick delete-slice ;
+: snip-this! ( a b seq -- seq ) -rot pick delete-slice ;
+: snipped! ( seq a b -- ) rot delete-slice ;
+: snipped-from! ( a b seq -- ) delete-slice ;
+
From 964549b22446e81198dbd3e4ef69b88011d915d5 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Wed, 2 Jul 2008 10:19:31 -0500
Subject: [PATCH 4/9] bake: Add tests
---
extra/bake/bake-tests.factor | 28 ++++++++++++++++++++++++++++
1 file changed, 28 insertions(+)
create mode 100644 extra/bake/bake-tests.factor
diff --git a/extra/bake/bake-tests.factor b/extra/bake/bake-tests.factor
new file mode 100644
index 0000000000..64329de92d
--- /dev/null
+++ b/extra/bake/bake-tests.factor
@@ -0,0 +1,28 @@
+
+USING: kernel tools.test bake ;
+
+IN: bake.tests
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: unit-test* ( input output -- ) swap unit-test ;
+
+: must-be-t ( in -- ) [ t ] swap unit-test ;
+: must-be-f ( in -- ) [ f ] swap unit-test ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+[ 10 20 30 `{ , , , } ] [ { 10 20 30 } ] unit-test*
+
+[ 10 20 30 `{ , { , } , } ] [ { 10 { 20 } 30 } ] unit-test*
+
+[ 10 { 20 21 22 } 30 `{ , , , } ] [ { 10 { 20 21 22 } 30 } ] unit-test*
+
+[ 10 { 20 21 22 } 30 `{ , @ , } ] [ { 10 20 21 22 30 } ] unit-test*
+
+[ { 1 2 3 } `{ @ } ] [ { 1 2 3 } ] unit-test*
+
+[ { 1 2 3 } { 4 5 6 } { 7 8 9 } `{ @ @ @ } ]
+[ { 1 2 3 4 5 6 7 8 9 } ]
+unit-test*
+
From a25254c7f4aa6cdda892e08c8e03e266a2440a48 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Wed, 2 Jul 2008 11:42:49 -0500
Subject: [PATCH 5/9] newfx: invert-index
---
extra/newfx/newfx.factor | 3 +++
1 file changed, 3 insertions(+)
diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor
index 0e24ff2507..e62747a2eb 100644
--- a/extra/newfx/newfx.factor
+++ b/extra/newfx/newfx.factor
@@ -219,3 +219,6 @@ METHOD: as-mutate { object object assoc } set-at ;
: snipped! ( seq a b -- ) rot delete-slice ;
: snipped-from! ( a b seq -- ) delete-slice ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: invert-index ( seq i -- seq i ) >r dup length 1 - r> - ;
\ No newline at end of file
From 4e599f5d9c6cb695a6f66912a0371d0ba242cfaa Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Wed, 2 Jul 2008 11:43:14 -0500
Subject: [PATCH 6/9] bake: Bake quotations and vectors
---
extra/bake/bake.factor | 68 +++++++++++++++++++++++++++++++-----------
1 file changed, 50 insertions(+), 18 deletions(-)
diff --git a/extra/bake/bake.factor b/extra/bake/bake.factor
index 7a12a3cc97..834a345821 100644
--- a/extra/bake/bake.factor
+++ b/extra/bake/bake.factor
@@ -1,6 +1,6 @@
-USING: kernel parser combinators sequences splitting quotations arrays macros
- arrays.lib combinators.cleave combinators.conditional newfx ;
+USING: kernel parser namespaces sequences quotations arrays vectors splitting
+ macros arrays.lib combinators.lib combinators.conditional newfx ;
IN: bake
@@ -14,46 +14,78 @@ SYMBOL: @
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-DEFER: [bake-array]
+DEFER: [bake]
: broil-element ( obj -- quot )
{
- { [ comma? ] [ drop [ >r ] ] }
- { [ array? ] [ [bake-array] [ >r ] append ] }
- { [ drop t ] [ [ >r ] prefix-on ] }
+ { [ comma? ] [ drop [ >r ] ] }
+ { [ sequence? ] [ [bake] [ >r ] append ] }
+ { [ drop t ] [ [ >r ] prefix-on ] }
}
1cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: [broil] ( array -- quot )
+: constructor ( seq -- quot )
+ {
+ { [ array? ] [ length [ narray ] prefix-on ] }
+ { [ quotation? ] [ length [ ncurry ] prefix-on [ ] prefix ] }
+ { [ vector? ] [ length [ narray >vector ] prefix-on ] }
+ }
+ 1cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: [broil] ( seq -- quot )
[ reverse [ broil-element ] map concat ]
- [ length [ drop [ r> ] ] map concat ]
- [ length [ narray ] prefix-on ]
+ [ length [ drop [ r> ] ] map concat ]
+ [ constructor ]
tri append append
>quotation ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: [simmer] ( array -- quot )
+SYMBOL: saved-sequence
+
+: [connector] ( -- quot )
+ saved-sequence get quotation? [ [ compose ] ] [ [ append ] ] if ;
+
+: [starter] ( -- quot )
+ saved-sequence get
+ {
+ { [ quotation? ] [ drop [ [ ] ] ] }
+ { [ array? ] [ drop [ { } ] ] }
+ { [ vector? ] [ drop [ V{ } ] ] }
+ }
+ 1cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: [simmer] ( seq -- quot )
+
+ dup saved-sequence set
{ @ } split reverse
- [ [ [bake-array] [ append ] append [ >r ] append ] map concat ]
- [ length [ drop [ r> append ] ] map concat ]
+ [ [ [bake] [connector] append [ >r ] append ] map concat ]
+ [ length [ drop [ r> ] [connector] append ] map concat ]
bi
- >r 2 head* [ >r ] append r> ! remove the last append
+ >r 1 invert-index pluck r> ! remove the last append/compose
- [ { } ] swap append
+ [starter] prepend
append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: [bake-array] ( array -- quot ) [ @ member? ] [ [simmer] ] [ [broil] ] 1if ;
-
-MACRO: bake-array ( array -- quot ) [bake-array] ;
+: [bake] ( seq -- quot ) [ @ member? ] [ [simmer] ] [ [broil] ] 1if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: `{ \ } [ >array ] parse-literal \ bake-array parsed ; parsing
\ No newline at end of file
+MACRO: bake ( seq -- quot ) [bake] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing
+: `V{ \ } [ >vector ] parse-literal \ bake parsed ; parsing
+: `[ \ ] [ >quotation ] parse-literal \ bake parsed ; parsing
\ No newline at end of file
From 9a361344cd1c1cd74958b9d84bea2a65d10fd4db Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Wed, 2 Jul 2008 12:08:37 -0500
Subject: [PATCH 7/9] bake: add more tests
---
extra/bake/bake-tests.factor | 6 ++++++
1 file changed, 6 insertions(+)
diff --git a/extra/bake/bake-tests.factor b/extra/bake/bake-tests.factor
index 64329de92d..7b40d603f1 100644
--- a/extra/bake/bake-tests.factor
+++ b/extra/bake/bake-tests.factor
@@ -26,3 +26,9 @@ 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*
+
From a45d8a64095e7dfd6664107609fdd74c75fcc85e Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Wed, 2 Jul 2008 12:09:03 -0500
Subject: [PATCH 8/9] bake: handle integers before sequences
---
extra/bake/bake.factor | 2 ++
1 file changed, 2 insertions(+)
diff --git a/extra/bake/bake.factor b/extra/bake/bake.factor
index 834a345821..71818bc5c6 100644
--- a/extra/bake/bake.factor
+++ b/extra/bake/bake.factor
@@ -1,5 +1,6 @@
USING: kernel parser namespaces sequences quotations arrays vectors splitting
+ math
macros arrays.lib combinators.lib combinators.conditional newfx ;
IN: bake
@@ -19,6 +20,7 @@ DEFER: [bake]
: broil-element ( obj -- quot )
{
{ [ comma? ] [ drop [ >r ] ] }
+ { [ integer? ] [ [ >r ] prefix-on ] }
{ [ sequence? ] [ [bake] [ >r ] append ] }
{ [ drop t ] [ [ >r ] prefix-on ] }
}
From d0cddcfc4152113efba67603a5f3842635b84e3f Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Wed, 2 Jul 2008 15:57:07 -0500
Subject: [PATCH 9/9] fry: Minor factoring
---
extra/fry/fry.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/fry/fry.factor b/extra/fry/fry.factor
index f15a6b24c2..4a97ace2fe 100755
--- a/extra/fry/fry.factor
+++ b/extra/fry/fry.factor
@@ -10,9 +10,10 @@ IN: fry
: _ ( -- * ) "Only valid inside a fry" throw ;
DEFER: (shallow-fry)
+DEFER: shallow-fry
: ((shallow-fry)) ( accum quot adder -- result )
- >r [ ] swap (shallow-fry) r>
+ >r shallow-fry r>
append swap dup empty? [ drop ] [
[ prepose ] curry append
] if ; inline