1 ! Copyright (C) 2008, 2009 Daniel Ehrenberg.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: combinators.short-circuit assocs math kernel sequences
4 io.files hashtables quotations splitting grouping arrays io
5 math.parser hash2 math.order byte-arrays namespaces
6 compiler.units parser io.encodings.ascii values interval-maps
7 ascii sets combinators locals math.ranges sorting make
8 strings.parser io.encodings.utf8 memoize simple-flat-file ;
19 VALUE: compatibility-map
28 : canonical-entry ( char -- seq ) canonical-map at ; inline
29 : combine-chars ( a b -- char/f ) combine-map hash2 ; inline
30 : compatibility-entry ( char -- seq ) compatibility-map at ; inline
31 : combining-class ( char -- n ) class-map at ; inline
32 : non-starter? ( char -- ? ) combining-class { 0 f } member? not ; inline
33 : name>char ( name -- char ) name-map at ; inline
34 : char>name ( char -- name ) name-map value-at ; inline
35 : property? ( char property -- ? ) properties at interval-key? ; inline
36 : ch>lower ( ch -- lower ) simple-lower ?at drop ; inline
37 : ch>upper ( ch -- upper ) simple-upper ?at drop ; inline
38 : ch>title ( ch -- title ) simple-title ?at drop ; inline
39 : special-case ( ch -- casing-tuple ) special-casing at ; inline
41 ! For non-existent characters, use Cn
44 "Lu" "Ll" "Lt" "Lm" "Lo"
47 "Pc" "Pd" "Ps" "Pe" "Pi" "Pf" "Po"
54 MEMO: categories-map ( -- hashtable )
55 categories <enum> [ swap ] H{ } assoc-map-as ;
57 CONSTANT: num-chars HEX: 2FA1E
61 : category# ( char -- n )
62 ! There are a few characters that should be Cn
63 ! that this gives Cf or Mn
64 ! Cf = 26; Mn = 5; Cn = 29
65 ! Use a compressed array instead?
66 dup category-map ?nth [ ] [
67 dup HEX: E0001 HEX: E007F between?
69 HEX: E0100 HEX: E01EF between? 5 29 ?
73 : category ( char -- category )
74 category# categories nth ;
78 ! Loading data from UnicodeData.txt
80 : load-data ( -- data )
81 "vocab:unicode/data/UnicodeData.txt" data ;
83 : (process-data) ( index data -- newdata )
84 [ [ nth ] keep first swap ] with { } map>assoc
85 [ [ hex> ] dip ] assoc-map ;
87 : process-data ( index data -- hash )
88 (process-data) [ hex> ] assoc-map [ nip ] assoc-filter >hashtable ;
90 : (chain-decomposed) ( hash value -- newvalue )
93 [ (chain-decomposed) ] [ 1array nip ] ?if
96 : chain-decomposed ( hash -- newhash )
97 dup [ swap (chain-decomposed) ] curry assoc-map ;
100 second { [ empty? ] [ first ] } 1|| ;
102 : (process-decomposed) ( data -- alist )
103 5 swap (process-data)
104 [ " " split [ hex> ] map ] assoc-map ;
106 : exclusions-file ( -- filename )
107 "vocab:unicode/data/CompositionExclusions.txt" ;
109 : exclusions ( -- set )
110 exclusions-file utf8 file-lines
111 [ "#" split1 drop [ blank? ] trim-tail hex> ] map harvest ;
113 : remove-exclusions ( alist -- alist )
114 exclusions [ dup ] H{ } map>assoc assoc-diff ;
116 : process-canonical ( data -- hash2 hash )
117 (process-decomposed) [ first* ] filter
119 [ second length 2 = ] filter remove-exclusions
120 ! using 1009 as the size, the maximum load is 4
121 [ first2 first2 rot 3array ] map 1009 alist>hash2
122 ] [ >hashtable chain-decomposed ] bi ;
124 : process-compatibility ( data -- hash )
126 [ dup first* [ first2 rest 2array ] unless ] map
127 [ second empty? not ] filter
128 >hashtable chain-decomposed ;
130 : process-combining ( data -- hash )
131 3 swap (process-data)
132 [ string>number ] assoc-map
133 [ nip zero? not ] assoc-filter
136 ! the maximum unicode char in the first 3 planes
138 : ?set-nth ( val index seq -- )
139 2dup bounds-check? [ set-nth ] [ 3drop ] if ;
141 :: fill-ranges ( table -- table )
142 name-map >alist sort-values keys
143 [ { [ "first>" tail? ] [ "last>" tail? ] } 1|| ] filter
145 [ name>char ] bi@ [ [a,b] ] [ table ?nth ] bi
146 [ swap table ?set-nth ] curry each
149 :: process-category ( data -- category-listing )
150 num-chars <byte-array> :> table
151 2 data (process-data) [| char cat |
152 cat categories-map at char table ?set-nth
153 ] assoc-each table fill-ranges ;
155 : process-names ( data -- names-hash )
156 1 swap (process-data) [
157 >lower { { CHAR: \s CHAR: - } } substitute swap
158 ] H{ } assoc-map-as ;
160 : multihex ( hexstring -- string )
161 " " split [ hex> ] map sift ;
165 TUPLE: code-point lower title upper ;
167 C: <code-point> code-point
171 : set-code-point ( seq -- )
172 4 head [ multihex ] map first4
173 <code-point> swap first set ;
176 : parse-properties ( -- {{[a,b],prop}} )
177 "vocab:unicode/data/PropList.txt" data [
179 ".." split1 [ dup ] unless*
184 : properties>intervals ( properties -- assoc[str,interval] )
185 dup values prune [ f ] H{ } map>assoc
186 [ [ push-at ] curry assoc-each ] keep
187 [ <interval-set> ] assoc-map ;
189 : load-properties ( -- assoc )
190 parse-properties properties>intervals ;
192 ! Special casing data
193 : load-special-casing ( -- special-casing )
194 "vocab:unicode/data/SpecialCasing.txt" data
195 [ length 5 = ] filter
196 [ [ set-code-point ] each ] H{ } make-assoc ;
199 [ process-names to: name-map ]
200 [ 13 swap process-data to: simple-lower ]
201 [ 12 swap process-data to: simple-upper ]
202 [ 14 swap process-data simple-upper assoc-union to: simple-title ]
203 [ process-combining to: class-map ]
204 [ process-canonical to: canonical-map to: combine-map ]
205 [ process-compatibility to: compatibility-map ]
206 [ process-category to: category-map ]
209 : postprocess-class ( -- )
210 combine-map [ [ second ] map ] map concat
211 [ combining-class not ] filter
212 [ 0 swap class-map set-at ] each ;
216 load-special-casing to: special-casing
218 load-properties to: properties
220 [ name>char [ "Invalid character" throw ] unless* ]
221 name>char-hook set-global