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