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 make ;
   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     [ ] [ [ dup empty? [ [ dip ] curry ] unless ] dip append ] reduce ;
  32
  33 : spread ( objs... seq -- )
  34     spread>quot call ;
  35
  36 ! cond
  37 ERROR: no-cond ;
  38
  39 : cond ( assoc -- )
  40     [ dup callable? [ drop t ] [ first call ] if ] find nip
  41     [ dup callable? [ call ] [ second call ] if ]
  42     [ no-cond ] if* ;
  43
  44 : alist>quot ( default assoc -- quot )
  45     [ rot \ if 3array append [ ] like ] assoc-each ;
  46
  47 : cond>quot ( assoc -- quot )
  48     [ dup pair? [ [ t ] swap 2array ] unless ] map
  49     reverse [ no-cond ] swap alist>quot ;
  50
  51 ! case
  52 ERROR: no-case object ;
  53
  54 : case-find ( obj assoc -- obj' )
  55     [
  56         dup array? [
  57             dupd first dup word? [
  58                 execute
  59             ] [
  60                 dup wrapper? [ wrapped>> ] when
  61             ] if =
  62         ] [ callable? ] if
  63     ] find nip ;
  64
  65 : case ( obj assoc -- )
  66     case-find {
  67         { [ dup array? ] [ nip second call ] }
  68         { [ dup callable? ] [ call ] }
  69         { [ dup not ] [ drop no-case ] }
  70     } cond ;
  71
  72 : linear-case-quot ( default assoc -- quot )
  73     [
  74         [ 1quotation \ dup prefix \ = suffix ]
  75         [ \ drop prefix ] bi*
  76     ] assoc-map alist>quot ;
  77
  78 : (distribute-buckets) ( buckets pair keys -- )
  79     dup t eq? [
  80         drop [ swap adjoin ] curry each
  81     ] [
  82         [
  83             [ 2dup ] dip hashcode pick length rem rot nth adjoin
  84         ] each 2drop
  85     ] if ;
  86
  87 : <buckets> ( initial length -- array )
  88     next-power-of-2 swap [ nip clone ] curry map ;
  89
  90 : distribute-buckets ( alist initial quot -- buckets )
  91     swapd [ [ dup first ] dip call 2array ] curry map
  92     [ length <buckets> dup ] keep
  93     [ first2 (distribute-buckets) ] with each ; inline
  94
  95 : hash-case-table ( default assoc -- array )
  96     V{ } [ 1array ] distribute-buckets
  97     [ [ [ literalize ] dip ] assoc-map linear-case-quot ] with map ;
  98
  99 : hash-dispatch-quot ( table -- quot )
 100     [ length 1- [ fixnum-bitand ] curry ] keep
 101     [ dispatch ] curry append ;
 102
 103 : hash-case-quot ( default assoc -- quot )
 104     hash-case-table hash-dispatch-quot
 105     [ dup hashcode >fixnum ] prepend ;
 106
 107 : contiguous-range? ( keys -- ? )
 108     dup [ fixnum? ] all? [
 109         dup all-unique? [
 110             [ prune length ]
 111             [ [ supremum ] [ infimum ] bi - ]
 112             bi - 1 =
 113         ] [ drop f ] if
 114     ] [ drop f ] if ;
 115
 116 : dispatch-case-quot ( default assoc -- quot )
 117     [
 118         \ dup ,
 119         dup keys [ infimum , ] [ supremum , ] bi \ between? ,
 120         [
 121             dup keys infimum , [ - >fixnum ] %
 122             sort-keys values [ >quotation ] map ,
 123             \ dispatch ,
 124         ] [ ] make , , \ if ,
 125     ] [ ] make ;
 126
 127 : case>quot ( default assoc -- quot )
 128     dup keys {
 129         { [ dup empty? ] [ 2drop ] }
 130         { [ dup [ length 4 <= ] [ [ word? ] any? ] bi or ] [ drop linear-case-quot ] }
 131         { [ dup contiguous-range? ] [ drop dispatch-case-quot ] }
 132         { [ dup [ wrapper? ] any? not ] [ drop hash-case-quot ] }
 133         { [ dup [ wrapper? ] all? ] [ drop [ [ wrapped>> ] dip ] assoc-map hash-case-quot ] }
 134         [ drop linear-case-quot ]
 135     } cond ;
 136
 137 ! recursive-hashcode
 138 : recursive-hashcode ( n obj quot -- code )
 139     pick 0 <= [ 3drop 0 ] [ [ 1- ] 2dip call ] if ; inline
 140
 141 ! These go here, not in sequences and hashtables, since those
 142 ! two cannot depend on us
 143 M: sequence hashcode* [ sequence-hashcode ] recursive-hashcode ;
 144
 145 M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
 146
 147 M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
 148
 149 M: hashtable hashcode*
 150     [
 151         dup assoc-size 1 eq?
 152         [ assoc-hashcode ] [ nip assoc-size ] if
 153     ] recursive-hashcode ;