1 ! Copyright (C) 2008 Daniel Ehrenberg.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: sequences io.files io.encodings.ascii kernel splitting
4 accessors math.parser ascii io assocs strings math namespaces make
5 sorting combinators math.order arrays unicode.normalize unicode.data
6 locals macros sequences.deep words unicode.breaks quotations
7 combinators.short-circuit simple-flat-file ;
13 TUPLE: weight primary secondary tertiary ignorable? ;
15 : parse-weight ( string -- weight )
17 weight new swap rest unclip CHAR: * = swapd >>ignorable?
18 swap "." split first3 [ hex> ] tri@
19 [ >>primary ] [ >>secondary ] [ >>tertiary ] tri*
22 : parse-keys ( string -- chars )
23 " " split [ hex> ] "" map-as ;
25 : parse-ducet ( file -- ducet )
26 data [ [ parse-keys ] [ parse-weight ] bi* ] H{ } assoc-map-as ;
28 "vocab:unicode/collation/allkeys.txt" parse-ducet ducet set-global
30 ! Fix up table for long contractions
31 : help-one ( assoc key -- )
32 ! Need to be more general? Not for DUCET, apparently
33 2 head 2dup swap key? [ 2drop ] [
34 [ [ 1string of ] with { } map-as concat ]
38 : insert-helpers ( assoc -- )
39 dup keys [ length 3 >= ] filter
40 [ help-one ] with each ;
42 ducet get-global insert-helpers
44 : base ( char -- base )
46 { [ dup 0x3400 0x4DB5 between? ] [ drop 0xFB80 ] } ! Extension A
47 { [ dup 0x20000 0x2A6D6 between? ] [ drop 0xFB80 ] } ! Extension B
48 { [ dup 0x4E00 0x9FC3 between? ] [ drop 0xFB40 ] } ! CJK
49 [ drop 0xFBC0 ] ! Other
52 : AAAA ( char -- weight )
53 [ base ] [ -15 shift ] bi + 0x20 2 f weight boa ;
55 : BBBB ( char -- weight )
56 0x7FFF bitand 0x8000 bitor 0 0 f weight boa ;
58 : illegal? ( char -- ? )
59 { [ "Noncharacter_Code_Point" property? ] [ category "Cs" = ] } 1|| ;
61 : derive-weight ( char -- weights )
64 [ [ AAAA ] [ BBBB ] bi 2array ] if ;
66 : building-last ( -- char )
67 building get empty? [ 0 ] [ building get last last ] if ;
69 : blocked? ( char -- ? )
70 combining-class dup { 0 f } member?
71 [ drop building-last non-starter? ]
72 [ building-last combining-class = ] if ;
74 : possible-bases ( -- slice-of-building )
75 building get dup [ first non-starter? not ] find-last
76 drop [ 0 ] unless* tail-slice ;
78 :: ?combine ( char slice i -- ? )
79 i slice nth char suffix :> str
80 str ducet get-global key? dup
81 [ str i slice set-nth ] when ;
84 dup blocked? [ 1string , ] [
85 dup possible-bases dup length iota
86 [ ?combine ] 2with any?
87 [ drop ] [ 1string , ] if
90 : string>graphemes ( string -- graphemes )
91 [ [ add ] each ] { } make ;
93 : graphemes>weights ( graphemes -- weights )
95 dup weight? [ 1array ] ! From tailoring
96 [ dup ducet get-global at [ ] [ derive-weight ] ?if ] if
99 : append-weights ( weights quot -- )
100 [ [ ignorable?>> ] reject ] dip
101 map [ zero? ] reject % 0 , ; inline
103 : variable-weight ( weight -- )
104 dup ignorable?>> [ primary>> ] [ drop 0xFFFF ] if , ;
106 : weights>bytes ( weights -- byte-array )
109 [ [ primary>> ] append-weights ]
110 [ [ secondary>> ] append-weights ]
111 [ [ tertiary>> ] append-weights ]
112 [ [ variable-weight ] each ]
117 : completely-ignorable? ( weight -- ? )
118 [ primary>> ] [ secondary>> ] [ tertiary>> ] tri
119 [ zero? ] tri@ and and ;
121 : filter-ignorable ( weights -- weights' )
123 [ nip ] [ primary>> zero? and ] 2bi
124 [ swap ignorable?>> or ]
125 [ swap completely-ignorable? or not ] 2bi
128 : collation-key ( string -- key )
129 nfd string>graphemes graphemes>weights
130 filter-ignorable weights>bytes ;
133 : insensitive= ( str1 str2 levels-removed -- ? )
135 [ collation-key ] dip
136 [ [ 0 = not ] trim-tail but-last ] times
140 : primary= ( str1 str2 -- ? )
143 : secondary= ( str1 str2 -- ? )
146 : tertiary= ( str1 str2 -- ? )
149 : quaternary= ( str1 str2 -- ? )
152 : w/collation-key ( str -- {str,key} )
153 [ collation-key ] keep 2array ;
155 : sort-strings ( strings -- sorted )
156 [ w/collation-key ] map natural-sort values ;
158 : string<=> ( str1 str2 -- <=> )
159 [ w/collation-key ] compare ;