1 USING: combinators.short-circuit sequences io.files
\r
2 io.encodings.ascii kernel values splitting accessors math.parser
\r
3 ascii io assocs strings math namespaces make sorting combinators
\r
4 math.order arrays unicode.normalize unicode.data locals
\r
5 unicode.syntax macros sequences.deep words unicode.breaks
\r
7 IN: unicode.collation
\r
12 TUPLE: weight primary secondary tertiary ignorable? ;
\r
14 : parse-weight ( string -- weight )
\r
15 "]" split but-last [
\r
16 weight new swap rest unclip CHAR: * = swapd >>ignorable?
\r
17 swap "." split first3 [ hex> ] tri@
\r
18 [ >>primary ] [ >>secondary ] [ >>tertiary ] tri*
\r
21 : parse-line ( line -- code-poing weight )
\r
22 ";" split1 [ [ blank? ] trim ] bi@
\r
23 [ " " split [ hex> ] "" map-as ] [ parse-weight ] bi* ;
\r
25 : parse-ducet ( stream -- ducet )
\r
26 lines filter-comments
\r
27 [ parse-line ] H{ } map>assoc ;
\r
29 "resource:basis/unicode/collation/allkeys.txt"
\r
30 ascii <file-reader> parse-ducet to: ducet
\r
32 ! Fix up table for long contractions
\r
33 : help-one ( assoc key -- )
\r
34 ! Need to be more general? Not for DUCET, apparently
\r
35 2 head 2dup swap key? [ 2drop ] [
\r
36 [ [ 1string swap at ] with { } map-as concat ]
\r
40 : insert-helpers ( assoc -- )
\r
41 dup keys [ length 3 >= ] filter
\r
42 [ help-one ] with each ;
\r
44 ducet insert-helpers
\r
46 : base ( char -- base )
\r
48 { [ dup HEX: 3400 HEX: 4DB5 between? ] [ drop HEX: FB80 ] } ! Extension A
\r
49 { [ dup HEX: 20000 HEX: 2A6D6 between? ] [ drop HEX: FB80 ] } ! Extension B
\r
50 { [ dup HEX: 4E00 HEX: 9FC3 between? ] [ drop HEX: FB40 ] } ! CJK
\r
51 [ drop HEX: FBC0 ] ! Other
\r
54 : AAAA ( char -- weight )
\r
55 [ base ] [ -15 shift ] bi + HEX: 20 2 f weight boa ;
\r
57 : BBBB ( char -- weight )
\r
58 HEX: 7FFF bitand HEX: 8000 bitor 0 0 f weight boa ;
\r
60 : illegal? ( char -- ? )
\r
61 { [ "Noncharacter_Code_Point" property? ] [ category "Cs" = ] } 1|| ;
\r
63 : derive-weight ( char -- weights )
\r
66 [ [ AAAA ] [ BBBB ] bi 2array ] if ;
\r
69 building get empty? [ 0 ] [ building get peek peek ] if ;
\r
71 : blocked? ( char -- ? )
\r
73 last combining-class =
\r
74 ] [ last combining-class ] if* ;
\r
76 : possible-bases ( -- slice-of-building )
\r
77 building get dup [ first combining-class not ] find-last
\r
78 drop [ 0 ] unless* tail-slice ;
\r
80 :: ?combine ( char slice i -- ? )
\r
81 [let | str [ i slice nth char suffix ] |
\r
83 [ str i slice set-nth ] when
\r
87 dup blocked? [ 1string , ] [
\r
88 dup possible-bases dup length
\r
89 [ ?combine ] with with contains?
\r
90 [ drop ] [ 1string , ] if
\r
93 : string>graphemes ( string -- graphemes )
\r
94 [ [ add ] each ] { } make ;
\r
96 : graphemes>weights ( graphemes -- weights )
\r
98 dup weight? [ 1array ] ! From tailoring
\r
99 [ dup ducet at [ ] [ derive-weight ] ?if ] if
\r
100 ] { } map-as concat ;
\r
102 : append-weights ( weights quot -- )
\r
103 swap [ ignorable?>> not ] filter
\r
104 swap map [ zero? not ] filter % 0 , ;
\r
106 : variable-weight ( weight -- )
\r
107 dup ignorable?>> [ primary>> ] [ drop HEX: FFFF ] if , ;
\r
109 : weights>bytes ( weights -- byte-array )
\r
112 [ [ primary>> ] append-weights ]
\r
113 [ [ secondary>> ] append-weights ]
\r
114 [ [ tertiary>> ] append-weights ]
\r
115 [ [ variable-weight ] each ]
\r
120 : completely-ignorable? ( weight -- ? )
\r
121 [ primary>> ] [ secondary>> ] [ tertiary>> ] tri
\r
122 [ zero? ] tri@ and and ;
\r
124 : filter-ignorable ( weights -- weights' )
\r
126 tuck primary>> zero? and
\r
127 [ swap ignorable?>> or ]
\r
128 [ swap completely-ignorable? or not ] 2bi
\r
131 : collation-key ( string -- key )
\r
132 nfd string>graphemes graphemes>weights
\r
133 filter-ignorable weights>bytes ;
\r
136 : insensitive= ( str1 str2 levels-removed -- ? )
\r
138 swap collation-key swap
\r
139 [ [ 0 = not ] trim-right but-last ] times
\r
143 : primary= ( str1 str2 -- ? )
\r
146 : secondary= ( str1 str2 -- ? )
\r
149 : tertiary= ( str1 str2 -- ? )
\r
152 : quaternary= ( str1 str2 -- ? )
\r
156 : w/collation-key ( str -- {str,key} )
\r
157 [ collation-key ] keep 2array ;
\r
160 : sort-strings ( strings -- sorted )
\r
161 [ w/collation-key ] map
\r
162 natural-sort values ;
\r
164 : string<=> ( str1 str2 -- <=> )
\r
165 [ w/collation-key ] compare ;
\r