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* - 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 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..6b069334e6 --- /dev/null +++ b/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 ) , ; + +: [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 \ No newline at end of file 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 ) 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 ) diff --git a/extra/math/quaternions/quaternions.factor b/extra/math/quaternions/quaternions.factor index f121e4a0d1..3c450f1c05 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. @@ -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* ;