basis/unicode/collation/collation.factor

   1 ! Copyright (C) 2008 Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators
   4 combinators.short-circuit combinators.smart fry kernel locals make
   5 math math.order math.parser namespaces sequences
   6 simple-flat-file splitting strings unicode.data ;
   7 IN: unicode.collation
   8
   9 <PRIVATE
  10
  11 SYMBOL: ducet
  12
  13 TUPLE: weight-levels primary secondary tertiary ignorable? ;
  14 : <weight-levels> ( primary secondary tertiary -- weight-levels> )
  15     weight-levels new
  16         swap >>tertiary
  17         swap >>secondary
  18         swap >>primary ; inline
  19
  20 : parse-weight ( string -- weight )
  21     "]" split but-last [
  22         weight-levels new swap rest unclip CHAR: * = swapd >>ignorable?
  23         swap "." split first3 [ hex> ] tri@
  24         [ >>primary ] [ >>secondary ] [ >>tertiary ] tri*
  25     ] map ;
  26
  27 : parse-keys ( string -- chars )
  28     " " split [ hex> ] "" map-as ;
  29
  30 : parse-ducet ( file -- ducet )
  31     load-data-file [ [ parse-keys ] [ parse-weight ] bi* ] H{ } assoc-map-as ;
  32
  33 "vocab:unicode/UCA/allkeys.txt" parse-ducet ducet set-global
  34
  35 ! Fix up table for long contractions
  36 : help-one ( assoc key -- )
  37     ! Need to be more general? Not for DUCET, apparently
  38     2 head 2dup swap key? [ 2drop ] [
  39         [ [ 1string of ] with { } map-as concat ]
  40         [ swap set-at ] 2bi
  41     ] if ;
  42
  43 : fixup-ducet ( -- )
  44     {
  45         {
  46             { 0x0FB2 0x0F71 } ! CE(0FB2) CE(0F71)
  47             {
  48                 T{ weight-levels
  49                     { primary 12719 }
  50                     { secondary 32 }
  51                     { tertiary 2 }
  52                 }
  53                 T{ weight-levels
  54                     { primary 12741 }
  55                     { secondary 32 }
  56                     { tertiary 2 }
  57                 }
  58             }
  59         }
  60         {
  61             { 0x0FB3 0x0F71 } ! CE(0FB3) CE(0F71)
  62             {
  63                 T{ weight-levels
  64                     { primary 12722 }
  65                     { secondary 32 }
  66                     { tertiary 2 }
  67                 }
  68                 T{ weight-levels
  69                     { primary 12741 }
  70                     { secondary 32 }
  71                     { tertiary 2 }
  72                 }
  73             }
  74         }
  75
  76         {
  77             { 0x0FB2 0x0F71 0x0F72 } ! CE(0FB2) CE(0F71 0F72)
  78             {
  79                 T{ weight-levels
  80                     { primary 12719 }
  81                     { secondary 32 }
  82                     { tertiary 2 }
  83                 }
  84                 T{ weight-levels
  85                     { primary 12743 }
  86                     { secondary 32 }
  87                     { tertiary 2 }
  88                 }
  89             }
  90         }
  91         {
  92             { 0x0FB2 0x0F73        } ! CE(0FB2) CE(0F71 0F72)
  93             {
  94                 T{ weight-levels
  95                     { primary 12719 }
  96                     { secondary 32 }
  97                     { tertiary 2 }
  98                 }
  99                 T{ weight-levels
 100                     { primary 12743 }
 101                     { secondary 32 }
 102                     { tertiary 2 }
 103                 }
 104             }
 105         }
 106         {
 107             { 0x0FB2 0x0F71 0x0F74 } ! CE(0FB2) CE(0F71 0F74)
 108             {
 109                 T{ weight-levels
 110                     { primary 12719 }
 111                     { secondary 32 }
 112                     { tertiary 2 }
 113                 }
 114                 T{ weight-levels
 115                     { primary 12747 }
 116                     { secondary 32 }
 117                     { tertiary 2 }
 118                 }
 119             }
 120         }
 121         {
 122             { 0x0FB2 0x0F75        } ! CE(0FB2) CE(0F71 0F74)
 123             {
 124                 T{ weight-levels
 125                     { primary 12719 }
 126                     { secondary 32 }
 127                     { tertiary 2 }
 128                 }
 129                 T{ weight-levels
 130                     { primary 12747 }
 131                     { secondary 32 }
 132                     { tertiary 2 }
 133                 }
 134             }
 135         }
 136         {
 137             { 0x0FB3 0x0F71 0x0F72 } ! CE(0FB3) CE(0F71 0F72)
 138             {
 139                 T{ weight-levels
 140                     { primary 12722 }
 141                     { secondary 32 }
 142                     { tertiary 2 }
 143                 }
 144                 T{ weight-levels
 145                     { primary 12743 }
 146                     { secondary 32 }
 147                     { tertiary 2 }
 148                 }
 149             }
 150         }
 151         {
 152             { 0x0FB3 0x0F73        } ! CE(0FB3) CE(0F71 0F72)
 153             {
 154                 T{ weight-levels
 155                     { primary 12722 }
 156                     { secondary 32 }
 157                     { tertiary 2 }
 158                 }
 159                 T{ weight-levels
 160                     { primary 12743 }
 161                     { secondary 32 }
 162                     { tertiary 2 }
 163                 }
 164             }
 165         }
 166         {
 167             { 0x0FB3 0x0F71 0x0F74 } ! CE(0FB3) CE(0F71 0F74)
 168             {
 169                 T{ weight-levels
 170                     { primary 12722 }
 171                     { secondary 32 }
 172                     { tertiary 2 }
 173                 }
 174                 T{ weight-levels
 175                     { primary 12747 }
 176                     { secondary 32 }
 177                     { tertiary 2 }
 178                 }
 179             }
 180         }
 181         {
 182             { 0x0FB3 0x0F75        } ! CE(0FB3) CE(0F71 0F74)
 183             {
 184                 T{ weight-levels
 185                     { primary 12722 }
 186                     { secondary 32 }
 187                     { tertiary 2 }
 188                 }
 189                 T{ weight-levels
 190                     { primary 12747 }
 191                     { secondary 32 }
 192                     { tertiary 2 }
 193                 }
 194             }
 195         }
 196     } ducet get-global '[ swap >string _ set-at ] assoc-each ;
 197
 198 ! Add a few missing ducet values
 199 fixup-ducet
 200
 201 : tangut-block? ( char -- ? )
 202     ! Tangut Block, Tangut Components Block
 203     { [ 0x17000 0x187FF between? ] [ 0x18800 0x18AFF between? ] } 1|| ; inline
 204
 205 : nushu-block? ( char -- ? )
 206     0x1b170 0x1B2FB between? ; inline
 207
 208 ! https://wiki.computercraft.cc/Module:Unicode_data
 209 ! Unicode TR10 - Computing Implicit Weights
 210 : base ( char -- base )
 211     {
 212         { [ dup 0x03400 0x04DB5 between? ] [ drop 0xFB80 ] } ! Extension A
 213         { [ dup 0x20000 0x2A6D6 between? ] [ drop 0xFB80 ] } ! Extension B
 214         { [ dup 0x2A700 0x2B734 between? ] [ drop 0xFB80 ] } ! Extension C
 215         { [ dup 0x2B740 0x2B81D between? ] [ drop 0xFB80 ] } ! Extension D
 216         { [ dup 0x2B820 0x2CEA1 between? ] [ drop 0xFB80 ] } ! Extension E
 217         { [ dup 0x2CEB0 0x2EBE0 between? ] [ drop 0xFB80 ] } ! Extension F
 218         { [ dup 0x04E00 0x09FEF between? ] [ drop 0xFB40 ] } ! CJK
 219         [ drop 0xFBC0 ] ! Other
 220     } cond ;
 221
 222 : tangut-AAAA ( char -- weight-levels )
 223     drop 0xfb00 0x0020 0x0002 <weight-levels> ; inline
 224
 225 : tangut-BBBB ( char -- weight-levels )
 226     0x17000 - 0x8000 bitor 0 0 <weight-levels> ; inline
 227
 228 : nushu-AAAA ( char -- weight-levels )
 229     drop 0xfb01 0x0020 0x0002 <weight-levels> ; inline
 230
 231 : nushu-BBBB ( char -- weight-levels )
 232     0x1B170 - 0x8000 bitor 0 0 <weight-levels> ; inline
 233
 234 : AAAA ( char -- weight-levels )
 235     [ base ] [ -15 shift ] bi + 0x0020 0x0002 <weight-levels> ; inline
 236
 237 : BBBB ( char -- weight-levels )
 238     0x7FFF bitand 0x8000 bitor 0 0 <weight-levels> ; inline
 239
 240 : derive-weight ( 1string -- weight-levels-pair )
 241     first
 242     {
 243         { [ dup tangut-block? ] [ [ tangut-AAAA ] [ tangut-BBBB ] bi 2array ] }
 244         { [ dup nushu-block? ] [ [ nushu-AAAA ] [ nushu-BBBB ] bi 2array ] }
 245         [ [ AAAA ] [ BBBB ] bi 2array ]
 246     } cond ;
 247
 248 : building-last ( -- char )
 249     building get [ 0 ] [ last last ] if-empty ;
 250
 251 : blocked? ( char -- ? )
 252     combining-class dup { 0 f } member?
 253     [ drop building-last non-starter? ]
 254     [ building-last combining-class = ] if ;
 255
 256 : possible-bases ( -- slice-of-building )
 257     building get dup [ first non-starter? not ] find-last
 258     drop [ 0 ] unless* tail-slice ;
 259
 260 :: ?combine ( char slice i -- ? )
 261     i slice nth char suffix :> str
 262     str ducet get-global key? dup
 263     [ str i slice set-nth ] when ;
 264
 265 : add ( char -- )
 266     dup blocked? [ 1string , ] [
 267         dup possible-bases dup length <iota>
 268         [ ?combine ] 2with any?
 269         [ drop ] [ 1string , ] if
 270     ] if ;
 271
 272 : string>graphemes ( string -- graphemes )
 273     [ [ add ] each ] { } make ;
 274
 275 : char>weight-levels ( 1string -- weight-levels )
 276     ducet get-global ?at [ derive-weight ] unless ; inline
 277
 278 : graphemes>weights ( graphemes -- weights )
 279     [
 280         dup weight-levels?
 281         [ 1array ] ! From tailoring
 282         [ char>weight-levels ] if
 283     ] { } map-as concat ;
 284
 285 : append-weights ( weight-levels quot -- seq )
 286     [ [ ignorable?>> ] reject ] dip
 287     map [ zero? ] reject ; inline
 288
 289 : variable-weight ( weight-levels -- obj )
 290     dup ignorable?>> [ primary>> ] [ drop 0xFFFF ] if ;
 291
 292 : weights>bytes ( weights -- array )
 293     [
 294         {
 295             [ [ primary>> ] append-weights { 0 } ]
 296             [ [ secondary>> ] append-weights { 0 } ]
 297             [ [ tertiary>> ] append-weights { 0 } ]
 298             [ [ [ secondary>> ] [ tertiary>> ] bi [ zero? ] bi@ and not ] filter [ variable-weight ] map ]
 299         } cleave
 300     ] { } append-outputs-as ;
 301
 302 PRIVATE>
 303
 304 : completely-ignorable? ( weight -- ? )
 305     {
 306         [ primary>> zero? ]
 307         [ secondary>> zero? ]
 308         [ tertiary>> zero? ]
 309     } 1&& ;
 310
 311 : filter-ignorable ( weights -- weights' )
 312     f swap [
 313         [ nip ] [ primary>> zero? and ] 2bi
 314         [ swap ignorable?>> or ]
 315         [ swap completely-ignorable? or not ] 2bi
 316     ] filter nip ;