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