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 math.order byte-arrays namespaces math.bitwise
6 compiler.units parser io.encodings.ascii interval-maps
7 ascii sets combinators locals math.ranges sorting make
8 strings.parser io.encodings.utf8 memoize simple-flat-file ;
13 CONSTANT: simple-lower H{ }
14 CONSTANT: simple-upper H{ }
15 CONSTANT: simple-title H{ }
16 CONSTANT: canonical-map H{ }
17 CONSTANT: combine-map H{ }
18 CONSTANT: class-map H{ }
19 CONSTANT: compatibility-map H{ }
20 SYMBOL: category-map ! B{ }
21 CONSTANT: special-casing H{ }
22 CONSTANT: properties H{ }
24 : >2ch ( a b -- c ) [ 21 shift ] dip + ;
25 : 2ch> ( c -- a b ) [ -21 shift ] [ 21 on-bits mask ] bi ;
29 CONSTANT: name-map H{ }
31 : canonical-entry ( char -- seq ) canonical-map at ; inline
32 : combine-chars ( a b -- char/f ) >2ch combine-map at ; inline
33 : compatibility-entry ( char -- seq ) compatibility-map at ; inline
34 : combining-class ( char -- n ) class-map at ; inline
35 : non-starter? ( char -- ? ) combining-class { 0 f } member? not ; inline
36 : name>char ( name -- char ) name-map at ; inline
37 : char>name ( char -- name ) name-map value-at ; inline
38 : property? ( char property -- ? ) properties at interval-key? ; inline
39 : ch>lower ( ch -- lower ) simple-lower ?at drop ; inline
40 : ch>upper ( ch -- upper ) simple-upper ?at drop ; inline
41 : ch>title ( ch -- title ) simple-title ?at drop ; inline
42 : special-case ( ch -- casing-tuple ) special-casing at ; inline
44 ! For non-existent characters, use Cn
47 "Lu" "Ll" "Lt" "Lm" "Lo"
50 "Pc" "Pd" "Ps" "Pe" "Pi" "Pf" "Po"
57 MEMO: categories-map ( -- hashtable )
58 categories <enum> [ swap ] H{ } assoc-map-as ;
60 CONSTANT: num-chars 0x2FA1E
64 : category# ( char -- n )
65 ! There are a few characters that should be Cn
66 ! that this gives Cf or Mn
67 ! Cf = 26; Mn = 5; Cn = 29
68 ! Use a compressed array instead?
69 dup category-map get-global ?nth [ ] [
70 dup 0xE0001 0xE007F between?
72 0xE0100 0xE01EF between? 5 29 ?
76 : category ( char -- category )
77 category# categories nth ;
81 ! Loading data from UnicodeData.txt
83 : load-data ( -- data )
84 "vocab:unicode/data/UnicodeData.txt" data ;
86 : (process-data) ( index data -- newdata )
87 [ [ nth ] keep first swap ] with { } map>assoc
88 [ [ hex> ] dip ] assoc-map ;
90 : process-data ( index data -- hash )
91 (process-data) [ hex> ] assoc-map [ nip ] H{ } assoc-filter-as ;
93 : (chain-decomposed) ( hash value -- newvalue )
96 [ (chain-decomposed) ] [ 1array nip ] ?if
99 : chain-decomposed ( hash -- newhash )
100 dup [ swap (chain-decomposed) ] curry assoc-map ;
102 : first* ( seq -- ? )
103 second { [ empty? ] [ first ] } 1|| ;
105 : (process-decomposed) ( data -- alist )
106 5 swap (process-data)
107 [ " " split [ hex> ] map ] assoc-map ;
109 : exclusions-file ( -- filename )
110 "vocab:unicode/data/CompositionExclusions.txt" ;
112 : exclusions ( -- set )
113 exclusions-file utf8 file-lines
114 [ "#" split1 drop [ blank? ] trim-tail hex> ] map
117 : remove-exclusions ( alist -- alist )
118 exclusions unique assoc-diff ;
120 : process-canonical ( data -- hash hash )
121 (process-decomposed) [ first* ] filter
123 [ second length 2 = ] filter remove-exclusions
124 [ first2 >2ch swap ] H{ } assoc-map-as
125 ] [ >hashtable chain-decomposed ] bi ;
127 : process-compatibility ( data -- hash )
129 [ dup first* [ first2 rest 2array ] unless ] map
130 [ second empty? not ] filter
131 >hashtable chain-decomposed ;
133 : process-combining ( data -- hash )
134 3 swap (process-data)
135 [ string>number ] assoc-map
136 [ nip zero? not ] assoc-filter
139 ! the maximum unicode char in the first 3 planes
141 : ?set-nth ( elt n seq -- )
142 2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ; inline
144 :: fill-ranges ( table -- table )
145 name-map sort-values keys
146 [ { [ "first>" tail? ] [ "last>" tail? ] } 1|| ] filter
148 [ name>char ] bi@ [ [a,b] ] [ table ?nth ] bi
149 [ swap table ?set-nth ] curry each
152 :: process-category ( data -- category-listing )
153 num-chars <byte-array> :> table
154 2 data (process-data) [| char cat |
155 cat categories-map at char table ?set-nth
156 ] assoc-each table fill-ranges ;
158 : process-names ( data -- names-hash )
159 1 swap (process-data) [
160 >lower H{ { CHAR: \s CHAR: - } } substitute swap
161 ] H{ } assoc-map-as ;
163 : multihex ( hexstring -- string )
164 " " split [ hex> ] map sift ;
168 TUPLE: code-point lower title upper ;
170 C: <code-point> code-point
174 : set-code-point ( seq -- )
175 4 head [ multihex ] map first4
176 <code-point> swap first ,, ;
179 : parse-properties ( -- {{[a,b],prop}} )
180 "vocab:unicode/data/PropList.txt" data [
182 ".." split1 [ dup ] unless*
187 : properties>intervals ( properties -- assoc[str,interval] )
188 dup values members [ f ] H{ } map>assoc
189 [ [ push-at ] curry assoc-each ] keep
190 [ <interval-set> ] assoc-map ;
192 : load-properties ( -- assoc )
193 parse-properties properties>intervals ;
195 ! Special casing data
196 : load-special-casing ( -- special-casing )
197 "vocab:unicode/data/SpecialCasing.txt" data
198 [ length 5 = ] filter
199 [ [ set-code-point ] each ] H{ } make ;
202 [ process-names name-map swap assoc-union! drop ]
203 [ 13 swap process-data simple-lower swap assoc-union! drop ]
204 [ 12 swap process-data simple-upper swap assoc-union! drop ]
205 [ 14 swap process-data simple-upper assoc-union simple-title swap assoc-union! drop ]
206 [ process-combining class-map swap assoc-union! drop ]
207 [ process-canonical canonical-map swap assoc-union! drop combine-map swap assoc-union! drop ]
208 [ process-compatibility compatibility-map swap assoc-union! drop ]
209 [ process-category category-map set-global ]
212 combine-map keys [ 2ch> nip ] map
213 [ combining-class not ] filter
214 [ 0 swap class-map set-at ] each
216 load-special-casing special-casing swap assoc-union! drop
218 load-properties properties swap assoc-union! drop
220 [ name>char [ "Invalid character" throw ] unless* ]
221 name>char-hook set-global