factor: trim some using lists

[factor.git] / basis / unicode / data / data.factor

diff --git a/basis/unicode/data/data.factor b/basis/unicode/data/data.factor
index 49519ac3e13755649787db52397d497917c6be59..459c3b017b927c49be95045b2167f5844d93c9c0 100644 (file)
--- a/basis/unicode/data/data.factor
+++ b/basis/unicode/data/data.factor
@@ -2,10 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays ascii assocs byte-arrays combinators
 combinators.short-circuit grouping hashtables interval-sets
-io.encodings.utf8 io.files kernel locals make math math.bitwise
-math.order math.parser math.ranges memoize namespaces sequences
+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 ;
-QUALIFIED: interval-sets
 IN: unicode.data
 
 <PRIVATE
@@ -21,25 +20,20 @@ CONSTANT: category-map BV{ }
 CONSTANT: special-casing H{ }
 CONSTANT: properties H{ }
 
-: >2ch ( a b -- c ) [ 21 shift ] dip + ;
-: 2ch> ( c -- a b ) [ -21 shift ] [ 21 on-bits mask ] bi ;
+: >2ch ( a b -- c ) [ 21 shift ] dip + ; inline
+: 2ch> ( c -- a b ) [ -21 shift ] [ 21 on-bits mask ] bi ; inline
 
 PRIVATE>
 
 CONSTANT: name-map H{ }
 
 : 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
+: 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 ( property -- interval-map ) properties at ; foldable
-: property? ( char property -- ? ) property interval-sets:in? ; 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? ( char property -- ? ) property interval-in? ; inline
 : special-case ( ch -- casing-tuple ) special-casing at ; inline
 
 ! For non-existent characters, use Cn
@@ -57,13 +51,13 @@ CONSTANT: categories {
 <PRIVATE
 
 MEMO: categories-map ( -- hashtable )
-    categories <enum> [ swap ] H{ } assoc-map-as ;
+    categories H{ } zip-index-as ;
 
-CONSTANT: num-chars 0x2FA1E
+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
@@ -76,14 +70,14 @@ PRIVATE>
     ] ?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
@@ -106,15 +100,18 @@ PRIVATE>
 
 : (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 = ] reject ;
+    [ "#" split1 drop [ ascii:blank? ] trim-tail hex> ] map
+    0 swap remove ;
+
+: unique ( seq -- assoc )
+    [ dup ] H{ } map>assoc ;
 
 : remove-exclusions ( alist -- alist )
     exclusions unique assoc-diff ;
@@ -144,12 +141,12 @@ PRIVATE>
     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 ;
@@ -160,7 +157,7 @@ PRIVATE>
     ] H{ } assoc-map-as ;
 
 : multihex ( hexstring -- string )
-    " " split [ hex> ] map sift ;
+    split-words [ hex> ] map sift ;
 
 PRIVATE>
 
@@ -174,9 +171,9 @@ C: <code-point> code-point
     4 head [ multihex ] map first4
     <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
@@ -193,11 +190,11 @@ C: <code-point> code-point
 
 ! 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 ;
 
-load-data {
+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 ]
@@ -209,14 +206,17 @@ load-data {
 } cleave
 
 combine-map keys [ 2ch> nip ] map
-[ combining-class ] reject
+[ class-map at ] reject
 [ 0 swap class-map set-at ] each
 
 load-special-casing special-casing swap assoc-union! drop
 
 load-properties properties swap assoc-union! drop
 
-[ name>char [ "Invalid character" throw ] unless* ]
-name>char-hook set-global
-
 PRIVATE>
+
+ERROR: invalid-unicode-character name ;
+
+[
+    name-map ?at [ invalid-unicode-character ] unless
+] name>char-hook set-global