basis/unicode/normalize/normalize.factor

   1 ! Copyright (C) 2008 Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: ascii sequences namespaces make unicode.data kernel math arrays
   4 locals sorting.insertion accessors assocs math.order combinators
   5 unicode.syntax strings sbufs hints combinators.short-circuit vectors ;
   6 IN: unicode.normalize
   7
   8 <PRIVATE
   9 ! Conjoining Jamo behavior
  10
  11 CONSTANT: hangul-base HEX: ac00
  12 CONSTANT: hangul-end HEX: D7AF
  13 CONSTANT: initial-base HEX: 1100
  14 CONSTANT: medial-base HEX: 1161
  15 CONSTANT: final-base HEX: 11a7
  16
  17 CONSTANT: initial-count 19
  18 CONSTANT: medial-count 21
  19 CONSTANT: final-count 28
  20
  21 : ?between? ( n/f from to -- ? )
  22     pick [ between? ] [ 3drop f ] if ; inline
  23
  24 : hangul? ( ch -- ? ) hangul-base hangul-end ?between? ; inline
  25 : jamo? ( ch -- ? ) HEX: 1100 HEX: 11FF ?between? ; inline
  26
  27 ! These numbers come from UAX 29
  28 : initial? ( ch -- ? )
  29     dup HEX: 1100 HEX: 1159 ?between? [ ] [ HEX: 115F = ] ?if ; inline
  30 : medial? ( ch -- ? ) HEX: 1160 HEX: 11A2 ?between? ; inline
  31 : final? ( ch -- ? ) HEX: 11A8 HEX: 11F9 ?between? ; inline
  32
  33 : hangul>jamo ( hangul -- jamo-string )
  34     hangul-base - final-count /mod final-base +
  35     [
  36         medial-count /mod medial-base +
  37         [ initial-base + ] dip
  38     ] dip
  39     dup final-base = [ drop 2array ] [ 3array ] if ;
  40
  41 : jamo>hangul ( initial medial final -- hangul )
  42     [
  43         [ initial-base - medial-count * ] dip
  44         medial-base - + final-count *
  45     ] dip final-base - + hangul-base + ;
  46
  47 ! Normalization -- Decomposition
  48
  49 : reorder-slice ( string start -- slice done? )
  50     2dup swap [ non-starter? not ] find-from drop
  51     [ [ over length ] unless* rot <slice> ] keep not ; inline
  52
  53 : reorder-next ( string i -- new-i done? )
  54     over [ non-starter? ] find-from drop [
  55         reorder-slice
  56         [ dup [ combining-class ] insertion-sort to>> ] dip
  57     ] [ length t ] if* ; inline
  58
  59 : reorder-loop ( string start -- )
  60     dupd reorder-next [ 2drop ] [ reorder-loop ] if ; inline recursive
  61
  62 : reorder ( string -- )
  63     0 reorder-loop ;
  64
  65 : reorder-back ( string i -- )
  66     over [ non-starter? not ] find-last-from drop ?1+ reorder-next 2drop ;
  67
  68 :: decompose ( string quot -- decomposed )
  69     string length <sbuf> :> out
  70     string [
  71         >fixnum dup ascii? [ out push ] [
  72             dup hangul? [ hangul>jamo out push-all ]
  73             [ dup quot call [ out push-all ] [ out push ] ?if ] if
  74         ] if
  75     ] each
  76     out "" like dup reorder ; inline
  77
  78 : with-string ( str quot -- str )
  79     over aux>> [ call ] [ drop ] if ; inline
  80
  81 : (nfd) ( string -- nfd )
  82     [ canonical-entry ] decompose ;
  83
  84 HINTS: (nfd) string ;
  85
  86 : (nfkd) ( string -- nfkd )
  87     [ compatibility-entry ] decompose ;
  88
  89 HINTS: (nfkd) string ;
  90
  91 PRIVATE>
  92
  93 : nfd ( string -- nfd )
  94     [ (nfd) ] with-string ;
  95
  96 : nfkd ( string -- nfkd )
  97     [ (nfkd) ] with-string ;
  98
  99 : string-append ( s1 s2 -- string )
 100     [ append ] keep
 101     0 over ?nth non-starter?
 102     [ length dupd reorder-back ] [ drop ] if ;
 103
 104 HINTS: string-append string string ;
 105
 106 <PRIVATE
 107
 108 ! Normalization -- Composition
 109
 110 : initial-medial? ( str i -- ? )
 111     { [ swap nth initial? ] [ 1+ swap ?nth medial? ] } 2&& ;
 112
 113 : --final? ( str i -- ? )
 114     2 + swap ?nth final? ;
 115
 116 : imf, ( str i -- str i )
 117     [ tail-slice first3 jamo>hangul , ]
 118     [ 3 + ] 2bi ;
 119
 120 : im, ( str i -- str i )
 121     [ tail-slice first2 final-base jamo>hangul , ]
 122     [ 2 + ] 2bi ;
 123
 124 : compose-jamo ( str i -- str i )
 125     2dup initial-medial? [
 126         2dup --final? [ imf, ] [ im, ] if
 127     ] [ 2dup swap nth , 1+ ] if ;
 128
 129 : pass-combining ( str -- str i )
 130     dup [ non-starter? not ] find drop
 131     [ dup length ] unless*
 132     2dup head-slice % ;
 133
 134 TUPLE: compose-state i str char after last-class ;
 135
 136 : get-str ( state i -- ch )
 137     swap [ i>> + ] [ str>> ] bi ?nth ; inline
 138 : current ( state -- ch ) 0 get-str ; inline
 139 : to ( state -- state ) [ 1+ ] change-i ; inline
 140 : push-after ( ch state -- state ) [ ?push ] change-after ; inline
 141
 142 :: try-compose ( state new-char current-class -- state )
 143     state last-class>> current-class =
 144     [ new-char state push-after ] [
 145         state char>> new-char combine-chars
 146         [ state swap >>char ] [
 147             new-char state push-after
 148             current-class >>last-class
 149         ] if*
 150     ] if ; inline
 151
 152 DEFER: compose-iter
 153
 154 : try-noncombining ( char state -- state )
 155     tuck char>> swap combine-chars
 156     [ >>char to f >>last-class compose-iter ] when* ; inline
 157
 158 : compose-iter ( state -- state )
 159     dup current [
 160         dup combining-class {
 161             { f [ drop ] }
 162             { 0 [
 163                 over last-class>>
 164                 [ drop ] [ swap try-noncombining ] if ] }
 165             [ try-compose to compose-iter ]
 166         } case
 167     ] when* ; inline recursive
 168
 169 : compose-combining ( ch str i -- str i )
 170     compose-state new
 171         swap >>i
 172         swap >>str
 173         swap >>char
 174     compose-iter
 175     { [ char>> , ] [ after>> % ] [ str>> ] [ i>> ] } cleave ; inline
 176
 177 :: (compose) ( str i -- )
 178     i str ?nth [
 179         dup jamo? [ drop str i compose-jamo ] [
 180             i 1+ str ?nth combining-class
 181             [ str i 1+ compose-combining ] [ , str i 1+ ] if
 182         ] if (compose)
 183     ] when* ; inline recursive
 184
 185 : combine ( str -- comp )
 186     [ pass-combining (compose) ] "" make ;
 187
 188 HINTS: combine string ;
 189
 190 PRIVATE>
 191
 192 : nfc ( string -- nfc )
 193     [ (nfd) combine ] with-string ;
 194
 195 : nfkc ( string -- nfkc )
 196     [ (nfkd) combine ] with-string ;