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