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 ;
12 : cleave>quot ( seq -- quot )
13 [ [ keep ] curry ] map concat [ drop ] append [ ] like ;
16 : 2cleave ( x y seq -- )
17 [ 2keep ] each 2drop ;
19 : 2cleave>quot ( seq -- quot )
20 [ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ;
23 : 3cleave ( x y z seq -- )
24 [ 3keep ] each 3drop ;
26 : 3cleave>quot ( seq -- quot )
27 [ [ 3keep ] curry ] map concat [ 3drop ] append [ ] like ;
30 : spread>quot ( seq -- quot )
32 [ dup empty? [ [ >r ] swap [ r> ] 3append ] unless ] dip
36 : spread ( objs... seq -- )
43 [ dup callable? [ drop t ] [ first call ] if ] find nip
44 [ dup callable? [ call ] [ second call ] if ]
47 : alist>quot ( default assoc -- quot )
48 [ rot \ if 3array append [ ] like ] assoc-each ;
50 : cond>quot ( assoc -- quot )
51 [ dup callable? [ [ t ] swap 2array ] when ] map
52 reverse [ no-cond ] swap alist>quot ;
57 : case-find ( obj assoc -- obj' )
60 dupd first dup word? [
63 dup wrapper? [ wrapped>> ] when
68 : case ( obj assoc -- )
70 { [ dup array? ] [ nip second call ] }
71 { [ dup quotation? ] [ call ] }
72 { [ dup not ] [ no-case ] }
75 : linear-case-quot ( default assoc -- quot )
77 [ 1quotation \ dup prefix \ = suffix ]
79 ] assoc-map alist>quot ;
81 : (distribute-buckets) ( buckets pair keys -- )
83 drop [ swap adjoin ] curry each
86 >r 2dup r> hashcode pick length rem rot nth adjoin
90 : <buckets> ( initial length -- array )
91 next-power-of-2 swap [ nip clone ] curry map ;
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
98 : hash-case-table ( default assoc -- array )
99 V{ } [ 1array ] distribute-buckets
100 [ [ >r literalize r> ] assoc-map linear-case-quot ] with map ;
102 : hash-dispatch-quot ( table -- quot )
103 [ length 1- [ fixnum-bitand ] curry ] keep
104 [ dispatch ] curry append ;
106 : hash-case-quot ( default assoc -- quot )
107 hash-case-table hash-dispatch-quot
108 [ dup hashcode >fixnum ] prepend ;
110 : contiguous-range? ( keys -- ? )
111 dup [ fixnum? ] all? [
114 [ [ supremum ] [ infimum ] bi - ]
119 : dispatch-case ( value from to default array -- )
120 >r >r 3dup between? r> r> rot [
121 >r 2drop - >fixnum r> dispatch
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 ;
131 : case>quot ( default assoc -- quot )
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 ]
142 : trim-datastacks ( seq1 seq2 -- seq1' seq2' )
143 2dup [ length ] bi@ min tuck tail >r tail r> ;
145 ERROR: relative-underflow stack ;
147 ERROR: relative-overflow stack ;
149 : assert-depth ( quot -- )
150 >r datastack r> dip >r datastack r>
151 2dup [ length ] compare {
152 { +lt+ [ trim-datastacks nip relative-underflow ] }
154 { +gt+ [ trim-datastacks drop relative-overflow ] }
158 : recursive-hashcode ( n obj quot -- code )
159 pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
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 ;
165 M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
167 M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
169 M: hashtable hashcode*
171 dup assoc-size 1 number=
172 [ assoc-hashcode ] [ nip assoc-size ] if
173 ] recursive-hashcode ;