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 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 : insert-helpers ( assoc -- )
  44     dup keys [ length 3 >= ] filter [ help-one ] with each ;
  45
  46 ducet get-global insert-helpers
  47
  48 : tangut-block? ( char -- ? )
  49     ! Tangut Block, Tangut Components Block
  50     { [ 0x17000 0x187FF between? ] [ 0x18800 0x18AFF between? ] } 1|| ; inline
  51
  52 ! Unicode TR10 - Computing Implicit Weights
  53 : base ( char -- base )
  54     {
  55         { [ dup 0x03400 0x04DB5 between? ] [ drop 0xFB80 ] } ! Extension A
  56         { [ dup 0x20000 0x2A6D6 between? ] [ drop 0xFB80 ] } ! Extension B
  57         { [ dup 0x2A700 0x2B734 between? ] [ drop 0xFB80 ] } ! Extension C
  58         { [ dup 0x2B740 0x2B81D between? ] [ drop 0xFB80 ] } ! Extension D
  59         { [ dup 0x2B820 0x2CEA1 between? ] [ drop 0xFB80 ] } ! Extension E
  60         { [ dup 0x04E00 0x09FD5 between? ] [ drop 0xFB40 ] } ! CJK
  61         [ drop 0xFBC0 ] ! Other
  62     } cond ;
  63
  64 : tangut-AAAA ( char -- weight-levels )
  65     drop 0xfb00 0x0020 0x0002 <weight-levels> ; inline
  66
  67 : tangut-BBBB ( char -- weight-levels )
  68     0x17000 - 0x8000 bitor 0 0 <weight-levels> ; inline
  69
  70 : AAAA ( char -- weight-levels )
  71     [ base ] [ -15 shift ] bi + 0x0020 0x0002 <weight-levels> ; inline
  72
  73 : BBBB ( char -- weight-levels )
  74     0x7FFF bitand 0x8000 bitor 0 0 <weight-levels> ; inline
  75
  76 : illegal? ( char -- ? )
  77     {
  78         [ "Noncharacter_Code_Point" property? ]
  79         [ category "Cs" = ]
  80     } 1|| ;
  81
  82 : derive-weight ( 1string -- weight-levels-pair )
  83     first
  84     dup tangut-block? [
  85         [ tangut-AAAA ] [ tangut-BBBB ] bi 2array
  86     ] [
  87         dup illegal? [
  88             drop { }
  89         ] [
  90             [ AAAA ] [ BBBB ] bi 2array
  91         ] if
  92     ] if ;
  93
  94 : building-last ( -- char )
  95     building get [ 0 ] [ last last ] if-empty ;
  96
  97 : blocked? ( char -- ? )
  98     combining-class dup { 0 f } member?
  99     [ drop building-last non-starter? ]
 100     [ building-last combining-class = ] if ;
 101
 102 : possible-bases ( -- slice-of-building )
 103     building get dup [ first non-starter? not ] find-last
 104     drop [ 0 ] unless* tail-slice ;
 105
 106 :: ?combine ( char slice i -- ? )
 107     i slice nth char suffix :> str
 108     str ducet get-global key? dup
 109     [ str i slice set-nth ] when ;
 110
 111 : add ( char -- )
 112     dup blocked? [ 1string , ] [
 113         dup possible-bases dup length <iota>
 114         [ ?combine ] 2with any?
 115         [ drop ] [ 1string , ] if
 116     ] if ;
 117
 118 : string>graphemes ( string -- graphemes )
 119     [ [ add ] each ] { } make ;
 120
 121 : char>weight-levels ( 1string -- weight-levels )
 122     ducet get-global ?at [ derive-weight ] unless ; inline
 123
 124 : graphemes>weights ( graphemes -- weights )
 125     [
 126         dup weight-levels?
 127         [ 1array ] ! From tailoring
 128         [ char>weight-levels ] if
 129     ] { } map-as concat ;
 130
 131 : append-weights ( weight-levels quot -- seq )
 132     [ [ ignorable?>> ] reject ] dip
 133     map [ zero? ] reject ; inline
 134
 135 : variable-weight ( weight-levels -- obj )
 136     dup ignorable?>> [ primary>> ] [ drop 0xFFFF ] if ;
 137
 138 : weights>bytes ( weights -- array )
 139     [
 140         {
 141             [ [ primary>> ] append-weights { 0 } ]
 142             [ [ secondary>> ] append-weights { 0 } ]
 143             [ [ tertiary>> ] append-weights { 0 } ]
 144             [ [ [ secondary>> ] [ tertiary>> ] bi [ zero? ] bi@ and not ] filter [ variable-weight ] map ]
 145         } cleave
 146     ] { } append-outputs-as ;
 147
 148 PRIVATE>
 149
 150 : completely-ignorable? ( weight -- ? )
 151     {
 152         [ primary>> zero? ]
 153         [ secondary>> zero? ]
 154         [ tertiary>> zero? ]
 155     } 1&& ;
 156
 157 : filter-ignorable ( weights -- weights' )
 158     f swap [
 159         [ nip ] [ primary>> zero? and ] 2bi
 160         [ swap ignorable?>> or ]
 161         [ swap completely-ignorable? or not ] 2bi
 162     ] filter nip ;