core/combinators/combinators.factor

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