basis/unicode/collation/collation.factor

   1 USING: combinators.short-circuit sequences io.files\r
   2 io.encodings.ascii kernel values splitting accessors math.parser\r
   3 ascii io assocs strings math namespaces make sorting combinators\r
   4 math.order arrays unicode.normalize unicode.data locals\r
   5 unicode.syntax macros sequences.deep words unicode.breaks\r
   6 quotations ;\r
   7 IN: unicode.collation\r
   8 \r
   9 <PRIVATE\r
  10 VALUE: ducet\r
  11 \r
  12 TUPLE: weight primary secondary tertiary ignorable? ;\r
  13 \r
  14 : parse-weight ( string -- weight )\r
  15     "]" split but-last [\r
  16         weight new swap rest unclip CHAR: * = swapd >>ignorable?\r
  17         swap "." split first3 [ hex> ] tri@\r
  18         [ >>primary ] [ >>secondary ] [ >>tertiary ] tri*\r
  19     ] map ;\r
  20 \r
  21 : parse-line ( line -- code-poing weight )\r
  22     ";" split1 [ [ blank? ] trim ] bi@\r
  23     [ " " split [ hex> ] "" map-as ] [ parse-weight ] bi* ;\r
  24 \r
  25 : parse-ducet ( stream -- ducet )\r
  26     lines filter-comments\r
  27     [ parse-line ] H{ } map>assoc ;\r
  28 \r
  29 "resource:basis/unicode/collation/allkeys.txt"\r
  30 ascii <file-reader> parse-ducet to: ducet\r
  31 \r
  32 ! Fix up table for long contractions\r
  33 : help-one ( assoc key -- )\r
  34     ! Need to be more general? Not for DUCET, apparently\r
  35     2 head 2dup swap key? [ 2drop ] [\r
  36         [ [ 1string swap at ] with { } map-as concat ]\r
  37         [ swap set-at ] 2bi\r
  38     ] if ;\r
  39 \r
  40 : insert-helpers ( assoc -- )\r
  41     dup keys [ length 3 >= ] filter\r
  42     [ help-one ] with each ;\r
  43 \r
  44 ducet insert-helpers\r
  45 \r
  46 : base ( char -- base )\r
  47     {\r
  48         { [ dup HEX: 3400 HEX:  4DB5 between? ] [ drop HEX: FB80 ] } ! Extension A\r
  49         { [ dup HEX: 20000 HEX: 2A6D6 between? ] [ drop HEX: FB80 ] } ! Extension B\r
  50         { [ dup HEX: 4E00 HEX: 9FC3 between? ] [ drop HEX: FB40 ] } ! CJK\r
  51         [ drop HEX: FBC0 ] ! Other\r
  52     } cond ;\r
  53 \r
  54 : AAAA ( char -- weight )\r
  55     [ base ] [ -15 shift ] bi + HEX: 20 2 f weight boa ;\r
  56 \r
  57 : BBBB ( char -- weight )\r
  58     HEX: 7FFF bitand HEX: 8000 bitor 0 0 f weight boa ;\r
  59 \r
  60 : illegal? ( char -- ? )\r
  61     { [ "Noncharacter_Code_Point" property? ] [ category "Cs" = ] } 1|| ;\r
  62 \r
  63 : derive-weight ( char -- weights )\r
  64     first dup illegal?\r
  65     [ drop { } ]\r
  66     [ [ AAAA ] [ BBBB ] bi 2array ] if ;\r
  67 \r
  68 : last ( -- char )\r
  69     building get empty? [ 0 ] [ building get peek peek ] if ;\r
  70 \r
  71 : blocked? ( char -- ? )\r
  72     combining-class [\r
  73         last combining-class =\r
  74     ] [ last combining-class ] if* ;\r
  75 \r
  76 : possible-bases ( -- slice-of-building )\r
  77     building get dup [ first combining-class not ] find-last\r
  78     drop [ 0 ] unless* tail-slice ;\r
  79 \r
  80 :: ?combine ( char slice i -- ? )\r
  81     [let | str [ i slice nth char suffix ] |\r
  82         str ducet key? dup\r
  83         [ str i slice set-nth ] when\r
  84     ] ;\r
  85 \r
  86 : add ( char -- )\r
  87     dup blocked? [ 1string , ] [\r
  88         dup possible-bases dup length\r
  89         [ ?combine ] with with contains?\r
  90         [ drop ] [ 1string , ] if\r
  91     ] if ;\r
  92 \r
  93 : string>graphemes ( string -- graphemes )\r
  94     [ [ add ] each ] { } make ;\r
  95 \r
  96 : graphemes>weights ( graphemes -- weights )\r
  97     [\r
  98         dup weight? [ 1array ] ! From tailoring\r
  99         [ dup ducet at [ ] [ derive-weight ] ?if ] if\r
 100     ] { } map-as concat ;\r
 101 \r
 102 : append-weights ( weights quot -- )\r
 103     swap [ ignorable?>> not ] filter\r
 104     swap map [ zero? not ] filter % 0 , ;\r
 105 \r
 106 : variable-weight ( weight -- )\r
 107     dup ignorable?>> [ primary>> ] [ drop HEX: FFFF ] if , ;\r
 108 \r
 109 : weights>bytes ( weights -- byte-array )\r
 110     [\r
 111         {\r
 112             [ [ primary>> ] append-weights ]\r
 113             [ [ secondary>> ] append-weights ]\r
 114             [ [ tertiary>> ] append-weights ]\r
 115             [ [ variable-weight ] each ]\r
 116         } cleave\r
 117     ] { } make ;\r
 118 PRIVATE>\r
 119 \r
 120 : completely-ignorable? ( weight -- ? )\r
 121     [ primary>> ] [ secondary>> ] [ tertiary>> ] tri\r
 122     [ zero? ] tri@ and and ;\r
 123 \r
 124 : filter-ignorable ( weights -- weights' )\r
 125     >r f r> [\r
 126         tuck primary>> zero? and\r
 127         [ swap ignorable?>> or ]\r
 128         [ swap completely-ignorable? or not ] 2bi\r
 129     ] filter nip ;\r
 130 \r
 131 : collation-key ( string -- key )\r
 132     nfd string>graphemes graphemes>weights\r
 133     filter-ignorable weights>bytes ;\r
 134 \r
 135 <PRIVATE\r
 136 : insensitive= ( str1 str2 levels-removed -- ? )\r
 137     [\r
 138         swap collation-key swap\r
 139         [ [ 0 = not ] trim-right but-last ] times\r
 140     ] curry bi@ = ;\r
 141 PRIVATE>\r
 142 \r
 143 : primary= ( str1 str2 -- ? )\r
 144     3 insensitive= ;\r
 145 \r
 146 : secondary= ( str1 str2 -- ? )\r
 147     2 insensitive= ;\r
 148 \r
 149 : tertiary= ( str1 str2 -- ? )\r
 150     1 insensitive= ;\r
 151 \r
 152 : quaternary= ( str1 str2 -- ? )\r
 153     0 insensitive= ;\r
 154 \r
 155 <PRIVATE\r
 156 : w/collation-key ( str -- {str,key} )\r
 157     [ collation-key ] keep 2array ;\r
 158 PRIVATE>\r
 159 \r
 160 : sort-strings ( strings -- sorted )\r
 161     [ w/collation-key ] map\r
 162     natural-sort values ;\r
 163 \r
 164 : string<=> ( str1 str2 -- <=> )\r
 165     [ w/collation-key ] compare ;\r