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