2011-03-10 09:29:04 -05:00
|
|
|
! Copyright (C) 2009 Slava Pestov, Eduardo Cavazos, Joe Groff.
|
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2019-10-04 21:15:59 -04:00
|
|
|
USING: accessors combinators kernel locals.backend math
|
|
|
|
namespaces parser quotations sequences sets splitting words ;
|
2008-03-03 17:44:24 -05:00
|
|
|
IN: fry
|
|
|
|
|
2019-10-04 21:15:59 -04:00
|
|
|
ERROR: not-in-a-fry ;
|
|
|
|
|
|
|
|
SYMBOL: in-fry?
|
|
|
|
|
|
|
|
SYNTAX: _ in-fry? get [ \ _ suffix! ] [ not-in-a-fry ] if ;
|
|
|
|
|
|
|
|
SYNTAX: @ in-fry? get [ \ @ suffix! ] [ not-in-a-fry ] if ;
|
2008-09-10 21:07:00 -04:00
|
|
|
|
2008-11-21 06:17:51 -05:00
|
|
|
ERROR: >r/r>-in-fry-error ;
|
|
|
|
|
2009-11-07 14:03:46 -05:00
|
|
|
GENERIC: fry ( quot -- quot' )
|
2008-03-03 17:44:24 -05:00
|
|
|
|
2009-11-07 00:39:08 -05:00
|
|
|
<PRIVATE
|
2008-11-21 06:17:51 -05:00
|
|
|
|
|
|
|
: check-fry ( quot -- quot )
|
2008-12-17 20:17:37 -05:00
|
|
|
dup { load-local load-locals get-local drop-locals } intersect
|
2015-08-13 19:13:05 -04:00
|
|
|
[ >r/r>-in-fry-error ] unless-empty ;
|
2008-11-21 06:17:51 -05:00
|
|
|
|
2019-10-04 21:15:59 -04:00
|
|
|
PREDICATE: fry-specifier < word { POSTPONE: _ POSTPONE: @ } member-eq? ;
|
2008-03-03 17:44:24 -05:00
|
|
|
|
2008-09-10 21:07:00 -04:00
|
|
|
GENERIC: count-inputs ( quot -- n )
|
|
|
|
|
2009-10-29 15:34:04 -04:00
|
|
|
M: callable count-inputs [ count-inputs ] map-sum ;
|
2008-09-11 01:36:55 -04:00
|
|
|
M: fry-specifier count-inputs drop 1 ;
|
2008-09-10 21:07:00 -04:00
|
|
|
M: object count-inputs drop 0 ;
|
|
|
|
|
2009-11-07 14:03:46 -05:00
|
|
|
MIXIN: fried
|
2009-11-07 00:39:08 -05:00
|
|
|
PREDICATE: fried-callable < callable
|
|
|
|
count-inputs 0 > ;
|
2009-11-07 14:03:46 -05:00
|
|
|
INSTANCE: fried-callable fried
|
2008-11-27 22:55:20 -05:00
|
|
|
|
2009-11-07 22:34:16 -05:00
|
|
|
: (ncurry) ( quot n -- quot )
|
2009-11-07 14:03:46 -05:00
|
|
|
{
|
2009-11-07 22:34:16 -05:00
|
|
|
{ 0 [ ] }
|
|
|
|
{ 1 [ \ curry suffix! ] }
|
|
|
|
{ 2 [ \ 2curry suffix! ] }
|
|
|
|
{ 3 [ \ 3curry suffix! ] }
|
|
|
|
[ [ \ 3curry suffix! ] dip 3 - (ncurry) ]
|
2009-11-07 15:38:06 -05:00
|
|
|
} case ;
|
2009-11-07 14:03:46 -05:00
|
|
|
|
2009-11-08 22:00:35 -05:00
|
|
|
: wrap-non-callable ( obj -- quot )
|
|
|
|
dup callable? [ ] [ [ call ] curry ] if ; inline
|
|
|
|
|
2009-11-07 22:34:16 -05:00
|
|
|
: [ncurry] ( n -- quot )
|
|
|
|
[ V{ } clone ] dip (ncurry) >quotation ;
|
|
|
|
|
2009-11-07 00:39:08 -05:00
|
|
|
: [ndip] ( quot n -- quot' )
|
|
|
|
{
|
2009-11-08 22:00:35 -05:00
|
|
|
{ 0 [ wrap-non-callable ] }
|
2009-11-07 00:39:08 -05:00
|
|
|
{ 1 [ \ dip [ ] 2sequence ] }
|
|
|
|
{ 2 [ \ 2dip [ ] 2sequence ] }
|
|
|
|
{ 3 [ \ 3dip [ ] 2sequence ] }
|
2009-11-07 22:34:16 -05:00
|
|
|
[ [ \ 3dip [ ] 2sequence ] dip 3 - [ndip] ]
|
2009-11-07 00:39:08 -05:00
|
|
|
} case ;
|
2008-05-26 01:48:18 -04:00
|
|
|
|
2009-11-07 15:38:06 -05:00
|
|
|
: (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 ;
|
|
|
|
|
2009-11-07 22:50:45 -05:00
|
|
|
: prune-curries ( seq -- seq' )
|
2011-03-10 09:29:04 -05:00
|
|
|
dup [ empty? not ] find
|
2009-11-07 22:50:45 -05:00
|
|
|
[ [ 1 + tail ] dip but-last prefix ]
|
|
|
|
[ 2drop { } ] if* ;
|
|
|
|
|
2009-11-07 15:38:06 -05:00
|
|
|
: convert-curries ( seq -- tail seq' )
|
2009-11-07 22:50:45 -05:00
|
|
|
unclip-slice [ 0 swap [ convert-curry ] map ] dip
|
|
|
|
[ prune-curries ]
|
|
|
|
[ >quotation 1quotation prefix ] if-empty ;
|
|
|
|
|
|
|
|
: mark-composes ( quot -- quot' )
|
2019-10-04 21:15:59 -04:00
|
|
|
[ dup \ @ = [ drop [ POSTPONE: _ POSTPONE: @ ] ] [ 1quotation ] if ] map concat ; inline
|
2009-11-07 15:38:06 -05:00
|
|
|
|
|
|
|
: shallow-fry ( quot -- quot' )
|
2009-11-07 22:50:45 -05:00
|
|
|
check-fry mark-composes
|
2019-10-04 21:15:59 -04:00
|
|
|
{ POSTPONE: _ } split convert-curries
|
2009-11-07 22:50:45 -05:00
|
|
|
[ [ [ ] ] [ [ ] (make-curry) but-last ] if-zero ]
|
2011-10-02 23:25:39 -04:00
|
|
|
[ shallow-spread>quot swap [ [ ] (make-curry) compose ] unless-zero ] if-empty ;
|
2009-11-07 15:38:06 -05:00
|
|
|
|
2009-11-07 00:39:08 -05:00
|
|
|
DEFER: dredge-fry
|
2008-11-27 22:55:20 -05:00
|
|
|
|
2009-11-07 00:39:08 -05:00
|
|
|
TUPLE: dredge-fry-state
|
|
|
|
{ in-quot read-only }
|
|
|
|
{ prequot read-only }
|
|
|
|
{ quot read-only } ;
|
|
|
|
|
|
|
|
: <dredge-fry> ( quot -- dredge-fry )
|
|
|
|
V{ } clone V{ } clone dredge-fry-state boa ; inline
|
|
|
|
|
|
|
|
: in-quot-slices ( n i state -- head tail )
|
|
|
|
in-quot>>
|
|
|
|
[ <slice> ]
|
2018-06-19 20:15:05 -04:00
|
|
|
[ nipd swap 1 + tail-slice ] 3bi ; inline
|
2009-11-07 00:39:08 -05:00
|
|
|
|
|
|
|
: push-head-slice ( head state -- )
|
|
|
|
quot>> [ push-all ] [ \ _ swap push ] bi ; inline
|
|
|
|
|
|
|
|
: push-subquot ( tail elt state -- )
|
|
|
|
[ fry swap >quotation count-inputs [ndip] ] dip prequot>> push-all ; inline
|
|
|
|
|
|
|
|
: (dredge-fry-subquot) ( n state i elt -- )
|
|
|
|
rot {
|
|
|
|
[ nip in-quot-slices ] ! head tail i elt state
|
|
|
|
[ [ 2drop swap ] dip push-head-slice ]
|
2018-06-19 20:15:05 -04:00
|
|
|
[ nipd push-subquot ]
|
2009-11-07 00:39:08 -05:00
|
|
|
[ [ 1 + ] [ drop ] [ ] tri* dredge-fry ]
|
|
|
|
} 3cleave ; inline recursive
|
|
|
|
|
|
|
|
: (dredge-fry-simple) ( n state -- )
|
|
|
|
[ in-quot>> swap tail-slice ] [ quot>> ] bi push-all ; inline recursive
|
|
|
|
|
|
|
|
: dredge-fry ( n dredge-fry -- )
|
2009-11-07 14:03:46 -05:00
|
|
|
2dup in-quot>> [ fried? ] find-from
|
2009-11-07 00:39:08 -05:00
|
|
|
[ (dredge-fry-subquot) ]
|
|
|
|
[ drop (dredge-fry-simple) ] if* ; inline recursive
|
|
|
|
|
|
|
|
PRIVATE>
|
2008-11-27 22:55:20 -05:00
|
|
|
|
2020-09-09 17:41:17 -04:00
|
|
|
M: callable fry
|
2009-11-11 16:50:20 -05:00
|
|
|
[ [ [ ] ] ] [
|
|
|
|
0 swap <dredge-fry>
|
|
|
|
[ dredge-fry ] [
|
|
|
|
[ prequot>> >quotation ]
|
|
|
|
[ quot>> >quotation shallow-fry ] bi append
|
|
|
|
] bi
|
|
|
|
] if-empty ;
|
2008-04-22 17:29:20 -04:00
|
|
|
|
2019-10-04 21:15:59 -04:00
|
|
|
SYNTAX: '[ t in-fry? [ parse-quotation ] with-variable fry append! ;
|