core/fry/fry.factor

   1 ! Copyright (C) 2009 Slava Pestov, Eduardo Cavazos, Joe Groff.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays classes combinators generic kernel
   4 locals.backend math quotations sequences sequences.private sets
   5 splitting vectors words ;
   6 IN: fry
   7
   8 ERROR: not-in-a-fry ;
   9
  10 SYMBOL: in-fry?
  11
  12 ERROR: >r/r>-in-fry-error ;
  13
  14 GENERIC: fry ( object -- quot )
  15
  16 <PRIVATE
  17
  18 : check-fry ( quot -- quot )
  19     dup { load-local load-locals get-local drop-locals } intersect
  20     [ >r/r>-in-fry-error ] unless-empty ;
  21
  22 PREDICATE: fry-specifier < word { POSTPONE: _ POSTPONE: @ } member-eq? ;
  23
  24 GENERIC: count-inputs ( quot -- n )
  25
  26 M: sequence count-inputs [ count-inputs ] map-sum ;
  27 M: fry-specifier count-inputs drop 1 ;
  28 M: object count-inputs drop 0 ;
  29
  30 MIXIN: fried
  31 PREDICATE: fried-sequence < sequence count-inputs 0 > ;
  32 INSTANCE: fried-sequence fried
  33
  34 : (ncurry) ( accum n -- accum )
  35     {
  36         { 0 [ ] }
  37         { 1 [ \ curry  suffix! ] }
  38         { 2 [ \ 2curry suffix! ] }
  39         { 3 [ \ 3curry suffix! ] }
  40         [ [ \ 3curry suffix! ] dip 3 - (ncurry) ]
  41     } case ;
  42
  43 : wrap-non-callable ( obj -- quot )
  44     dup callable? [ ] [ [ call ] curry ] if ; inline
  45
  46 : [ncurry] ( n -- quot )
  47     [ V{ dup callable? [ >quotation ] unless } clone ] dip (ncurry) >quotation ;
  48
  49 : [ndip] ( quot n -- quot' )
  50     {
  51         { 0 [ wrap-non-callable ] }
  52         { 1 [ \ dip  [ ] 2sequence ] }
  53         { 2 [ \ 2dip [ ] 2sequence ] }
  54         { 3 [ \ 3dip [ ] 2sequence ] }
  55         [ [ \ 3dip [ ] 2sequence ] dip 3 - [ndip] ]
  56     } case ;
  57
  58 : (make-curry) ( tail quot -- quot' )
  59     swap [ncurry] curry [ compose ] compose ;
  60
  61 : make-compose ( consecutive quot -- consecutive' quot' )
  62     [ [ [ ] ] [ [ncurry] ] if-zero ]
  63     [ [ [ compose ] ] [ [ compose compose ] curry ] if-empty ]
  64     bi* compose 0 swap ;
  65
  66 : make-curry ( consecutive quot -- consecutive' quot' )
  67     [ 1 + ] dip [ [ ] ] [ (make-curry) 0 swap ] if-empty ;
  68
  69 : convert-curry ( consecutive quot -- consecutive' quot' )
  70     [ [ ] make-curry ] [
  71         dup first \ @ =
  72         [ rest >quotation make-compose ]
  73         [ >quotation make-curry ] if
  74     ] if-empty ;
  75
  76 : prune-curries ( seq -- seq' )
  77     dup [ empty? not ] find
  78     [ [ 1 + tail ] dip but-last prefix ] [ 2drop { } ] if* ;
  79
  80 : convert-curries ( seq -- tail seq' )
  81     unclip-slice [ 0 swap [ convert-curry ] map ] dip
  82     [ prune-curries ] [ >quotation 1quotation prefix ] if-empty ;
  83
  84 : mark-composes ( quot -- quot' )
  85     [
  86         dup \ @ = [
  87             drop [ POSTPONE: _ POSTPONE: @ ]
  88         ] [
  89             1quotation
  90         ] if
  91     ] map concat ; inline
  92
  93 : shallow-fry ( quot -- quot' )
  94     check-fry mark-composes
  95     { POSTPONE: _ } split convert-curries
  96     [ [ [ ] ] [ [ ] (make-curry) but-last ] if-zero ]
  97     [ shallow-spread>quot swap [ [ ] (make-curry) compose ] unless-zero ] if-empty ;
  98
  99 TUPLE: dredge-fry-state
 100     { input sequence read-only }
 101     { prequot vector read-only }
 102     { quot vector read-only } ;
 103
 104 : <dredge-fry> ( quot -- dredge-fry )
 105     V{ } clone V{ } clone dredge-fry-state boa ; inline
 106
 107 : input-slices ( n i state -- head tail )
 108     input>> [ <slice> ] [ nipd swap 1 + tail-slice ] 3bi ; inline
 109
 110 : push-head-slice ( head state -- )
 111     quot>> [ push-all ] [ \ _ swap push ] bi ; inline
 112
 113 : push-subquot ( tail elt state -- )
 114     [ fry swap count-inputs [ndip] ] dip prequot>> push-all ; inline
 115
 116 DEFER: dredge-fry
 117
 118 : dredge-fry-subquot ( n state i elt -- )
 119     rot {
 120         [ nip input-slices ] ! head tail i elt state
 121         [ [ 2drop swap ] dip push-head-slice ]
 122         [ nipd push-subquot ]
 123         [ [ drop 1 + ] dip dredge-fry ]
 124     } 3cleave ; inline recursive
 125
 126 : dredge-fry-simple ( n state -- )
 127     [ input>> swap tail-slice ] [ quot>> ] bi push-all ; inline recursive
 128
 129 : dredge-fry ( n dredge-fry -- )
 130     2dup input>> [ fried? ] find-from
 131     [ dredge-fry-subquot ]
 132     [ drop dredge-fry-simple ] if* ; inline recursive
 133
 134 : (fry) ( sequence -- quot )
 135     <dredge-fry>
 136     [ 0 swap dredge-fry ]
 137     [ prequot>> >quotation ]
 138     [ quot>> >quotation shallow-fry ] tri append ;
 139
 140 PRIVATE>
 141
 142 M: callable fry
 143     [ [ [ ] ] ] [ (fry) ] if-empty ;
 144
 145 M: sequence fry
 146     [ 0 swap new-sequence ] keep
 147     [ 1quotation ] [ (fry) swap [ like ] curry append ] if-empty ;