! Copyright (C) 2008, 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit assocs math kernel sequences
-io.files hashtables quotations splitting grouping arrays io
-math.parser hash2 math.order byte-arrays namespaces
-compiler.units parser io.encodings.ascii values interval-maps
-ascii sets combinators locals math.ranges sorting make
-strings.parser io.encodings.utf8 memoize simple-flat-file ;
-FROM: namespaces => set ;
+USING: arrays ascii assocs byte-arrays combinators
+combinators.short-circuit grouping hashtables interval-sets
+io.encodings.utf8 io.files kernel make math math.bitwise
+math.order math.parser ranges namespaces sequences
+sets simple-flat-file sorting splitting strings.parser ;
IN: unicode.data
<PRIVATE
-VALUE: simple-lower
-VALUE: simple-upper
-VALUE: simple-title
-VALUE: canonical-map
-VALUE: combine-map
-VALUE: class-map
-VALUE: compatibility-map
-VALUE: category-map
-VALUE: special-casing
-VALUE: properties
+CONSTANT: simple-lower H{ }
+CONSTANT: simple-upper H{ }
+CONSTANT: simple-title H{ }
+CONSTANT: canonical-map H{ }
+CONSTANT: combine-map H{ }
+CONSTANT: class-map H{ }
+CONSTANT: compatibility-map H{ }
+CONSTANT: category-map BV{ }
+CONSTANT: special-casing H{ }
+CONSTANT: properties H{ }
+
+: >2ch ( a b -- c ) [ 21 shift ] dip + ; inline
+: 2ch> ( c -- a b ) [ -21 shift ] [ 21 on-bits mask ] bi ; inline
PRIVATE>
-VALUE: name-map
+CONSTANT: name-map H{ }
: canonical-entry ( char -- seq ) canonical-map at ; inline
-: combine-chars ( a b -- char/f ) combine-map hash2 ; inline
: compatibility-entry ( char -- seq ) compatibility-map at ; inline
+: combine-chars ( a b -- char/f ) >2ch combine-map at ; inline
: combining-class ( char -- n ) class-map at ; inline
: non-starter? ( char -- ? ) combining-class { 0 f } member? not ; inline
-: name>char ( name -- char ) name-map at ; inline
-: char>name ( char -- name ) name-map value-at ; inline
-: property? ( char property -- ? ) properties at interval-key? ; inline
-: ch>lower ( ch -- lower ) simple-lower ?at drop ; inline
-: ch>upper ( ch -- upper ) simple-upper ?at drop ; inline
-: ch>title ( ch -- title ) simple-title ?at drop ; inline
+: property ( property -- interval-map ) properties at ; foldable
+: property? ( char property -- ? ) property interval-in? ; inline
: special-case ( ch -- casing-tuple ) special-casing at ; inline
! For non-existent characters, use Cn
-CONSTANT: categories
- { "Cn"
- "Lu" "Ll" "Lt" "Lm" "Lo"
- "Mn" "Mc" "Me"
- "Nd" "Nl" "No"
- "Pc" "Pd" "Ps" "Pe" "Pi" "Pf" "Po"
- "Sm" "Sc" "Sk" "So"
- "Zs" "Zl" "Zp"
- "Cc" "Cf" "Cs" "Co" }
+CONSTANT: categories {
+ "Cn"
+ "Lu" "Ll" "Lt" "Lm" "Lo"
+ "Mn" "Mc" "Me"
+ "Nd" "Nl" "No"
+ "Pc" "Pd" "Ps" "Pe" "Pi" "Pf" "Po"
+ "Sm" "Sc" "Sk" "So"
+ "Zs" "Zl" "Zp"
+ "Cc" "Cf" "Cs" "Co"
+}
<PRIVATE
MEMO: categories-map ( -- hashtable )
- categories <enum> [ swap ] H{ } assoc-map-as ;
+ categories H{ } zip-index-as ;
-CONSTANT: num-chars HEX: 2FA1E
+CONSTANT: NUM-CHARS 0x2FA1E
PRIVATE>
-: category# ( char -- n )
+: category-num ( char -- n )
! There are a few characters that should be Cn
! that this gives Cf or Mn
! Cf = 26; Mn = 5; Cn = 29
! Use a compressed array instead?
dup category-map ?nth [ ] [
- dup HEX: E0001 HEX: E007F between?
+ dup 0xE0001 0xE007F between?
[ drop 26 ] [
- HEX: E0100 HEX: E01EF between? 5 29 ?
+ 0xE0100 0xE01EF between? 5 29 ?
] if
- ] ?if ;
+ ] ?if ; inline
: category ( char -- category )
- category# categories nth ;
+ category-num categories nth ;
<PRIVATE
! Loading data from UnicodeData.txt
-: load-data ( -- data )
- "vocab:unicode/data/UnicodeData.txt" data ;
+: load-unicode-data ( -- data )
+ "vocab:unicode/UCD/UnicodeData.txt" load-data-file ;
: (process-data) ( index data -- newdata )
[ [ nth ] keep first swap ] with { } map>assoc
[ [ hex> ] dip ] assoc-map ;
: process-data ( index data -- hash )
- (process-data) [ hex> ] assoc-map [ nip ] assoc-filter >hashtable ;
+ (process-data) [ hex> ] assoc-map [ nip ] H{ } assoc-filter-as ;
: (chain-decomposed) ( hash value -- newvalue )
[
- 2dup swap at
+ 2dup of
[ (chain-decomposed) ] [ 1array nip ] ?if
] with map concat ;
: (process-decomposed) ( data -- alist )
5 swap (process-data)
- [ " " split [ hex> ] map ] assoc-map ;
+ [ split-words [ hex> ] map ] assoc-map ;
: exclusions-file ( -- filename )
- "vocab:unicode/data/CompositionExclusions.txt" ;
+ "vocab:unicode/UCD/CompositionExclusions.txt" ;
: exclusions ( -- set )
exclusions-file utf8 file-lines
- [ "#" split1 drop [ blank? ] trim-tail hex> ] map
- [ 0 = not ] filter ;
+ [ "#" split1 drop [ ascii:blank? ] trim-tail hex> ] map
+ 0 swap remove ;
+
+: unique ( seq -- assoc )
+ [ dup ] H{ } map>assoc ;
: remove-exclusions ( alist -- alist )
- exclusions [ dup ] H{ } map>assoc assoc-diff ;
+ exclusions unique assoc-diff ;
-: process-canonical ( data -- hash2 hash )
+: process-canonical ( data -- hash hash )
(process-decomposed) [ first* ] filter
[
[ second length 2 = ] filter remove-exclusions
- ! using 1009 as the size, the maximum load is 4
- [ first2 first2 rot 3array ] map 1009 alist>hash2
+ [ first2 >2ch swap ] H{ } assoc-map-as
] [ >hashtable chain-decomposed ] bi ;
: process-compatibility ( data -- hash )
(process-decomposed)
[ dup first* [ first2 rest 2array ] unless ] map
- [ second empty? not ] filter
+ [ second empty? ] reject
>hashtable chain-decomposed ;
: process-combining ( data -- hash )
3 swap (process-data)
[ string>number ] assoc-map
- [ nip zero? not ] assoc-filter
+ [ nip zero? ] assoc-reject
>hashtable ;
! the maximum unicode char in the first 3 planes
-: ?set-nth ( val index seq -- )
- 2dup bounds-check? [ set-nth ] [ 3drop ] if ;
-
:: fill-ranges ( table -- table )
name-map sort-values keys
[ { [ "first>" tail? ] [ "last>" tail? ] } 1|| ] filter
2 group [
- [ name>char ] bi@ [ [a,b] ] [ table ?nth ] bi
+ [ name-map at ] bi@ [ [a..b] ] [ table ?nth ] bi
[ swap table ?set-nth ] curry each
] assoc-each table ;
:: process-category ( data -- category-listing )
- num-chars <byte-array> :> table
+ NUM-CHARS <byte-array> :> table
2 data (process-data) [| char cat |
cat categories-map at char table ?set-nth
] assoc-each table fill-ranges ;
: process-names ( data -- names-hash )
1 swap (process-data) [
- >lower { { CHAR: \s CHAR: - } } substitute swap
+ >lower H{ { CHAR: \s CHAR: - } } substitute swap
] H{ } assoc-map-as ;
: multihex ( hexstring -- string )
- " " split [ hex> ] map sift ;
+ split-words [ hex> ] map sift ;
PRIVATE>
: set-code-point ( seq -- )
4 head [ multihex ] map first4
- <code-point> swap first set ;
+ <code-point> swap first ,, ;
-! Extra properties
-: parse-properties ( -- {{[a,b],prop}} )
- "vocab:unicode/data/PropList.txt" data [
+! Extra properties {{[a,b],prop}}
+: parse-properties ( -- assoc )
+ "vocab:unicode/UCD/PropList.txt" load-data-file [
[
".." split1 [ dup ] unless*
[ hex> ] bi@ 2array
! Special casing data
: load-special-casing ( -- special-casing )
- "vocab:unicode/data/SpecialCasing.txt" data
+ "vocab:unicode/UCD/SpecialCasing.txt" load-data-file
[ length 5 = ] filter
- [ [ set-code-point ] each ] H{ } make-assoc ;
-
-load-data {
- [ process-names to: name-map ]
- [ 13 swap process-data to: simple-lower ]
- [ 12 swap process-data to: simple-upper ]
- [ 14 swap process-data simple-upper assoc-union to: simple-title ]
- [ process-combining to: class-map ]
- [ process-canonical to: canonical-map to: combine-map ]
- [ process-compatibility to: compatibility-map ]
- [ process-category to: category-map ]
+ [ [ set-code-point ] each ] H{ } make ;
+
+load-unicode-data {
+ [ process-names name-map swap assoc-union! drop ]
+ [ 13 swap process-data simple-lower swap assoc-union! drop ]
+ [ 12 swap process-data simple-upper swap assoc-union! drop ]
+ [ 14 swap process-data simple-upper assoc-union simple-title swap assoc-union! drop ]
+ [ process-combining class-map swap assoc-union! drop ]
+ [ process-canonical canonical-map swap assoc-union! drop combine-map swap assoc-union! drop ]
+ [ process-compatibility compatibility-map swap assoc-union! drop ]
+ [ process-category category-map push-all ]
} cleave
-: postprocess-class ( -- )
- combine-map [ values ] map concat
- [ combining-class not ] filter
- [ 0 swap class-map set-at ] each ;
+combine-map keys [ 2ch> nip ] map
+[ class-map at ] reject
+[ 0 swap class-map set-at ] each
-postprocess-class
+load-special-casing special-casing swap assoc-union! drop
-load-special-casing to: special-casing
+load-properties properties swap assoc-union! drop
+
+PRIVATE>
-load-properties to: properties
+ERROR: invalid-unicode-character name ;
-[ name>char [ "Invalid character" throw ] unless* ]
-name>char-hook set-global
+[
+ name-map ?at [ invalid-unicode-character ] unless
+] name>char-hook set-global
projects / factor.git / blobdiff