basis/unicode/collation/collation.factor

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