diff --git a/basis/fry/fry-tests.factor b/basis/fry/fry-tests.factor index e3e9129931..10d9b282ad 100644 --- a/basis/fry/fry-tests.factor +++ b/basis/fry/fry-tests.factor @@ -10,6 +10,8 @@ SYMBOLS: a b c d e f g h ; [ [ 1 2 ] ] [ [ 1 ] [ 2 ] '[ @ @ ] ] unit-test [ [ 1 2 a ] ] [ 1 2 '[ _ _ a ] ] unit-test +[ [ 1 2 ] ] [ 1 2 '[ _ _ ] ] unit-test +[ [ a 1 2 ] ] [ 1 2 '[ a _ _ ] ] unit-test [ [ 1 2 a ] ] [ [ 1 ] [ 2 ] '[ @ @ a ] ] unit-test [ [ 1 a 2 b ] ] [ 1 2 '[ _ a _ b ] ] unit-test [ [ 1 a 2 b ] ] [ 1 [ 2 ] '[ _ a @ b ] ] unit-test diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor index 42518528dc..abcba82205 100644 --- a/basis/fry/fry.factor +++ b/basis/fry/fry.factor @@ -29,30 +29,14 @@ PREDICATE: fried-callable < callable count-inputs 0 > ; INSTANCE: fried-callable fried -: convert-curry ( quot -- quot' ) - [ [ [ ] curry compose ] ] [ - dup first \ @ = - [ rest >quotation \ compose \ compose [ ] 3sequence ] - [ >quotation \ curry \ compose [ ] 3sequence ] if - ] if-empty ; - -: convert-curries ( seq -- seq' ) - unclip-slice [ [ convert-curry ] map ] [ >quotation 1quotation ] bi* prefix ; - -: shallow-fry ( quot -- quot' ) - check-fry - [ dup \ @ = [ drop [ _ @ ] ] [ 1quotation ] if ] map concat - { _ } split convert-curries - spread>quot ; - -: [ncurry] ( quot n -- quot ) +: [ncurry] ( n -- quot ) { { 0 [ [ ] ] } { 1 [ [ curry ] ] } { 2 [ [ 2curry ] ] } { 3 [ [ 3curry ] ] } - [ \ curry ] - } case curry ; + [ \ curry >quotation ] + } case ; : [ndip] ( quot n -- quot' ) { @@ -63,6 +47,39 @@ INSTANCE: fried-callable fried [ [ \ dip [ ] 2sequence ] times ] } case ; +: (make-curry) ( tail quot -- quot' ) + swap [ncurry] curry [ compose ] compose ; + +: make-compose ( consecutive quot -- consecutive quot' ) + [ + [ [ ] ] + [ [ncurry] ] if-zero + ] [ + [ [ compose ] ] + [ [ compose compose ] curry ] if-empty + ] bi* compose + 0 swap ; + +: make-curry ( consecutive quot -- consecutive' quot' ) + [ 1 + ] dip + [ [ ] ] [ (make-curry) 0 swap ] if-empty ; + +: convert-curry ( consecutive quot -- consecutive' quot' ) + [ [ ] make-curry ] [ + dup first \ @ = + [ rest >quotation make-compose ] + [ >quotation make-curry ] if + ] if-empty ; + +: convert-curries ( seq -- tail seq' ) + unclip-slice [ 0 swap [ convert-curry ] map ] [ >quotation 1quotation ] bi* prefix ; + +: shallow-fry ( quot -- quot' ) + check-fry + [ dup \ @ = [ drop [ _ @ ] ] [ 1quotation ] if ] map concat + { _ } split convert-curries + spread>quot swap [ [ ] (make-curry) compose ] unless-zero ; + DEFER: dredge-fry TUPLE: dredge-fry-state diff --git a/basis/locals/fry/fry.factor b/basis/locals/fry/fry.factor index 30336c45e9..a2a1a6c178 100644 --- a/basis/locals/fry/fry.factor +++ b/basis/locals/fry/fry.factor @@ -12,7 +12,7 @@ M: lambda count-inputs body>> count-inputs ; M: lambda fry clone [ [ count-inputs ] [ fry ] bi ] change-body [ [ vars>> length ] keep '[ _ _ mnswap _ call ] ] - [ drop [ncurry] [ call ] compose ] 2bi ; + [ drop [ncurry] curry [ call ] compose ] 2bi ; M: let fry clone [ fry ] change-body ;