basis/unicode/normalize/normalize.factor

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