basis/unicode/data/data.factor

   1 ! Copyright (C) 2008, 2009 Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays ascii assocs byte-arrays combinators
   4 combinators.short-circuit grouping hashtables interval-sets
   5 io.encodings.utf8 io.files kernel locals make math math.bitwise
   6 math.order math.parser math.ranges memoize namespaces sequences
   7 sets simple-flat-file sorting splitting strings.parser ;
   8 QUALIFIED: interval-sets
   9 IN: unicode.data
  10
  11 <PRIVATE
  12
  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 CONSTANT: category-map BV{ }
  21 CONSTANT: special-casing H{ }
  22 CONSTANT: properties H{ }
  23
  24 : >2ch ( a b -- c ) [ 21 shift ] dip + ;
  25 : 2ch> ( c -- a b ) [ -21 shift ] [ 21 on-bits mask ] bi ;
  26
  27 PRIVATE>
  28
  29 CONSTANT: name-map H{ }
  30
  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 ( property -- interval-map ) properties at ; foldable
  39 : property? ( char property -- ? ) property interval-sets:in? ; inline
  40 : ch>lower ( ch -- lower ) simple-lower ?at drop ; inline
  41 : ch>upper ( ch -- upper ) simple-upper ?at drop ; inline
  42 : ch>title ( ch -- title ) simple-title ?at drop ; inline
  43 : special-case ( ch -- casing-tuple ) special-casing at ; inline
  44
  45 ! For non-existent characters, use Cn
  46 CONSTANT: categories {
  47     "Cn"
  48     "Lu" "Ll" "Lt" "Lm" "Lo"
  49     "Mn" "Mc" "Me"
  50     "Nd" "Nl" "No"
  51     "Pc" "Pd" "Ps" "Pe" "Pi" "Pf" "Po"
  52     "Sm" "Sc" "Sk" "So"
  53     "Zs" "Zl" "Zp"
  54     "Cc" "Cf" "Cs" "Co"
  55 }
  56
  57 <PRIVATE
  58
  59 MEMO: categories-map ( -- hashtable )
  60     categories <enum> [ swap ] H{ } assoc-map-as ;
  61
  62 CONSTANT: num-chars 0x2FA1E
  63
  64 PRIVATE>
  65
  66 : category# ( char -- n )
  67     ! There are a few characters that should be Cn
  68     ! that this gives Cf or Mn
  69     ! Cf = 26; Mn = 5; Cn = 29
  70     ! Use a compressed array instead?
  71     dup category-map ?nth [ ] [
  72         dup 0xE0001 0xE007F between?
  73         [ drop 26 ] [
  74             0xE0100 0xE01EF between?  5 29 ?
  75         ] if
  76     ] ?if ; inline
  77
  78 : category ( char -- category )
  79     category# categories nth ;
  80
  81 <PRIVATE
  82
  83 ! Loading data from UnicodeData.txt
  84
  85 : load-data ( -- data )
  86     "vocab:unicode/data/UnicodeData.txt" data ;
  87
  88 : (process-data) ( index data -- newdata )
  89     [ [ nth ] keep first swap ] with { } map>assoc
  90     [ [ hex> ] dip ] assoc-map ;
  91
  92 : process-data ( index data -- hash )
  93     (process-data) [ hex> ] assoc-map [ nip ] H{ } assoc-filter-as ;
  94
  95 : (chain-decomposed) ( hash value -- newvalue )
  96     [
  97         2dup of
  98         [ (chain-decomposed) ] [ 1array nip ] ?if
  99     ] with map concat ;
 100
 101 : chain-decomposed ( hash -- newhash )
 102     dup [ swap (chain-decomposed) ] curry assoc-map ;
 103
 104 : first* ( seq -- ? )
 105     second { [ empty? ] [ first ] } 1|| ;
 106
 107 : (process-decomposed) ( data -- alist )
 108     5 swap (process-data)
 109     [ " " split [ hex> ] map ] assoc-map ;
 110
 111 : exclusions-file ( -- filename )
 112     "vocab:unicode/data/CompositionExclusions.txt" ;
 113
 114 : exclusions ( -- set )
 115     exclusions-file utf8 file-lines
 116     [ "#" split1 drop [ blank? ] trim-tail hex> ] map
 117     [ 0 = not ] filter ;
 118
 119 : remove-exclusions ( alist -- alist )
 120     exclusions unique assoc-diff ;
 121
 122 : process-canonical ( data -- hash hash )
 123     (process-decomposed) [ first* ] filter
 124     [
 125         [ second length 2 = ] filter remove-exclusions
 126         [ first2 >2ch swap ] H{ } assoc-map-as
 127     ] [ >hashtable chain-decomposed ] bi ;
 128
 129 : process-compatibility ( data -- hash )
 130     (process-decomposed)
 131     [ dup first* [ first2 rest 2array ] unless ] map
 132     [ second empty? not ] filter
 133     >hashtable chain-decomposed ;
 134
 135 : process-combining ( data -- hash )
 136     3 swap (process-data)
 137     [ string>number ] assoc-map
 138     [ nip zero? not ] assoc-filter
 139     >hashtable ;
 140
 141 ! the maximum unicode char in the first 3 planes
 142
 143 :: fill-ranges ( table -- table )
 144     name-map sort-values keys
 145     [ { [ "first>" tail? ] [ "last>" tail? ] } 1|| ] filter
 146     2 group [
 147         [ name>char ] bi@ [ [a,b] ] [ table ?nth ] bi
 148         [ swap table ?set-nth ] curry each
 149     ] assoc-each table ;
 150
 151 :: process-category ( data -- category-listing )
 152     num-chars <byte-array> :> table
 153     2 data (process-data) [| char cat |
 154         cat categories-map at char table ?set-nth
 155     ] assoc-each table fill-ranges ;
 156
 157 : process-names ( data -- names-hash )
 158     1 swap (process-data) [
 159         >lower H{ { CHAR: \s CHAR: - } } substitute swap
 160     ] H{ } assoc-map-as ;
 161
 162 : multihex ( hexstring -- string )
 163     " " split [ hex> ] map sift ;
 164
 165 PRIVATE>
 166
 167 TUPLE: code-point lower title upper ;
 168
 169 C: <code-point> code-point
 170
 171 <PRIVATE
 172
 173 : set-code-point ( seq -- )
 174     4 head [ multihex ] map first4
 175     <code-point> swap first ,, ;
 176
 177 ! Extra properties
 178 : parse-properties ( -- {{[a,b],prop}} )
 179     "vocab:unicode/data/PropList.txt" data [
 180         [
 181             ".." split1 [ dup ] unless*
 182             [ hex> ] bi@ 2array
 183         ] dip
 184     ] assoc-map ;
 185
 186 : properties>intervals ( properties -- assoc[str,interval] )
 187     dup values members [ f ] H{ } map>assoc
 188     [ [ push-at ] curry assoc-each ] keep
 189     [ <interval-set> ] assoc-map ;
 190
 191 : load-properties ( -- assoc )
 192     parse-properties properties>intervals ;
 193
 194 ! Special casing data
 195 : load-special-casing ( -- special-casing )
 196     "vocab:unicode/data/SpecialCasing.txt" data
 197     [ length 5 = ] filter
 198     [ [ set-code-point ] each ] H{ } make ;
 199
 200 load-data {
 201     [ process-names name-map swap assoc-union! drop ]
 202     [ 13 swap process-data simple-lower swap assoc-union! drop ]
 203     [ 12 swap process-data simple-upper swap assoc-union! drop ]
 204     [ 14 swap process-data simple-upper assoc-union simple-title swap assoc-union! drop ]
 205     [ process-combining class-map swap assoc-union! drop ]
 206     [ process-canonical canonical-map swap assoc-union! drop combine-map swap assoc-union! drop ]
 207     [ process-compatibility compatibility-map swap assoc-union! drop ]
 208     [ process-category category-map push-all ]
 209 } cleave
 210
 211 combine-map keys [ 2ch> nip ] map
 212 [ combining-class not ] filter
 213 [ 0 swap class-map set-at ] each
 214
 215 load-special-casing special-casing swap assoc-union! drop
 216
 217 load-properties properties swap assoc-union! drop
 218
 219 [ name>char [ "Invalid character" throw ] unless* ]
 220 name>char-hook set-global
 221
 222 PRIVATE>