basis/unicode/normalize/normalize.factor

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