basis/unicode/data/data.factor

   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 values interval-maps
   7 ascii sets combinators locals math.ranges sorting make
   8 strings.parser io.encodings.utf8 memoize simple-flat-file ;
   9 FROM: namespaces => set ;
  10 IN: unicode.data
  11
  12 <PRIVATE
  13
  14 VALUE: simple-lower
  15 VALUE: simple-upper
  16 VALUE: simple-title
  17 VALUE: canonical-map
  18 VALUE: combine-map
  19 VALUE: class-map
  20 VALUE: compatibility-map
  21 VALUE: category-map
  22 VALUE: special-casing
  23 VALUE: properties
  24
  25 : >2ch ( a b -- c ) [ 21 shift ] dip + ;
  26 : 2ch> ( c -- a b ) [ -21 shift ] [ 21 on-bits mask ] bi ;
  27
  28 PRIVATE>
  29
  30 VALUE: name-map
  31
  32 : canonical-entry ( char -- seq ) canonical-map at ; inline
  33 : combine-chars ( a b -- char/f ) >2ch combine-map at ; inline
  34 : compatibility-entry ( char -- seq ) compatibility-map at ; inline
  35 : combining-class ( char -- n ) class-map at ; inline
  36 : non-starter? ( char -- ? ) combining-class { 0 f } member? not ; inline
  37 : name>char ( name -- char ) name-map at ; inline
  38 : char>name ( char -- name ) name-map value-at ; inline
  39 : property? ( char property -- ? ) properties at interval-key? ; 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 <PRIVATE
  57
  58 MEMO: categories-map ( -- hashtable )
  59     categories <enum> [ swap ] H{ } assoc-map-as ;
  60
  61 CONSTANT: num-chars 0x2FA1E
  62
  63 PRIVATE>
  64
  65 : category# ( char -- n )
  66     ! There are a few characters that should be Cn
  67     ! that this gives Cf or Mn
  68     ! Cf = 26; Mn = 5; Cn = 29
  69     ! Use a compressed array instead?
  70     dup category-map ?nth [ ] [
  71         dup 0xE0001 0xE007F between?
  72         [ drop 26 ] [
  73             0xE0100 0xE01EF between?  5 29 ?
  74         ] if
  75     ] ?if ;
  76
  77 : category ( char -- category )
  78     category# categories nth ;
  79
  80 <PRIVATE
  81
  82 ! Loading data from UnicodeData.txt
  83
  84 : load-data ( -- data )
  85     "vocab:unicode/data/UnicodeData.txt" data ;
  86
  87 : (process-data) ( index data -- newdata )
  88     [ [ nth ] keep first swap ] with { } map>assoc
  89     [ [ hex> ] dip ] assoc-map ;
  90
  91 : process-data ( index data -- hash )
  92     (process-data) [ hex> ] assoc-map [ nip ] H{ } assoc-filter-as ;
  93
  94 : (chain-decomposed) ( hash value -- newvalue )
  95     [
  96         2dup swap at
  97         [ (chain-decomposed) ] [ 1array nip ] ?if
  98     ] with map concat ;
  99
 100 : chain-decomposed ( hash -- newhash )
 101     dup [ swap (chain-decomposed) ] curry assoc-map ;
 102
 103 : first* ( seq -- ? )
 104     second { [ empty? ] [ first ] } 1|| ;
 105
 106 : (process-decomposed) ( data -- alist )
 107     5 swap (process-data)
 108     [ " " split [ hex> ] map ] assoc-map ;
 109
 110 : exclusions-file ( -- filename )
 111     "vocab:unicode/data/CompositionExclusions.txt" ;
 112
 113 : exclusions ( -- set )
 114     exclusions-file utf8 file-lines
 115     [ "#" split1 drop [ blank? ] trim-tail hex> ] map
 116     [ 0 = not ] filter ;
 117
 118 : remove-exclusions ( alist -- alist )
 119     exclusions unique assoc-diff ;
 120
 121 : process-canonical ( data -- hash hash )
 122     (process-decomposed) [ first* ] filter
 123     [
 124         [ second length 2 = ] filter remove-exclusions
 125         [ first2 >2ch swap ] H{ } assoc-map-as
 126     ] [ >hashtable chain-decomposed ] bi ;
 127
 128 : process-compatibility ( data -- hash )
 129     (process-decomposed)
 130     [ dup first* [ first2 rest 2array ] unless ] map
 131     [ second empty? not ] filter
 132     >hashtable chain-decomposed ;
 133
 134 : process-combining ( data -- hash )
 135     3 swap (process-data)
 136     [ string>number ] assoc-map
 137     [ nip zero? not ] assoc-filter
 138     >hashtable ;
 139
 140 ! the maximum unicode char in the first 3 planes
 141
 142 : ?set-nth ( val index seq -- )
 143     2dup bounds-check? [ set-nth ] [ 3drop ] if ;
 144
 145 :: fill-ranges ( table -- table )
 146     name-map sort-values keys
 147     [ { [ "first>" tail? ] [ "last>" tail? ] } 1|| ] filter
 148     2 group [
 149         [ name>char ] bi@ [ [a,b] ] [ table ?nth ] bi
 150         [ swap table ?set-nth ] curry each
 151     ] assoc-each table ;
 152
 153 :: process-category ( data -- category-listing )
 154     num-chars <byte-array> :> table
 155     2 data (process-data) [| char cat |
 156         cat categories-map at char table ?set-nth
 157     ] assoc-each table fill-ranges ;
 158
 159 : process-names ( data -- names-hash )
 160     1 swap (process-data) [
 161         >lower { { CHAR: \s CHAR: - } } substitute swap
 162     ] H{ } assoc-map-as ;
 163
 164 : multihex ( hexstring -- string )
 165     " " split [ hex> ] map sift ;
 166
 167 PRIVATE>
 168
 169 TUPLE: code-point lower title upper ;
 170
 171 C: <code-point> code-point
 172
 173 <PRIVATE
 174
 175 : set-code-point ( seq -- )
 176     4 head [ multihex ] map first4
 177     <code-point> swap first set ;
 178
 179 ! Extra properties
 180 : parse-properties ( -- {{[a,b],prop}} )
 181     "vocab:unicode/data/PropList.txt" data [
 182         [
 183             ".." split1 [ dup ] unless*
 184             [ hex> ] bi@ 2array
 185         ] dip
 186     ] assoc-map ;
 187
 188 : properties>intervals ( properties -- assoc[str,interval] )
 189     dup values members [ f ] H{ } map>assoc
 190     [ [ push-at ] curry assoc-each ] keep
 191     [ <interval-set> ] assoc-map ;
 192
 193 : load-properties ( -- assoc )
 194     parse-properties properties>intervals ;
 195
 196 ! Special casing data
 197 : load-special-casing ( -- special-casing )
 198     "vocab:unicode/data/SpecialCasing.txt" data
 199     [ length 5 = ] filter
 200     [ [ set-code-point ] each ] H{ } make-assoc ;
 201
 202 load-data {
 203     [ process-names \ name-map set-value ]
 204     [ 13 swap process-data \ simple-lower set-value ]
 205     [ 12 swap process-data \ simple-upper set-value ]
 206     [ 14 swap process-data simple-upper assoc-union \ simple-title set-value ]
 207     [ process-combining \ class-map set-value ]
 208     [ process-canonical \ canonical-map set-value \ combine-map set-value ]
 209     [ process-compatibility \ compatibility-map set-value ]
 210     [ process-category \ category-map set-value ]
 211 } cleave
 212
 213 : postprocess-class ( -- )
 214     combine-map keys [ 2ch> nip ] map
 215     [ combining-class not ] filter
 216     [ 0 swap class-map set-at ] each ;
 217
 218 postprocess-class
 219
 220 load-special-casing \ special-casing set-value
 221
 222 load-properties \ properties set-value
 223
 224 [ name>char [ "Invalid character" throw ] unless* ]
 225 name>char-hook set-global