611 lines
23 KiB
Scheme
611 lines
23 KiB
Scheme
;;; Copyright (C) 2008 Abdulaziz Ghuloum, R. Kent Dybvig
|
|
;;; Copyright (C) 2006,2007 Abdulaziz Ghuloum
|
|
;;;
|
|
;;; Permission is hereby granted, free of charge, to any person obtaining a
|
|
;;; copy of this software and associated documentation files (the "Software"),
|
|
;;; to deal in the Software without restriction, including without limitation
|
|
;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
|
|
;;; and/or sell copies of the Software, and to permit persons to whom the
|
|
;;; Software is furnished to do so, subject to the following conditions:
|
|
;;;
|
|
;;; The above copyright notice and this permission notice shall be included in
|
|
;;; all copies or substantial portions of the Software.
|
|
;;;
|
|
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
|
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
|
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
|
|
;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
|
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
|
|
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
|
|
;;; DEALINGS IN THE SOFTWARE.
|
|
|
|
(library (ikarus.unicode)
|
|
(export
|
|
unicode-printable-char?
|
|
char-upcase char-downcase char-titlecase char-foldcase
|
|
char-whitespace? char-lower-case? char-upper-case?
|
|
char-title-case? char-numeric?
|
|
char-alphabetic? char-general-category char-ci<? char-ci<=?
|
|
char-ci=? char-ci>? char-ci>=? string-upcase string-downcase
|
|
string-foldcase string-titlecase string-ci<? string-ci<=?
|
|
string-ci=? string-ci>? string-ci>=? string-normalize-nfd
|
|
string-normalize-nfkd string-normalize-nfc string-normalize-nfkc )
|
|
(import
|
|
(ikarus include)
|
|
(except (ikarus)
|
|
unicode-printable-char?
|
|
char-upcase char-downcase char-titlecase char-foldcase
|
|
char-whitespace? char-lower-case? char-upper-case?
|
|
char-title-case? char-numeric?
|
|
char-alphabetic? char-general-category char-ci<? char-ci<=?
|
|
char-ci=? char-ci>? char-ci>=? string-upcase string-downcase
|
|
string-foldcase string-titlecase string-ci<? string-ci<=?
|
|
string-ci=? string-ci>? string-ci>=? string-normalize-nfd
|
|
string-normalize-nfkd string-normalize-nfc string-normalize-nfkc ))
|
|
|
|
|
|
|
|
(module UNSAFE
|
|
(fx< fx<= fx> fx>= fx= fx+ fx-
|
|
fxior fxand fxsra fxsll fxzero?
|
|
integer->char char->integer
|
|
char<? char<=? char=? char>? char>=?
|
|
string-ref string-set! string-length
|
|
vector-ref vector-set! vector-length)
|
|
(import
|
|
(rename (ikarus system $strings)
|
|
($string-length string-length)
|
|
($string-ref string-ref)
|
|
($string-set! string-set!))
|
|
(rename (ikarus system $vectors)
|
|
($vector-length vector-length)
|
|
($vector-ref vector-ref)
|
|
($vector-set! vector-set!))
|
|
(rename (ikarus system $chars)
|
|
($char->fixnum char->integer)
|
|
($fixnum->char integer->char)
|
|
($char< char<?)
|
|
($char<= char<=?)
|
|
($char= char=?)
|
|
($char> char>?)
|
|
($char>= char>=?))
|
|
(rename (ikarus system $fx)
|
|
($fxzero? fxzero?)
|
|
($fxsra fxsra)
|
|
($fxsll fxsll)
|
|
($fxlogor fxior)
|
|
($fxlogand fxand)
|
|
($fx+ fx+)
|
|
($fx- fx-)
|
|
($fx< fx<)
|
|
($fx> fx>)
|
|
($fx>= fx>=)
|
|
($fx<= fx<=)
|
|
($fx= fx=))))
|
|
|
|
(module
|
|
(unicode-printable-char?
|
|
char-upcase char-downcase char-titlecase char-foldcase
|
|
char-whitespace? char-lower-case? char-upper-case?
|
|
char-title-case? char-numeric?
|
|
char-alphabetic? char-general-category char-ci<? char-ci<=?
|
|
char-ci=? char-ci>? char-ci>=? string-upcase string-downcase
|
|
string-foldcase string-titlecase string-ci<? string-ci<=?
|
|
string-ci=? string-ci>? string-ci>=? string-normalize-nfd
|
|
string-normalize-nfkd string-normalize-nfc string-normalize-nfkc)
|
|
|
|
(import UNSAFE)
|
|
(define (fxlogtest x y)
|
|
(not (fxzero? (fxand x y))))
|
|
(define (char- x y)
|
|
(fx- (char->integer x) (char->integer y)))
|
|
|
|
(include "unicode/unicode-char-cases.ss")
|
|
(include "unicode/unicode-charinfo.ss")
|
|
|
|
(define-syntax define-char-op
|
|
(syntax-rules ()
|
|
[(_ name unsafe-op)
|
|
(define name
|
|
(lambda (c)
|
|
(if (char? c)
|
|
(unsafe-op c)
|
|
(assertion-violation 'name "not a char" c))))]))
|
|
|
|
(define-char-op char-upcase $char-upcase)
|
|
(define-char-op char-downcase $char-downcase)
|
|
(define-char-op char-titlecase $char-titlecase)
|
|
(define-char-op char-foldcase $char-foldcase)
|
|
(define-char-op char-whitespace? $char-whitespace?)
|
|
(define-char-op char-lower-case? $char-lower-case?)
|
|
(define-char-op char-upper-case? $char-upper-case?)
|
|
(define-char-op char-title-case? $char-title-case?)
|
|
(define-char-op char-numeric? $char-numeric?)
|
|
(define-char-op unicode-printable-char? $char-constituent?)
|
|
(define-char-op char-alphabetic? $char-alphabetic?)
|
|
(define-char-op char-general-category $char-category)
|
|
|
|
(define (do-char-cmp a ls cmp who)
|
|
(if (char? a)
|
|
(let f ([a ($char-foldcase a)] [ls ls])
|
|
(cond
|
|
[(null? ls) #t]
|
|
[else
|
|
(let ([b (car ls)])
|
|
(if (char? b)
|
|
(let ([b ($char-foldcase b)])
|
|
(if (cmp a b)
|
|
(f b (cdr ls))
|
|
(let f ([ls (cdr ls)])
|
|
(if (null? ls)
|
|
#f
|
|
(if (char? (car ls))
|
|
(f (cdr ls))
|
|
(assertion-violation who
|
|
"not a char" (car ls)))))))
|
|
(assertion-violation who "not a char" b)))]))
|
|
(assertion-violation who "not a char" a)))
|
|
|
|
(define-syntax define-char-cmp
|
|
(syntax-rules ()
|
|
[(_ name cmp)
|
|
(define name
|
|
(case-lambda
|
|
[(c1 c2)
|
|
(if (char? c1)
|
|
(if (char? c2)
|
|
(cmp ($char-foldcase c1) ($char-foldcase c2))
|
|
(assertion-violation 'name "not a char" c2))
|
|
(assertion-violation 'name "not a char" c1))]
|
|
[(c1 . rest)
|
|
(do-char-cmp c1 rest (lambda (x y) (cmp x y)) 'name)]))]))
|
|
|
|
(define-char-cmp char-ci<? char<?)
|
|
(define-char-cmp char-ci<=? char<=?)
|
|
(define-char-cmp char-ci=? char=?)
|
|
(define-char-cmp char-ci>? char>?)
|
|
(define-char-cmp char-ci>=? char>=?)
|
|
|
|
(define (handle-special str ac)
|
|
(define (chars ac n)
|
|
(cond
|
|
[(null? ac) n]
|
|
[else
|
|
(chars (cdr ac)
|
|
(let f ([p (cdar ac)] [n n])
|
|
(cond
|
|
[(pair? p) (f (cdr p) (fx+ n 1))]
|
|
[else n])))]))
|
|
(define (extend src ac src-len dst-len)
|
|
(let f ([str str] [dst (make-string dst-len)] [i 0] [j 0] [ac (reverse ac)] [sigma* '()])
|
|
(cond
|
|
[(null? ac)
|
|
(string-copy! str i dst j (fx- src-len i))
|
|
(do-sigmas dst sigma*)]
|
|
[else
|
|
(let ([idx (caar ac)] [c* (cdar ac)] [ac (cdr ac)])
|
|
(let ([cnt (fx- idx i)])
|
|
(string-copy! str i dst j cnt)
|
|
(let g ([str str] [dst dst]
|
|
[i (fx+ i cnt)] [j (fx+ j cnt)]
|
|
[ac ac] [c* c*])
|
|
(cond
|
|
[(pair? c*)
|
|
(string-set! dst j (car c*))
|
|
(g str dst i (fx+ j 1) ac (cdr c*))]
|
|
[(char? c*)
|
|
(string-set! dst j c*)
|
|
(f str dst (fx+ i 1) (fx+ j 1) ac sigma*)]
|
|
[else ; assume c* = sigma
|
|
(f str dst (fx+ i 1) (fx+ j 1) ac (cons j sigma*))]))))])))
|
|
(define (do-sigmas str sigma*)
|
|
(define nonfinal-sigma #\x3c3)
|
|
(define final-sigma #\x3c2)
|
|
(define (final? i)
|
|
(define (scan i incr n)
|
|
(and (not (fx= i n))
|
|
(or ($char-cased? (string-ref str i))
|
|
(and ($char-case-ignorable? (string-ref str i))
|
|
(scan (fx+ i incr) incr n)))))
|
|
(and (scan (fx- i 1) -1 -1) (not (scan (fx+ i 1) +1 (string-length str)))))
|
|
; scanning requires we have some character in place...guess nonfinal sigma
|
|
(for-each (lambda (i) (string-set! str i nonfinal-sigma)) sigma*)
|
|
(for-each (lambda (i) (when (final? i) (string-set! str i final-sigma))) sigma*)
|
|
str)
|
|
(let* ([src-len (string-length str)]
|
|
[dst-len (chars ac src-len)])
|
|
(if (fx= dst-len src-len)
|
|
(do-sigmas str (map car ac))
|
|
(extend str ac src-len dst-len))))
|
|
|
|
(define ($string-change-case str cvt-char)
|
|
(let ([n (string-length str)])
|
|
(let f ([str str] [dst (make-string n)] [i 0] [n n] [ac '()])
|
|
(cond
|
|
[(fx= i n)
|
|
(if (null? ac)
|
|
dst
|
|
(handle-special dst ac))]
|
|
[else
|
|
(let ([c/ls (cvt-char (string-ref str i))])
|
|
(cond
|
|
[(char? c/ls)
|
|
(string-set! dst i c/ls)
|
|
(f str dst (fx+ i 1) n ac)]
|
|
[else
|
|
(f str dst (fx+ i 1) n
|
|
(cons (cons i c/ls) ac))]))]))))
|
|
|
|
|
|
|
|
(define-syntax define-string-op
|
|
(syntax-rules ()
|
|
[(_ name unsafe-op)
|
|
(define name
|
|
(lambda (s)
|
|
(if (string? s)
|
|
(unsafe-op s)
|
|
(assertion-violation 'name "not a string" s))))]))
|
|
|
|
(define-string-op string-upcase
|
|
(lambda (s) ($string-change-case s $str-upcase)))
|
|
|
|
(define-string-op string-foldcase
|
|
(lambda (s) ($string-change-case s $str-foldcase)))
|
|
|
|
(define-string-op string-downcase
|
|
(lambda (s) ($string-change-case s $str-downcase)))
|
|
|
|
(define-string-op string-titlecase
|
|
(lambda (str)
|
|
(let* ([n (string-length str)] [dst (make-string n)])
|
|
(define (trans2 s i seen-cased? ac)
|
|
(if (fx= i n)
|
|
(handle-special dst ac)
|
|
(s i seen-cased? ac)))
|
|
(define (trans1 s i c/ls seen-cased? ac)
|
|
(cond
|
|
[(char? c/ls)
|
|
(string-set! dst i c/ls)
|
|
(trans2 s (fx+ i 1) seen-cased? ac)]
|
|
[else
|
|
(trans2 s (fx+ i 1) seen-cased? (cons (cons i c/ls) ac))]))
|
|
(define (trans s i c seen-cased? ac)
|
|
(if seen-cased?
|
|
(trans1 s i ($str-downcase c) #t ac)
|
|
(if ($char-cased? c)
|
|
(trans1 s i ($str-titlecase c) #t ac)
|
|
(trans1 s i c #f ac))))
|
|
(define (s0 i ac)
|
|
(let ([c (string-ref str i)])
|
|
(cond
|
|
[($wb-aletter? c) (trans sAletter i c #f ac)]
|
|
[($wb-numeric? c) (trans sNumeric i c #f ac)]
|
|
[($wb-katakana? c) (trans sKatakana i c #f ac)]
|
|
[($wb-extendnumlet? c) (trans sExtendnumlet i c #f ac)]
|
|
[else (string-set! dst i c)
|
|
(let ([i (fx+ i 1)])
|
|
(if (fx= i n)
|
|
(handle-special dst ac)
|
|
(s0 i ac)))])))
|
|
(define (sAletter i seen-cased? ac)
|
|
(let ([c (string-ref str i)])
|
|
(cond
|
|
[(or ($wb-aletter? c) ($wb-extend? c) ($wb-format? c))
|
|
(trans sAletter i c seen-cased? ac)]
|
|
[(or ($wb-midletter? c) ($wb-midnumlet? c))
|
|
(trans sAletterMid i c seen-cased? ac)]
|
|
[($wb-numeric? c) (trans sNumeric i c seen-cased? ac)]
|
|
[($wb-extendnumlet? c) (trans sExtendnumlet i c seen-cased? ac)]
|
|
[else (s0 i ac)])))
|
|
(define (sAletterMid i seen-cased? ac)
|
|
(let ([c (string-ref str i)])
|
|
(cond
|
|
[(or ($wb-extend? c) ($wb-format? c))
|
|
(trans sAletterMid i c seen-cased? ac)]
|
|
[($wb-aletter? c) (trans sAletter i c seen-cased? ac)]
|
|
[else (s0 i ac)])))
|
|
(define (sNumeric i seen-cased? ac)
|
|
(let ([c (string-ref str i)])
|
|
(cond
|
|
[(or ($wb-numeric? c) ($wb-extend? c) ($wb-format? c))
|
|
(trans sNumeric c i seen-cased? ac)]
|
|
[(or ($wb-midnum? c) ($wb-midnumlet? c))
|
|
(trans sNumericMid i c seen-cased? ac)]
|
|
[($wb-aletter? c) (trans sAletter i c seen-cased? ac)]
|
|
[($wb-extendnumlet? c) (trans sExtendnumlet i c seen-cased? ac)]
|
|
[else (s0 i ac)])))
|
|
(define (sNumericMid i seen-cased? ac)
|
|
(let ([c (string-ref str i)])
|
|
(cond
|
|
[(or ($wb-extend? c) ($wb-format? c))
|
|
(trans sNumericMid i c seen-cased? ac)]
|
|
[($wb-numeric? c) (trans sNumeric i c seen-cased? ac)]
|
|
[else (s0 i ac)])))
|
|
(define (sKatakana i seen-cased? ac)
|
|
(let ([c (string-ref str i)])
|
|
(cond
|
|
[(or ($wb-katakana? c) ($wb-extend? c) ($wb-format? c))
|
|
(trans sKatakana i c seen-cased? ac)]
|
|
[($wb-extendnumlet? c) (trans sExtendnumlet i c seen-cased? ac)]
|
|
[else (s0 i ac)])))
|
|
(define (sExtendnumlet i seen-cased? ac)
|
|
(let ([c (string-ref str i)])
|
|
(cond
|
|
[(or ($wb-extendnumlet? c) ($wb-extend? c) ($wb-format? c))
|
|
(trans sExtendnumlet i c seen-cased? ac)]
|
|
[($wb-aletter? c) (trans sAletter i c seen-cased? ac)]
|
|
[($wb-numeric? c) (trans sNumeric i c seen-cased? ac)]
|
|
[($wb-katakana? c) (trans sKatakana i c seen-cased? ac)]
|
|
[else (s0 i ac)])))
|
|
(if (fx= n 0) dst (s0 0 '())))))
|
|
|
|
|
|
(define $string-ci=? ; two arguments, no string? checks
|
|
(lambda (s1 s2)
|
|
(let ([n1 (string-length s1)] [n2 (string-length s2)])
|
|
(if (fx= n1 0)
|
|
(fx= n2 0)
|
|
(and (not (fx= n2 0))
|
|
(let f ([i1 1]
|
|
[i2 1]
|
|
[c1* ($str-foldcase (string-ref s1 0))]
|
|
[c2* ($str-foldcase (string-ref s2 0))])
|
|
(if (char? c1*)
|
|
(if (char? c2*)
|
|
(and (char=? c1* c2*)
|
|
(if (fx= i1 n1)
|
|
(fx= i2 n2)
|
|
(and (not (fx= i2 n2))
|
|
(f (fx+ i1 1) (fx+ i2 1)
|
|
($str-foldcase (string-ref s1 i1))
|
|
($str-foldcase (string-ref s2 i2))))))
|
|
(and (char=? c1* (car c2*))
|
|
(not (fx= i1 n1))
|
|
(f (fx+ i1 1) i2
|
|
($str-foldcase (string-ref s1 i1))
|
|
(cdr c2*))))
|
|
(if (char? c2*)
|
|
(and (char=? (car c1*) c2*)
|
|
(not (fx= i2 n2))
|
|
(f i1 (fx+ i2 1) (cdr c1*)
|
|
($str-foldcase (string-ref s2 i2))))
|
|
(and (char=? (car c1*) (car c2*))
|
|
(f i1 i2 (cdr c1*) (cdr c2*)))))))))))
|
|
|
|
(define $string-ci<? ; two arguments, no string? checks
|
|
(lambda (s1 s2)
|
|
(let ([n1 (string-length s1)] [n2 (string-length s2)])
|
|
(and (not (fx= n2 0))
|
|
(or (fx= n1 0)
|
|
(let f ([i1 1]
|
|
[i2 1]
|
|
[c1* ($str-foldcase (string-ref s1 0))]
|
|
[c2* ($str-foldcase (string-ref s2 0))])
|
|
(if (char? c1*)
|
|
(if (char? c2*)
|
|
(or (char<? c1* c2*)
|
|
(and (char=? c1* c2*)
|
|
(not (fx= i2 n2))
|
|
(or (fx= i1 n1)
|
|
(f (fx+ i1 1) (fx+ i2 1)
|
|
($str-foldcase (string-ref s1 i1))
|
|
($str-foldcase (string-ref s2 i2))))))
|
|
(or (char<? c1* (car c2*))
|
|
(and (char=? c1* (car c2*))
|
|
(or (fx= i1 n1)
|
|
(f (fx+ i1 1) i2
|
|
($str-foldcase (string-ref s1 i1))
|
|
(cdr c2*))))))
|
|
(if (char? c2*)
|
|
(or (char<? (car c1*) c2*)
|
|
(and (char=? (car c1*) c2*)
|
|
(not (fx= i2 n2))
|
|
(f i1 (fx+ i2 1) (cdr c1*)
|
|
($str-foldcase (string-ref s2 i2)))))
|
|
(or (char<? (car c1*) (car c2*))
|
|
(and (char=? (car c1*) (car c2*))
|
|
(f i1 i2 (cdr c1*) (cdr c2*))))))))))))
|
|
|
|
|
|
|
|
(define (do-string-cmp a ls cmp who)
|
|
(if (string? a)
|
|
(let f ([a a] [ls ls])
|
|
(cond
|
|
[(null? ls) #t]
|
|
[else
|
|
(let ([b (car ls)])
|
|
(if (string? b)
|
|
(if (cmp a b)
|
|
(f b (cdr ls))
|
|
(let f ([ls (cdr ls)])
|
|
(if (null? ls)
|
|
#f
|
|
(if (string? (car ls))
|
|
(f (cdr ls))
|
|
(assertion-violation who
|
|
"not a string" (car ls)))))))
|
|
(assertion-violation who "not a string" b))]))
|
|
(assertion-violation who "not a string" a)))
|
|
|
|
(define-syntax define-string-cmp
|
|
(syntax-rules ()
|
|
[(_ name cmp)
|
|
(define name
|
|
(case-lambda
|
|
[(s1 s2)
|
|
(if (string? s1)
|
|
(if (string? s2)
|
|
(cmp s1 s2)
|
|
(assertion-violation 'name "not a string" s2))
|
|
(assertion-violation 'name "not a string" s2))]
|
|
[(s1 . rest)
|
|
(do-string-cmp s1 rest cmp 'name)]))]))
|
|
|
|
(define-string-cmp string-ci=? $string-ci=?)
|
|
(define-string-cmp string-ci<?
|
|
(lambda (s1 s2) ($string-ci<? s1 s2)))
|
|
(define-string-cmp string-ci<=?
|
|
(lambda (s1 s2) (not ($string-ci<? s2 s1))))
|
|
(define-string-cmp string-ci>=?
|
|
(lambda (s1 s2) (not ($string-ci<? s1 s2))))
|
|
(define-string-cmp string-ci>?
|
|
(lambda (s1 s2) ($string-ci<? s2 s1)))
|
|
|
|
(module (hangul-sbase hangul-slimit $hangul-decomp
|
|
hangul-lbase hangul-llimit
|
|
hangul-vbase hangul-vlimit
|
|
hangul-tbase hangul-tlimit
|
|
hangul-vcount hangul-tcount)
|
|
; adapted from UAX #15
|
|
(define SBase #xAC00)
|
|
(define LBase #x1100)
|
|
(define VBase #x1161)
|
|
(define TBase #x11A7)
|
|
(define LCount 19)
|
|
(define VCount 21)
|
|
(define TCount 28)
|
|
(define NCount (* VCount TCount))
|
|
(define SCount (* LCount NCount))
|
|
(define hangul-sbase (integer->char SBase))
|
|
(define hangul-slimit (integer->char (+ SBase SCount -1)))
|
|
(define hangul-lbase (integer->char LBase))
|
|
(define hangul-llimit (integer->char (+ LBase LCount -1)))
|
|
(define hangul-vbase (integer->char VBase))
|
|
(define hangul-vlimit (integer->char (+ VBase VCount -1)))
|
|
(define hangul-tbase (integer->char TBase))
|
|
(define hangul-tlimit (integer->char (+ TBase TCount -1)))
|
|
(define hangul-vcount VCount)
|
|
(define hangul-tcount TCount)
|
|
(define ($hangul-decomp c)
|
|
(let ([SIndex (char- c hangul-sbase)])
|
|
(let ([L (integer->char (fx+ LBase (fxdiv SIndex NCount)))]
|
|
[V (integer->char (fx+ VBase (fxdiv (fxmod SIndex NCount) TCount)))]
|
|
[adj (fxmod SIndex TCount)])
|
|
(if (fx= adj 0)
|
|
(cons* L V)
|
|
(cons* L V (integer->char (fx+ TBase adj))))))))
|
|
|
|
(define $decompose
|
|
; might should optimize for sequences of ascii characters
|
|
(lambda (s canonical?)
|
|
(let ([n (string-length s)] [ac '()])
|
|
(define (canonical>? c1 c2)
|
|
(fx> ($char-combining-class c1) ($char-combining-class c2)))
|
|
(define (sort-and-flush comb*)
|
|
(unless (null? comb*)
|
|
(set! ac (append (list-sort canonical>? comb*) ac))))
|
|
(define ($char-decomp c)
|
|
(if (and (char<=? hangul-sbase c) (char<=? c hangul-slimit))
|
|
($hangul-decomp c)
|
|
(if canonical?
|
|
($str-decomp-canon c)
|
|
($str-decomp-compat c))))
|
|
(define (push-and-go c* c** i comb*)
|
|
(if (char? c*)
|
|
(go c* c** i comb*)
|
|
(go (car c*) (cons (cdr c*) c**) i comb*)))
|
|
(define (pop-and-go c** i comb*)
|
|
(if (null? c**)
|
|
(if (fx= i n)
|
|
(sort-and-flush comb*)
|
|
(go (string-ref s i) '() (fx+ i 1) comb*))
|
|
(push-and-go (car c**) (cdr c**) i comb*)))
|
|
(define (go c c** i comb*)
|
|
(let ([c* ($char-decomp c)])
|
|
(if (eq? c c*) ; should be eqv?
|
|
(if (fxzero? ($char-combining-class c))
|
|
(begin
|
|
(sort-and-flush comb*)
|
|
(set! ac (cons c ac))
|
|
(pop-and-go c** i '()))
|
|
(pop-and-go c** i (cons c comb*)))
|
|
(push-and-go c* c** i comb*))))
|
|
(pop-and-go '() 0 '())
|
|
(list->string (reverse ac)))))
|
|
|
|
(define $compose
|
|
(let ([comp-table #f])
|
|
(define (lookup-composite c1 c2)
|
|
(hashtable-ref comp-table (cons c1 c2) #f))
|
|
(define (init!)
|
|
(set! comp-table
|
|
(make-hashtable
|
|
(lambda (x)
|
|
(fxxor
|
|
(fxsll (char->integer (car x)) 7)
|
|
(char->integer (cdr x))))
|
|
(lambda (x y)
|
|
(and (char=? (car x) (car y))
|
|
(char=? (cdr x) (cdr y))))))
|
|
(vector-for-each
|
|
(lambda (c* c) (hashtable-set! comp-table c* c))
|
|
(car ($composition-pairs))
|
|
(cdr ($composition-pairs))))
|
|
(lambda (s)
|
|
(unless comp-table (init!))
|
|
(let ([ac '()] [n (string-length s)])
|
|
(define (dump c acc)
|
|
(set! ac (cons c ac))
|
|
(unless (null? acc) (set! ac (append acc ac))))
|
|
(define (s0 i)
|
|
(unless (fx= i n)
|
|
(let ([c (string-ref s i)])
|
|
(if (fxzero? ($char-combining-class c))
|
|
(s1 (fx+ i 1) c)
|
|
(begin (set! ac (cons c ac)) (s0 (fx+ i 1)))))))
|
|
(define (s1 i c)
|
|
(if (fx= i n)
|
|
(set! ac (cons c ac))
|
|
(let ([c1 (string-ref s i)])
|
|
(cond
|
|
[(and (and (char<=? hangul-lbase c)
|
|
(char<=? c hangul-llimit))
|
|
(and (char<=? hangul-vbase c1)
|
|
(char<=? c1 hangul-vlimit)))
|
|
(s1 (fx+ i 1)
|
|
(let ([lindex (char- c hangul-lbase)]
|
|
[vindex (char- c1 hangul-vbase)])
|
|
(integer->char
|
|
(fx+ (char->integer hangul-sbase)
|
|
(fx* (fx+ (fx* lindex hangul-vcount) vindex)
|
|
hangul-tcount)))))]
|
|
[(and (and (char<=? hangul-sbase c)
|
|
(char<=? c hangul-slimit))
|
|
(and (char<=? hangul-tbase c1)
|
|
(char<=? c1 hangul-tlimit))
|
|
(let ([sindex (char- c hangul-sbase)])
|
|
(fxzero? (fxmod sindex hangul-tcount))))
|
|
(let ([tindex (char- c1 hangul-tbase)])
|
|
(s1 (fx+ i 1) (integer->char (fx+ (char->integer c) tindex))))]
|
|
[else (s2 i c -1 '())]))))
|
|
(define (s2 i c class acc)
|
|
(if (fx= i n)
|
|
(dump c acc)
|
|
(let ([c1 (string-ref s i)])
|
|
(let ([class1 ($char-combining-class c1)])
|
|
(cond
|
|
[(and (fx< class class1) (lookup-composite c c1)) =>
|
|
(lambda (c) (s2 (fx+ i 1) c class acc))]
|
|
[(fx= class1 0)
|
|
(dump c acc)
|
|
(s1 (fx+ i 1) c1)]
|
|
[else (s2 (fx+ i 1) c class1 (cons c1 acc))])))))
|
|
(s0 0)
|
|
(list->string (reverse ac))))))
|
|
|
|
(define-string-op string-normalize-nfd
|
|
(lambda (s) ($decompose s #t)))
|
|
|
|
(define-string-op string-normalize-nfkd
|
|
(lambda (s) ($decompose s #f)))
|
|
|
|
(define-string-op string-normalize-nfc
|
|
(lambda (s) ($compose ($decompose s #t))))
|
|
|
|
(define-string-op string-normalize-nfkc
|
|
(lambda (s) ($compose ($decompose s #f))))
|
|
|
|
))
|