basis/unicode/data/data.factor

   1 ! Copyright (C) 2008 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
   5 math.parser hash2 math.order byte-arrays words namespaces words
   6 compiler.units parser io.encodings.ascii values interval-maps
   7 ascii sets combinators locals math.ranges sorting ;
   8 IN: unicode.data
   9
  10 VALUE: simple-lower
  11 VALUE: simple-upper
  12 VALUE: simple-title
  13 VALUE: canonical-map
  14 VALUE: combine-map
  15 VALUE: class-map
  16 VALUE: compatibility-map
  17 VALUE: category-map
  18 VALUE: name-map
  19 VALUE: special-casing
  20 VALUE: properties
  21
  22 : canonical-entry ( char -- seq ) canonical-map at ;
  23 : combine-chars ( a b -- char/f ) combine-map hash2 ;
  24 : compatibility-entry ( char -- seq ) compatibility-map at  ;
  25 : combining-class ( char -- n ) class-map at ;
  26 : non-starter? ( char -- ? ) class-map key? ;
  27 : name>char ( string -- char ) name-map at ;
  28 : char>name ( char -- string ) name-map value-at ;
  29 : property? ( char property -- ? ) properties at interval-key? ;
  30
  31 ! Convenience functions
  32 : ?between? ( n/f from to -- ? )
  33     pick [ between? ] [ 3drop f ] if ;
  34
  35 ! Loading data from UnicodeData.txt
  36
  37 : split-; ( line -- array )
  38     ";" split [ [ blank? ] trim ] map ;
  39
  40 : data ( filename -- data )
  41     ascii file-lines [ split-; ] map ;
  42
  43 : load-data ( -- data )
  44     "resource:basis/unicode/data/UnicodeData.txt" data ;
  45
  46 : filter-comments ( lines -- lines )
  47     [ "#@" split first ] map harvest ;
  48
  49 : (process-data) ( index data -- newdata )
  50     filter-comments
  51     [ [ nth ] keep first swap ] with { } map>assoc
  52     [ [ hex> ] dip ] assoc-map ;
  53
  54 : process-data ( index data -- hash )
  55     (process-data) [ hex> ] assoc-map [ nip ] assoc-filter >hashtable ;
  56
  57 : (chain-decomposed) ( hash value -- newvalue )
  58     [
  59         2dup swap at
  60         [ (chain-decomposed) ] [ 1array nip ] ?if
  61     ] with map concat ;
  62
  63 : chain-decomposed ( hash -- newhash )
  64     dup [ swap (chain-decomposed) ] curry assoc-map ;
  65
  66 : first* ( seq -- ? )
  67     second { [ empty? ] [ first ] } 1|| ;
  68
  69 : (process-decomposed) ( data -- alist )
  70     5 swap (process-data)
  71     [ " " split [ hex> ] map ] assoc-map ;
  72
  73 : process-canonical ( data -- hash2 hash )
  74     (process-decomposed) [ first* ] filter
  75     [
  76         [ second length 2 = ] filter
  77         ! using 1009 as the size, the maximum load is 4
  78         [ first2 first2 rot 3array ] map 1009 alist>hash2
  79     ] [ >hashtable chain-decomposed ] bi ;
  80
  81 : process-compatibility ( data -- hash )
  82     (process-decomposed)
  83     [ dup first* [ first2 rest 2array ] unless ] map
  84     [ second empty? not ] filter
  85     >hashtable chain-decomposed ;
  86
  87 : process-combining ( data -- hash )
  88     3 swap (process-data)
  89     [ string>number ] assoc-map
  90     [ nip zero? not ] assoc-filter
  91     >hashtable ;
  92
  93 : categories ( -- names )
  94     ! For non-existent characters, use Cn
  95     { "Cn"
  96       "Lu" "Ll" "Lt" "Lm" "Lo"
  97       "Mn" "Mc" "Me"
  98       "Nd" "Nl" "No"
  99       "Pc" "Pd" "Ps" "Pe" "Pi" "Pf" "Po"
 100       "Sm" "Sc" "Sk" "So"
 101       "Zs" "Zl" "Zp"
 102       "Cc" "Cf" "Cs" "Co" } ;
 103
 104 : num-chars HEX: 2FA1E ;
 105 ! the maximum unicode char in the first 3 planes
 106
 107 : ?set-nth ( val index seq -- )
 108     2dup bounds-check? [ set-nth ] [ 3drop ] if ;
 109
 110 :: fill-ranges ( table -- table )
 111     name-map >alist sort-values keys
 112     [ { [ "first>" tail? ] [ "last>" tail? ] } 1|| ] filter
 113     2 group [
 114         [ name>char ] bi@ [ [a,b] ] [ table ?nth ] bi
 115         [ swap table ?set-nth ] curry each
 116     ] assoc-each table ;
 117
 118 :: process-category ( data -- category-listing )
 119     [let | table [ num-chars <byte-array> ] |
 120         2 data (process-data) [| char cat |
 121             cat categories index char table ?set-nth
 122         ] assoc-each table fill-ranges ] ;
 123
 124 : ascii-lower ( string -- lower )
 125     [ dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ] map ;
 126
 127 : process-names ( data -- names-hash )
 128     1 swap (process-data) [
 129         ascii-lower { { CHAR: \s CHAR: - } } substitute swap
 130     ] H{ } assoc-map-as ;
 131
 132 : multihex ( hexstring -- string )
 133     " " split [ hex> ] map sift ;
 134
 135 TUPLE: code-point lower title upper ;
 136
 137 C: <code-point> code-point
 138
 139 : set-code-point ( seq -- )
 140     4 head [ multihex ] map first4
 141     <code-point> swap first set ;
 142
 143 ! Extra properties
 144 : properties-lines ( -- lines )
 145     "resource:basis/unicode/data/PropList.txt"
 146     ascii file-lines ;
 147
 148 : parse-properties ( -- {{[a,b],prop}} )
 149     properties-lines filter-comments [
 150         split-; first2
 151         [ ".." split1 [ dup ] unless* [ hex> ] bi@ 2array ] dip
 152     ] { } map>assoc ;
 153
 154 : properties>intervals ( properties -- assoc[str,interval] )
 155     dup values prune [ f ] H{ } map>assoc
 156     [ [ push-at ] curry assoc-each ] keep
 157     [ <interval-set> ] assoc-map ;
 158
 159 : load-properties ( -- assoc )
 160     parse-properties properties>intervals ;
 161
 162 ! Special casing data
 163 : load-special-casing ( -- special-casing )
 164     "resource:basis/unicode/data/SpecialCasing.txt" data
 165     [ length 5 = ] filter
 166     [ [ set-code-point ] each ] H{ } make-assoc ;
 167
 168 load-data {
 169     [ process-names to: name-map ]
 170     [ 13 swap process-data to: simple-lower ]
 171     [ 12 swap process-data to: simple-upper ]
 172     [ 14 swap process-data simple-upper assoc-union to: simple-title ]
 173     [ process-combining to: class-map ]
 174     [ process-canonical to: canonical-map to: combine-map ]
 175     [ process-compatibility to: compatibility-map ]
 176     [ process-category to: category-map ]
 177 } cleave
 178
 179 load-special-casing to: special-casing
 180
 181 load-properties to: properties