core/combinators/combinators.factor

   1 ! Copyright (C) 2006, 2010 Slava Pestov, Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays sequences sequences.private math.private
   4 kernel kernel.private math assocs quotations vectors
   5 hashtables sorting words sets math.order make ;
   6 IN: combinators
   7
   8 ! Most of these combinators have compile-time expansions in
   9 ! the optimizing compiler. See stack-checker.transforms and
  10 ! compiler.tree.propagation.call-effect
  11
  12 <PRIVATE
  13
  14 : call-effect-unsafe ( quot effect -- ) drop call ;
  15
  16 : execute-effect-unsafe ( word effect -- ) drop execute ;
  17
  18 M: object throw
  19     5 special-object [ die ] or
  20     ( error -- * ) call-effect-unsafe ;
  21
  22 PRIVATE>
  23
  24 ERROR: wrong-values quot call-site ;
  25
  26 ! We can't USE: effects here so we forward reference slots instead
  27 SLOT: in
  28 SLOT: out
  29 SLOT: terminated?
  30
  31 : call-effect ( quot effect -- )
  32     ! Don't use fancy combinators here, since this word always
  33     ! runs unoptimized
  34     2dup [
  35         [ [ datastack ] dip dip ] dip
  36         dup terminated?>> [ 2drop f ] [
  37             dup in>> length swap out>> length
  38             check-datastack
  39         ] if
  40     ] 2dip rot
  41     [ 2drop ] [ wrong-values ] if ;
  42
  43 : execute-effect ( word effect -- )
  44     [ [ execute ] curry ] dip call-effect ;
  45
  46 ! cleave
  47 : cleave ( x seq -- )
  48     [ call ] with each ;
  49
  50 : cleave>quot ( seq -- quot )
  51     [ [ keep ] curry ] map concat [ drop ] append [ ] like ;
  52
  53 ! 2cleave
  54 : 2cleave ( x y seq -- )
  55     [ 2keep ] each 2drop ;
  56
  57 : 2cleave>quot ( seq -- quot )
  58     [ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ;
  59
  60 ! 3cleave
  61 : 3cleave ( x y z seq -- )
  62     [ 3keep ] each 3drop ;
  63
  64 : 3cleave>quot ( seq -- quot )
  65     [ [ 3keep ] curry ] map concat [ 3drop ] append [ ] like ;
  66
  67 ! spread
  68 : shallow-spread>quot ( seq -- quot )
  69     [ ] [ [ dup empty? [ [ dip ] curry ] unless ] dip append ] reduce ;
  70
  71 : deep-spread>quot ( seq -- quot )
  72     [ ] [ [ [ dip ] curry ] dip append ] reduce ;
  73
  74 : spread ( objs... seq -- )
  75     deep-spread>quot call ;
  76
  77 ! cond
  78 ERROR: no-cond ;
  79
  80 : cond ( assoc -- )
  81     [ dup callable? [ drop t ] [ first call ] if ] find nip
  82     [ dup callable? [ call ] [ second call ] if ]
  83     [ no-cond ] if* ;
  84
  85 : alist>quot ( default assoc -- quot )
  86     [ rot \ if 3array append [ ] like ] assoc-each ;
  87
  88 : cond>quot ( assoc -- quot )
  89     [ dup pair? [ [ t ] swap 2array ] unless ] map
  90     reverse [ no-cond ] swap alist>quot ;
  91
  92 ! case
  93 ERROR: no-case object ;
  94
  95 : case-find ( obj assoc -- obj' )
  96     [
  97         dup array? [
  98             dupd first dup word? [
  99                 execute
 100             ] [
 101                 dup wrapper? [ wrapped>> ] when
 102             ] if =
 103         ] [ callable? ] if
 104     ] find nip ;
 105
 106 \ case-find t "no-compile" set-word-prop
 107
 108 : case ( obj assoc -- )
 109     case-find {
 110         { [ dup array? ] [ nip second call ] }
 111         { [ dup callable? ] [ call ] }
 112         { [ dup not ] [ drop no-case ] }
 113     } cond ;
 114
 115 : linear-case-quot ( default assoc -- quot )
 116     [
 117         [ 1quotation \ dup prefix \ = suffix ]
 118         [ \ drop prefix ] bi*
 119     ] assoc-map alist>quot ;
 120
 121 <PRIVATE
 122
 123 : (distribute-buckets) ( buckets pair keys -- )
 124     dup t eq? [
 125         drop [ swap adjoin ] curry each
 126     ] [
 127         [
 128             [ 2dup ] dip hashcode pick length rem rot nth adjoin
 129         ] each 2drop
 130     ] if ;
 131
 132 : <buckets> ( initial length -- array )
 133     next-power-of-2 iota swap [ nip clone ] curry map ;
 134
 135 : distribute-buckets ( alist initial quot -- buckets )
 136     swapd [ [ dup first ] dip call 2array ] curry map
 137     [ length <buckets> dup ] keep
 138     [ first2 (distribute-buckets) ] with each ; inline
 139
 140 : hash-case-table ( default assoc -- array )
 141     V{ } [ 1array ] distribute-buckets
 142     [ [ [ literalize ] dip ] assoc-map linear-case-quot ] with map ;
 143
 144 : hash-dispatch-quot ( table -- quot )
 145     [ length 1 - [ fixnum-bitand ] curry ] keep
 146     [ dispatch ] curry append ;
 147
 148 : hash-case-quot ( default assoc -- quot )
 149     hash-case-table hash-dispatch-quot
 150     [ dup hashcode >fixnum ] prepend ;
 151
 152 : contiguous-range? ( keys -- ? )
 153     dup [ fixnum? ] all? [
 154         dup all-unique? [
 155             [ length ]
 156             [ [ supremum ] [ infimum ] bi - ]
 157             bi - 1 =
 158         ] [ drop f ] if
 159     ] [ drop f ] if ;
 160
 161 : dispatch-case-quot ( default assoc -- quot )
 162     [
 163         \ dup ,
 164         dup keys [ infimum , ] [ supremum , ] bi \ between? ,
 165         [
 166             dup keys infimum , [ - >fixnum ] %
 167             sort-keys values [ >quotation ] map ,
 168             \ dispatch ,
 169         ] [ ] make , , \ if ,
 170     ] [ ] make ;
 171
 172 PRIVATE>
 173
 174 : case>quot ( default assoc -- quot )
 175     <reversed> dup keys {
 176         { [ dup empty? ] [ 2drop ] }
 177         { [ dup [ length 4 <= ] [ [ word? ] any? ] bi or ] [ drop linear-case-quot ] }
 178         { [ dup contiguous-range? ] [ drop dispatch-case-quot ] }
 179         { [ dup [ wrapper? ] any? not ] [ drop hash-case-quot ] }
 180         { [ dup [ wrapper? ] all? ] [ drop [ [ wrapped>> ] dip ] assoc-map hash-case-quot ] }
 181         [ drop linear-case-quot ]
 182     } cond ;
 183
 184 : recursive-hashcode ( n obj quot -- code )
 185     pick 0 <= [ 3drop 0 ] [ [ 1 - ] 2dip call ] if ; inline
 186
 187 ! These go here, not in sequences and hashtables, since those
 188 ! two cannot depend on us
 189 M: sequence hashcode* [ sequence-hashcode ] recursive-hashcode ;
 190
 191 M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
 192
 193 M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
 194
 195 M: hashtable hashcode*
 196     [
 197         dup assoc-size 1 eq?
 198         [ assoc-hashcode ] [ nip assoc-size ] if
 199     ] recursive-hashcode ;
 200
 201 : to-fixed-point ( ... object quot: ( ... object(n) -- ... object(n+1) ) -- ... object(n) )
 202     [ keep over = ] keep [ to-fixed-point ] curry unless ; inline recursive