From 1fa98e2121bfd064186fb228df76b78658a9f9a1 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 4 Jul 2008 10:52:50 -0500 Subject: [PATCH 1/8] mandel: use tri@ in scale-rgb --- extra/benchmark/mandel/mandel.factor | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/extra/benchmark/mandel/mandel.factor b/extra/benchmark/mandel/mandel.factor index 5adbb7c668..a81e9565a7 100755 --- a/extra/benchmark/mandel/mandel.factor +++ b/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 ) From 22fdbf53f65434c45f33ce5049679478e1072e58 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 4 Jul 2008 11:19:42 -0500 Subject: [PATCH 2/8] math.quaternions: use 2bi in q* --- extra/math/quaternions/quaternions.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/math/quaternions/quaternions.factor b/extra/math/quaternions/quaternions.factor index f121e4a0d1..b7bfd92a1b 100755 --- a/extra/math/quaternions/quaternions.factor +++ b/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. From 79f19bfe95051fe0e0f35ad37d513b2a9a9c5361 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 4 Jul 2008 11:22:59 -0500 Subject: [PATCH 3/8] math.quaternions: use tri* in euler --- extra/math/quaternions/quaternions.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/math/quaternions/quaternions.factor b/extra/math/quaternions/quaternions.factor index b7bfd92a1b..3c450f1c05 100755 --- a/extra/math/quaternions/quaternions.factor +++ b/extra/math/quaternions/quaternions.factor @@ -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* ; From 94756c189e28e0d5607f5f325c2797f1e55ec01b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 4 Jul 2008 11:34:47 -0500 Subject: [PATCH 4/8] koszul: use 3tri in bigraded-triple --- extra/koszul/koszul.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index a8edf6917f..188cfaa1cf 100755 --- a/extra/koszul/koszul.factor +++ b/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 ) From b1928f6b43020a6e65b0f0ff08c3283fc1066d7f Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 4 Jul 2008 15:01:03 -0500 Subject: [PATCH 5/8] bake: Minor changes --- extra/bake/bake.factor | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/extra/bake/bake.factor b/extra/bake/bake.factor index 71818bc5c6..4ce7bfb586 100644 --- a/extra/bake/bake.factor +++ b/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 \ No newline at end of file From a812ee6503b3b8a9aba910fa886863dd4d09aa00 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 4 Jul 2008 15:01:21 -0500 Subject: [PATCH 6/8] bake-tests: fix some tests --- extra/bake/bake-tests.factor | 6 ------ 1 file changed, 6 deletions(-) diff --git a/extra/bake/bake-tests.factor b/extra/bake/bake-tests.factor index 7b40d603f1..64329de92d 100644 --- a/extra/bake/bake-tests.factor +++ b/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* - From 54d0cdde4f15910e066a4da83eeb44e7e0971191 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 4 Jul 2008 15:01:53 -0500 Subject: [PATCH 7/8] 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 \ , ] [ [fry] ] bi append ] + } + { + [ array? ] + [ [ count-inputs \ , ] [ [bake] ] bi append ] + } + { + [ vector? ] + [ [ count-inputs \ , ] [ [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 From 12d22e593ce08899309eb2f9aba5fe84342f3c7e Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 4 Jul 2008 15:22:47 -0500 Subject: [PATCH 8/8] bake.fry: commas factor --- extra/bake/fry/fry.factor | 25 ++++++++++--------------- 1 file changed, 10 insertions(+), 15 deletions(-) diff --git a/extra/bake/fry/fry.factor b/extra/bake/fry/fry.factor index e5d0813e02..6b069334e6 100644 --- a/extra/bake/fry/fry.factor +++ b/extra/bake/fry/fry.factor @@ -1,6 +1,7 @@ USING: kernel combinators arrays vectors quotations sequences splitting - parser macros sequences.deep combinators.conditional bake newfx ; + parser macros sequences.deep + combinators.short-circuit combinators.conditional bake newfx ; IN: bake.fry @@ -53,28 +54,22 @@ DEFER: shallow-fry ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: bakeable? ( obj -- ? ) { [ array? ] [ vector? ] } 1|| ; + : fry-specifier? ( obj -- ? ) { , @ } member-of? ; : count-inputs ( quot -- n ) flatten [ fry-specifier? ] count ; +: commas ( n -- seq ) , ; + : [fry] ( quot -- quot' ) [ - { { - [ callable? ] - [ [ count-inputs \ , ] [ [fry] ] bi append ] + { [ callable? ] [ [ count-inputs commas ] [ [fry] ] bi append ] } + { [ bakeable? ] [ [ count-inputs commas ] [ [bake] ] bi append ] } + { [ drop t ] [ 1quotation ] } } - { - [ array? ] - [ [ count-inputs \ , ] [ [bake] ] bi append ] - } - { - [ vector? ] - [ [ count-inputs \ , ] [ [bake] ] bi append ] - } - { [ drop t ] [ 1quotation ] } - } - 1cond + 1cond ] map concat deep-fry ;