! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences namespaces make unicode.data kernel math arrays
+USING: ascii sequences namespaces make unicode.data kernel math arrays
locals sorting.insertion accessors assocs math.order combinators
-unicode.syntax strings sbufs ;
+strings sbufs hints combinators.short-circuit vectors ;
IN: unicode.normalize
<PRIVATE
! Conjoining Jamo behavior
-CONSTANT: hangul-base HEX: ac00
-CONSTANT: hangul-end HEX: D7AF
-CONSTANT: initial-base HEX: 1100
-CONSTANT: medial-base HEX: 1161
-CONSTANT: final-base HEX: 11a7
+CONSTANT: hangul-base 0xac00
+CONSTANT: hangul-end 0xD7AF
+CONSTANT: initial-base 0x1100
+CONSTANT: medial-base 0x1161
+CONSTANT: final-base 0x11a7
CONSTANT: initial-count 19
CONSTANT: medial-count 21
CONSTANT: final-count 28
: ?between? ( n/f from to -- ? )
- pick [ between? ] [ 3drop f ] if ;
+ pick [ between? ] [ 3drop f ] if ; inline
-: hangul? ( ch -- ? ) hangul-base hangul-end ?between? ;
-: jamo? ( ch -- ? ) HEX: 1100 HEX: 11FF ?between? ;
+: hangul? ( ch -- ? ) hangul-base hangul-end ?between? ; inline
+: jamo? ( ch -- ? ) 0x1100 0x11FF ?between? ; inline
! These numbers come from UAX 29
: initial? ( ch -- ? )
- dup HEX: 1100 HEX: 1159 ?between? [ ] [ HEX: 115F = ] ?if ;
-: medial? ( ch -- ? ) HEX: 1160 HEX: 11A2 ?between? ;
-: final? ( ch -- ? ) HEX: 11A8 HEX: 11F9 ?between? ;
+ dup 0x1100 0x1159 ?between? [ ] [ 0x115F = ] ?if ; inline
+: medial? ( ch -- ? ) 0x1160 0x11A2 ?between? ; inline
+: final? ( ch -- ? ) 0x11A8 0x11F9 ?between? ; inline
: hangul>jamo ( hangul -- jamo-string )
hangul-base - final-count /mod final-base +
: reorder-slice ( string start -- slice done? )
2dup swap [ non-starter? not ] find-from drop
- [ [ over length ] unless* rot <slice> ] keep not ;
+ [ [ over length ] unless* rot <slice> ] keep not ; inline
: reorder-next ( string i -- new-i done? )
over [ non-starter? ] find-from drop [
reorder-slice
[ dup [ combining-class ] insertion-sort to>> ] dip
- ] [ length t ] if* ;
+ ] [ length t ] if* ; inline
: reorder-loop ( string start -- )
- dupd reorder-next [ 2drop ] [ reorder-loop ] if ;
+ dupd reorder-next [ 2drop ] [ reorder-loop ] if ; inline recursive
: reorder ( string -- )
0 reorder-loop ;
over [ non-starter? not ] find-last-from drop ?1+ reorder-next 2drop ;
:: decompose ( string quot -- decomposed )
- [let | out [ string length <sbuf> ] |
- string [
+ string length <sbuf> :> out
+ string [
+ >fixnum dup ascii? [ out push ] [
dup hangul? [ hangul>jamo out push-all ]
[ dup quot call [ out push-all ] [ out push ] ?if ] if
- ] each out >string
- ] dup reorder ;
+ ] if
+ ] each
+ out "" like dup reorder ; inline
: with-string ( str quot -- str )
over aux>> [ call ] [ drop ] if ; inline
: (nfd) ( string -- nfd )
[ canonical-entry ] decompose ;
+HINTS: (nfd) string ;
+
: (nfkd) ( string -- nfkd )
[ compatibility-entry ] decompose ;
+HINTS: (nfkd) string ;
+
PRIVATE>
: nfd ( string -- nfd )
0 over ?nth non-starter?
[ length dupd reorder-back ] [ drop ] if ;
+HINTS: string-append string string ;
+
<PRIVATE
! Normalization -- Composition
-SYMBOL: main-str
-SYMBOL: ind
-SYMBOL: after
-SYMBOL: char
-: get-str ( i -- ch ) ind get + main-str get ?nth ;
-: current ( -- ch ) 0 get-str ;
-: to ( -- ) ind inc ;
+: initial-medial? ( str i -- ? )
+ { [ swap nth initial? ] [ 1 + swap ?nth medial? ] } 2&& ;
-: initial-medial? ( -- ? )
- current initial? [ 1 get-str medial? ] [ f ] if ;
+: --final? ( str i -- ? )
+ 2 + swap ?nth final? ;
-: --final? ( -- ? )
- 2 get-str final? ;
+: imf, ( str i -- str i )
+ [ tail-slice first3 jamo>hangul , ]
+ [ 3 + ] 2bi ;
-: imf, ( -- )
- current to current to current jamo>hangul , ;
+: im, ( str i -- str i )
+ [ tail-slice first2 final-base jamo>hangul , ]
+ [ 2 + ] 2bi ;
-: im, ( -- )
- current to current final-base jamo>hangul , ;
+: compose-jamo ( str i -- str i )
+ 2dup initial-medial? [
+ 2dup --final? [ imf, ] [ im, ] if
+ ] [ 2dup swap nth , 1 + ] if ;
-: compose-jamo ( -- )
- initial-medial? [
- --final? [ imf, ] [ im, ] if
- ] [ current , ] if to ;
+: pass-combining ( str -- str i )
+ dup [ non-starter? not ] find drop
+ [ dup length ] unless*
+ 2dup head-slice % ;
-: pass-combining ( -- )
- current non-starter? [ current , to pass-combining ] when ;
+TUPLE: compose-state i str char after last-class ;
-:: try-compose ( last-class new-char current-class -- new-class )
- last-class current-class = [ new-char after get push last-class ] [
- char get new-char combine-chars
- [ char set last-class ]
- [ new-char after get push current-class ] if*
- ] if ;
+: get-str ( state i -- ch )
+ swap [ i>> + ] [ str>> ] bi ?nth ; inline
+: current ( state -- ch ) 0 get-str ; inline
+: to ( state -- state ) [ 1 + ] change-i ; inline
+: push-after ( ch state -- state ) [ ?push ] change-after ; inline
+
+:: try-compose ( state new-char current-class -- state )
+ state last-class>> current-class =
+ [ new-char state push-after ] [
+ state char>> new-char combine-chars
+ [ state swap >>char ] [
+ new-char state push-after
+ current-class >>last-class
+ ] if*
+ ] if ; inline
DEFER: compose-iter
-: try-noncombining ( char -- )
- char get swap combine-chars
- [ char set to f compose-iter ] when* ;
+: try-noncombining ( state char -- state )
+ [ drop ] [ [ char>> ] dip combine-chars ] 2bi
+ [ >>char to f >>last-class compose-iter ] when* ; inline
-: compose-iter ( last-class -- )
- current [
+: compose-iter ( state -- state )
+ dup current [
dup combining-class {
- { f [ 2drop ] }
- { 0 [ swap [ drop ] [ try-noncombining ] if ] }
+ { f [ drop ] }
+ { 0 [
+ over last-class>>
+ [ drop ] [ try-noncombining ] if ] }
[ try-compose to compose-iter ]
} case
- ] [ drop ] if* ;
-
-: ?new-after ( -- )
- after [ dup empty? [ drop SBUF" " clone ] unless ] change ;
-
-: compose-combining ( ch -- )
- char set to ?new-after
- f compose-iter
- char get , after get % ;
-
-: (compose) ( -- )
- current [
- dup jamo? [ drop compose-jamo ] [
- 1 get-str combining-class
- [ compose-combining ] [ , to ] if
+ ] when* ; inline recursive
+
+: compose-combining ( ch str i -- str i )
+ compose-state new
+ swap >>i
+ swap >>str
+ swap >>char
+ compose-iter
+ { [ char>> , ] [ after>> % ] [ str>> ] [ i>> ] } cleave ; inline
+
+:: (compose) ( str i -- )
+ i str ?nth [
+ dup jamo? [ drop str i compose-jamo ] [
+ i 1 + str ?nth combining-class
+ [ str i 1 + compose-combining ] [ , str i 1 + ] if
] if (compose)
- ] when* ;
+ ] when* ; inline recursive
: combine ( str -- comp )
- [
- main-str set
- 0 ind set
- SBUF" " clone after set
- pass-combining (compose)
- ] "" make ;
+ [ pass-combining (compose) ] "" make ;
+
+HINTS: combine string ;
PRIVATE>
projects / factor.git / blobdiff