core/combinators/combinators.factor

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