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-words [ 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 ! https://www.unicode.org/reports/tr10/tr10-41.html#Well_Formed_DUCET
  36 ! WF5 - Well-formedness 5 condition:
  37 ! https://www.unicode.org/reports/tr10/tr10-41.html#WF5
  38 !    { "0CC6" "0CC2" "0CD5" } ! 0CD5 is not a non-starter, don't add 2-gram "0CC6" "0CC2"to ducet
  39 !    { "0DD9" "0DCF" "0DCA" } ! already in allkeys.txt file
  40 !    { "0FB2" "0F71" "0F80" } ! added below
  41 !    { "0FB3" "0F71" "0F80" } ! added below
  42 ! This breaks the unicode tests that ship in CollationTest_SHIFTED.txt
  43 ! but it's supposedly more correct.
  44 : fixup-ducet-for-tibetan ( -- )
  45     {
  46         {
  47             { 0x0FB2 0x0F71 } ! CE(0FB2) CE(0F71)
  48             {
  49                 T{ weight-levels
  50                     { primary 12719 }
  51                     { secondary 32 }
  52                     { tertiary 2 }
  53                 }
  54                 T{ weight-levels
  55                     { primary 12741 }
  56                     { secondary 32 }
  57                     { tertiary 2 }
  58                 }
  59             }
  60         }
  61         {
  62             { 0x0FB3 0x0F71 } ! CE(0FB3) CE(0F71)
  63             {
  64                 T{ weight-levels
  65                     { primary 12722 }
  66                     { secondary 32 }
  67                     { tertiary 2 }
  68                 }
  69                 T{ weight-levels
  70                     { primary 12741 }
  71                     { secondary 32 }
  72                     { tertiary 2 }
  73                 }
  74             }
  75         }
  76
  77         {
  78             { 0x0FB2 0x0F71 0x0F72 } ! CE(0FB2) CE(0F71 0F72)
  79             {
  80                 T{ weight-levels
  81                     { primary 12719 }
  82                     { secondary 32 }
  83                     { tertiary 2 }
  84                 }
  85                 T{ weight-levels
  86                     { primary 12743 }
  87                     { secondary 32 }
  88                     { tertiary 2 }
  89                 }
  90             }
  91         }
  92         {
  93             { 0x0FB2 0x0F73        } ! CE(0FB2) CE(0F71 0F72)
  94             {
  95                 T{ weight-levels
  96                     { primary 12719 }
  97                     { secondary 32 }
  98                     { tertiary 2 }
  99                 }
 100                 T{ weight-levels
 101                     { primary 12743 }
 102                     { secondary 32 }
 103                     { tertiary 2 }
 104                 }
 105             }
 106         }
 107         {
 108             { 0x0FB2 0x0F71 0x0F74 } ! CE(0FB2) CE(0F71 0F74)
 109             {
 110                 T{ weight-levels
 111                     { primary 12719 }
 112                     { secondary 32 }
 113                     { tertiary 2 }
 114                 }
 115                 T{ weight-levels
 116                     { primary 12747 }
 117                     { secondary 32 }
 118                     { tertiary 2 }
 119                 }
 120             }
 121         }
 122         {
 123             { 0x0FB2 0x0F75        } ! CE(0FB2) CE(0F71 0F74)
 124             {
 125                 T{ weight-levels
 126                     { primary 12719 }
 127                     { secondary 32 }
 128                     { tertiary 2 }
 129                 }
 130                 T{ weight-levels
 131                     { primary 12747 }
 132                     { secondary 32 }
 133                     { tertiary 2 }
 134                 }
 135             }
 136         }
 137         {
 138             { 0x0FB3 0x0F71 0x0F72 } ! CE(0FB3) CE(0F71 0F72)
 139             {
 140                 T{ weight-levels
 141                     { primary 12722 }
 142                     { secondary 32 }
 143                     { tertiary 2 }
 144                 }
 145                 T{ weight-levels
 146                     { primary 12743 }
 147                     { secondary 32 }
 148                     { tertiary 2 }
 149                 }
 150             }
 151         }
 152         {
 153             { 0x0FB3 0x0F73        } ! CE(0FB3) CE(0F71 0F72)
 154             {
 155                 T{ weight-levels
 156                     { primary 12722 }
 157                     { secondary 32 }
 158                     { tertiary 2 }
 159                 }
 160                 T{ weight-levels
 161                     { primary 12743 }
 162                     { secondary 32 }
 163                     { tertiary 2 }
 164                 }
 165             }
 166         }
 167         {
 168             { 0x0FB3 0x0F71 0x0F74 } ! CE(0FB3) CE(0F71 0F74)
 169             {
 170                 T{ weight-levels
 171                     { primary 12722 }
 172                     { secondary 32 }
 173                     { tertiary 2 }
 174                 }
 175                 T{ weight-levels
 176                     { primary 12747 }
 177                     { secondary 32 }
 178                     { tertiary 2 }
 179                 }
 180             }
 181         }
 182         {
 183             { 0x0FB3 0x0F75        } ! CE(0FB3) CE(0F71 0F74)
 184             {
 185                 T{ weight-levels
 186                     { primary 12722 }
 187                     { secondary 32 }
 188                     { tertiary 2 }
 189                 }
 190                 T{ weight-levels
 191                     { primary 12747 }
 192                     { secondary 32 }
 193                     { tertiary 2 }
 194                 }
 195             }
 196         }
 197     } ducet get-global '[ swap >string _ set-at ] assoc-each ;
 198
 199 ! These values actually break the collation unit tests in CollationTest_SHIFTED.txt
 200 ! So we disable those tests in favor of supposedly better collation for Tibetan.
 201 ! https://www.unicode.org/reports/tr10/tr10-41.html#Well_Formed_DUCET
 202
 203 fixup-ducet-for-tibetan
 204
 205 : tangut-block? ( char -- ? )
 206     ! Tangut Block, Tangut Components Block
 207     {
 208         [ 0x17000 0x187FF between? ]
 209         [ 0x18800 0x18AFF between? ]
 210         [ 0x18D00 0x18D08 between? ]
 211     } 1|| ; inline
 212
 213 : nushu-block? ( char -- ? )
 214     0x1b170 0x1B2FB between? ; inline
 215
 216 : khitan-block? ( char -- ? )
 217     0x18b00 0x18cd5 between? ; inline
 218
 219 ! https://wiki.computercraft.cc/Module:Unicode_data
 220 ! Unicode TR10 - Computing Implicit Weights
 221 : base ( char -- base )
 222     {
 223         { [ dup 0x03400 0x04DBF between? ] [ drop 0xFB80 ] } ! Extension A
 224         { [ dup 0x20000 0x2A6DF between? ] [ drop 0xFB80 ] } ! Extension B
 225         { [ dup 0x2A700 0x2B738 between? ] [ drop 0xFB80 ] } ! Extension C
 226         { [ dup 0x2B740 0x2B81D between? ] [ drop 0xFB80 ] } ! Extension D
 227         { [ dup 0x2B820 0x2CEA1 between? ] [ drop 0xFB80 ] } ! Extension E
 228         { [ dup 0x2CEB0 0x2EBE0 between? ] [ drop 0xFB80 ] } ! Extension F
 229         { [ dup 0x30000 0x3134A between? ] [ drop 0xFB80 ] } ! Extension G
 230         { [ dup 0x03400 0x04DBF between? ] [ drop 0xFB40 ] } ! CJK
 231         { [ dup 0x04E00 0x09FFF between? ] [ drop 0xFB40 ] } ! CJK
 232         [ drop 0xFBC0 ] ! Other
 233     } cond ;
 234
 235 : tangut-AAAA ( char -- weight-levels )
 236     drop 0xfb00 0x0020 0x0002 <weight-levels> ; inline
 237
 238 : tangut-BBBB ( char -- weight-levels )
 239     0x17000 - 0x8000 bitor 0 0 <weight-levels> ; inline
 240
 241 : nushu-AAAA ( char -- weight-levels )
 242     drop 0xfb01 0x0020 0x0002 <weight-levels> ; inline
 243
 244 : nushu-BBBB ( char -- weight-levels )
 245     0x1B170 - 0x8000 bitor 0 0 <weight-levels> ; inline
 246
 247 : khitan-AAAA ( char -- weight-levels )
 248     drop 0xfb02 0x0020 0x0002 <weight-levels> ; inline
 249
 250 : khitan-BBBB ( char -- weight-levels )
 251     0x18b00 - 0x8000 bitor 0 0 <weight-levels> ; inline
 252
 253 : AAAA ( char -- weight-levels )
 254     [ base ] [ -15 shift ] bi + 0x0020 0x0002 <weight-levels> ; inline
 255
 256 : BBBB ( char -- weight-levels )
 257     0x7FFF bitand 0x8000 bitor 0 0 <weight-levels> ; inline
 258
 259 : derive-weight ( 1string -- weight-levels-pair )
 260     first
 261     {
 262         { [ dup tangut-block? ] [ [ tangut-AAAA ] [ tangut-BBBB ] bi 2array ] }
 263         { [ dup nushu-block? ] [ [ nushu-AAAA ] [ nushu-BBBB ] bi 2array ] }
 264         { [ dup khitan-block? ] [ [ khitan-AAAA ] [ khitan-BBBB ] bi 2array ] }
 265         [ [ AAAA ] [ BBBB ] bi 2array ]
 266     } cond ;
 267
 268 : building-last ( -- char )
 269     building get [ 0 ] [ last last ] if-empty ;
 270
 271 ! https://www.unicode.org/reports/tr10/tr10-41.html#Collation_Graphemes
 272 : blocked? ( char -- ? )
 273     combining-class dup { 0 f } member?
 274     [ drop building-last non-starter? ]
 275     [ building-last combining-class = ] if ;
 276
 277 : possible-bases ( -- slice-of-building )
 278     building get dup [ first non-starter? not ] find-last
 279     drop [ 0 ] unless* tail-slice ;
 280
 281 :: ?combine ( char slice i -- ? )
 282     i slice nth char suffix :> str
 283     str ducet get-global key? dup
 284     [ str i slice set-nth ] when ;
 285
 286 : add ( char -- )
 287     dup blocked? [ 1string , ] [
 288         dup possible-bases dup length <iota>
 289         [ ?combine ] 2with any?
 290         [ drop ] [ 1string , ] if
 291     ] if ;
 292
 293 : string>graphemes ( string -- graphemes )
 294     [ [ add ] each ] { } make ;
 295
 296 : char>weight-levels ( 1string -- weight-levels )
 297     ducet get-global ?at [ derive-weight ] unless ; inline
 298
 299 : graphemes>weights ( graphemes -- weights )
 300     [
 301         dup weight-levels?
 302         [ 1array ] ! From tailoring
 303         [ char>weight-levels ] if
 304     ] { } map-as concat ;
 305
 306 : append-weights ( weight-levels quot -- seq )
 307     [ [ ignorable?>> ] reject ] dip
 308     map [ zero? ] reject ; inline
 309
 310 : variable-weight ( weight-levels -- obj )
 311     dup ignorable?>> [ primary>> ] [ drop 0xFFFF ] if ;
 312
 313 : weights>bytes ( weights -- array )
 314     [
 315         {
 316             [ [ primary>> ] append-weights { 0 } ]
 317             [ [ secondary>> ] append-weights { 0 } ]
 318             [ [ tertiary>> ] append-weights { 0 } ]
 319             [ [ [ secondary>> ] [ tertiary>> ] bi [ zero? ] both? ] reject [ variable-weight ] map ]
 320         } cleave
 321     ] { } append-outputs-as ;
 322
 323 PRIVATE>
 324
 325 : completely-ignorable? ( weight -- ? )
 326     {
 327         [ primary>> zero? ]
 328         [ secondary>> zero? ]
 329         [ tertiary>> zero? ]
 330     } 1&& ;
 331
 332 : filter-ignorable ( weights -- weights' )
 333     f swap [
 334         [ nip ] [ primary>> zero? and ] 2bi
 335         [ swap ignorable?>> or ]
 336         [ swap completely-ignorable? or not ] 2bi
 337     ] filter nip ;