-! Copyright (C) 2008 Daniel Ehrenberg.
+! 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 words namespaces words
+math.parser math.order byte-arrays namespaces math.bitwise
compiler.units parser io.encodings.ascii values interval-maps
ascii sets combinators locals math.ranges sorting make
-strings.parser io.encodings.utf8 ;
+strings.parser io.encodings.utf8 memoize simple-flat-file ;
+FROM: namespaces => set ;
IN: unicode.data
+<PRIVATE
+
VALUE: simple-lower
VALUE: simple-upper
VALUE: simple-title
VALUE: class-map
VALUE: compatibility-map
VALUE: category-map
-VALUE: name-map
VALUE: special-casing
VALUE: properties
-: canonical-entry ( char -- seq ) canonical-map at ;
-: combine-chars ( a b -- char/f ) combine-map hash2 ;
-: compatibility-entry ( char -- seq ) compatibility-map at ;
-: combining-class ( char -- n ) class-map at ;
-: non-starter? ( char -- ? ) combining-class { 0 f } member? not ;
-: name>char ( name -- char ) name-map at ;
-: char>name ( char -- name ) name-map value-at ;
-: property? ( char property -- ? ) properties at interval-key? ;
+: >2ch ( a b -- c ) [ 21 shift ] dip + ;
+: 2ch> ( c -- a b ) [ -21 shift ] [ 21 on-bits mask ] bi ;
-! Loading data from UnicodeData.txt
+PRIVATE>
-: split-; ( line -- array )
- ";" split [ [ blank? ] trim ] map ;
+VALUE: name-map
-: data ( filename -- data )
- ascii file-lines [ split-; ] map ;
+: canonical-entry ( char -- seq ) canonical-map at ; inline
+: combine-chars ( a b -- char/f ) >2ch combine-map at ; inline
+: compatibility-entry ( char -- seq ) compatibility-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
+: 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" }
+
+<PRIVATE
+
+MEMO: categories-map ( -- hashtable )
+ categories <enum> [ swap ] H{ } assoc-map-as ;
+
+CONSTANT: num-chars 0x2FA1E
+
+PRIVATE>
+
+: category# ( 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 0xE0001 0xE007F between?
+ [ drop 26 ] [
+ 0xE0100 0xE01EF between? 5 29 ?
+ ] if
+ ] ?if ;
+
+: category ( char -- category )
+ category# categories nth ;
+
+<PRIVATE
+
+! Loading data from UnicodeData.txt
: load-data ( -- data )
"vocab:unicode/data/UnicodeData.txt" data ;
-: filter-comments ( lines -- lines )
- [ "#@" split first ] map harvest ;
-
: (process-data) ( index data -- newdata )
- filter-comments
[ [ 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 )
[
: exclusions ( -- set )
exclusions-file utf8 file-lines
- [ "#" split1 drop [ blank? ] trim-tail hex> ] map harvest ;
+ [ "#" split1 drop [ blank? ] trim-tail hex> ] map
+ [ 0 = not ] filter ;
: 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 )
[ nip zero? not ] assoc-filter
>hashtable ;
-: categories ( -- names )
- ! For non-existent characters, use Cn
- { "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" } ;
-
-: num-chars HEX: 2FA1E ;
-
! 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 >alist sort-values keys
+ name-map sort-values keys
[ { [ "first>" tail? ] [ "last>" tail? ] } 1|| ] filter
2 group [
[ name>char ] bi@ [ [a,b] ] [ table ?nth ] bi
] assoc-each table ;
:: process-category ( data -- category-listing )
- [let | table [ num-chars <byte-array> ] |
- 2 data (process-data) [| char cat |
- cat categories index char table ?set-nth
- ] assoc-each table fill-ranges ] ;
+ 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) [
: multihex ( hexstring -- string )
" " split [ hex> ] map sift ;
+PRIVATE>
+
TUPLE: code-point lower title upper ;
C: <code-point> code-point
+<PRIVATE
+
: set-code-point ( seq -- )
4 head [ multihex ] map first4
<code-point> swap first set ;
! Extra properties
-: properties-lines ( -- lines )
- "vocab:unicode/data/PropList.txt"
- ascii file-lines ;
-
: parse-properties ( -- {{[a,b],prop}} )
- properties-lines filter-comments [
- split-; first2
- [ ".." split1 [ dup ] unless* [ hex> ] bi@ 2array ] dip
- ] { } map>assoc ;
+ "vocab:unicode/data/PropList.txt" data [
+ [
+ ".." split1 [ dup ] unless*
+ [ hex> ] bi@ 2array
+ ] dip
+ ] assoc-map ;
: properties>intervals ( properties -- assoc[str,interval] )
- dup values prune [ f ] H{ } map>assoc
+ dup values members [ f ] H{ } map>assoc
[ [ push-at ] curry assoc-each ] keep
[ <interval-set> ] assoc-map ;
[ [ 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 ]
+ [ process-names \ name-map set-value ]
+ [ 13 swap process-data \ simple-lower set-value ]
+ [ 12 swap process-data \ simple-upper set-value ]
+ [ 14 swap process-data simple-upper assoc-union \ simple-title set-value ]
+ [ process-combining \ class-map set-value ]
+ [ process-canonical \ canonical-map set-value \ combine-map set-value ]
+ [ process-compatibility \ compatibility-map set-value ]
+ [ process-category \ category-map set-value ]
} cleave
: postprocess-class ( -- )
- combine-map [ [ second ] map ] map concat
+ combine-map keys [ 2ch> nip ] map
[ combining-class not ] filter
[ 0 swap class-map set-at ] each ;
postprocess-class
-load-special-casing to: special-casing
-
-load-properties to: properties
-
-! Utility to load resource files that look like Scripts.txt
+load-special-casing \ special-casing set-value
-SYMBOL: interned
-
-: parse-script ( filename -- assoc )
- ! assoc is code point/range => name
- ascii file-lines filter-comments [ split-; ] map ;
-
-: range, ( value key -- )
- swap interned get
- [ = ] with find nip 2array , ;
-
-: expand-ranges ( assoc -- interval-map )
- [
- [
- swap CHAR: . over member? [
- ".." split1 [ hex> ] bi@ 2array
- ] [ hex> ] if range,
- ] assoc-each
- ] { } make <interval-map> ;
-
-: process-script ( ranges -- table )
- dup values prune interned
- [ expand-ranges ] with-variable ;
-
-: load-script ( filename -- table )
- parse-script process-script ;
+load-properties \ properties set-value
[ name>char [ "Invalid character" throw ] unless* ]
name>char-hook set-global
projects / factor.git / blobdiff