;;; 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))))

))