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 ;
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 )
31 [ ] [ [ dup empty? [ [ dip ] curry ] unless ] dip append ] reduce ;
33 : spread ( objs... seq -- )
40 [ dup callable? [ drop t ] [ first call ] if ] find nip
41 [ dup callable? [ call ] [ second call ] if ]
44 : alist>quot ( default assoc -- quot )
45 [ rot \ if 3array append [ ] like ] assoc-each ;
47 : cond>quot ( assoc -- quot )
48 [ dup pair? [ [ t ] swap 2array ] unless ] map
49 reverse [ no-cond ] swap alist>quot ;
54 : case-find ( obj assoc -- obj' )
57 dupd first dup word? [
60 dup wrapper? [ wrapped>> ] when
65 : case ( obj assoc -- )
67 { [ dup array? ] [ nip second call ] }
68 { [ dup quotation? ] [ call ] }
69 { [ dup not ] [ no-case ] }
72 : linear-case-quot ( default assoc -- quot )
74 [ 1quotation \ dup prefix \ = suffix ]
76 ] assoc-map alist>quot ;
78 : (distribute-buckets) ( buckets pair keys -- )
80 drop [ swap adjoin ] curry each
83 [ 2dup ] dip hashcode pick length rem rot nth adjoin
87 : <buckets> ( initial length -- array )
88 next-power-of-2 swap [ nip clone ] curry map ;
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
95 : hash-case-table ( default assoc -- array )
96 V{ } [ 1array ] distribute-buckets
97 [ [ [ literalize ] dip ] assoc-map linear-case-quot ] with map ;
99 : hash-dispatch-quot ( table -- quot )
100 [ length 1- [ fixnum-bitand ] curry ] keep
101 [ dispatch ] curry append ;
103 : hash-case-quot ( default assoc -- quot )
104 hash-case-table hash-dispatch-quot
105 [ dup hashcode >fixnum ] prepend ;
107 : contiguous-range? ( keys -- ? )
108 dup [ fixnum? ] all? [
111 [ [ supremum ] [ infimum ] bi - ]
116 : dispatch-case-quot ( default assoc -- quot )
119 dup keys [ infimum , ] [ supremum , ] bi \ between? ,
121 dup keys infimum , [ - >fixnum ] %
122 sort-keys values [ >quotation ] map ,
124 ] [ ] make , , \ if ,
127 : case>quot ( default assoc -- quot )
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 ]
138 : recursive-hashcode ( n obj quot -- code )
139 pick 0 <= [ 3drop 0 ] [ [ 1- ] 2dip call ] if ; inline
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 ;
145 M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
147 M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
149 M: hashtable hashcode*
152 [ assoc-hashcode ] [ nip assoc-size ] if
153 ] recursive-hashcode ;