First draft of NFD normalization.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index a3d12341a2bf34745ed85db949dfde28c4f4b372..6acd8ce7f802405743bc2be5a0167dad099773dd 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1484,9 +1484,11 @@ USA.
         "ucd-table-cwcf"
         "ucd-table-cwl"
         "ucd-table-cwu"
+        "ucd-table-dm"
         "ucd-table-gc"
         "ucd-table-lc"
         "ucd-table-lower"
+        "ucd-table-nfd_qc"
         "ucd-table-nt"
         "ucd-table-nv"
         "ucd-table-scf"
@@ -1519,7 +1521,9 @@ USA.
          char-set:changes-when-case-folded
          ucd-nt-value)
   (export (runtime ustring)
-         ucd-ccc-value))
+         char-nfd-quick-check?
+         ucd-ccc-value
+         ucd-dm-value))
 
 (define-package (runtime ucd-glue)
   (files "ucd-glue")

diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm
index 493e59c5d4a7312aa91532ae4935a95986fb33c3..e8eeebd7f92a155ef34de9e7507f2a20a1fffa03 100644 (file)
--- a/src/runtime/ustring.scm
+++ b/src/runtime/ustring.scm
@@ -669,4 +669,82 @@ USA.
     (if (fix:< i end)
        (and (proc (ref string i))
             (loop (fix:+ i 1)))
-       #t)))
\ No newline at end of file
+       #t)))
+\f
+(define (ustring->nfd string)
+  (if (ustring-in-nfd? string)
+      string
+      (canonical-ordering! (canonical-decomposition string))))
+
+(define (ustring-in-nfd? string)
+  (let ((n (ustring-length string)))
+    (let loop ((i 0) (last-ccc 0))
+      (if (fix:< i n)
+         (let* ((char (ustring-ref string i))
+                (ccc (ucd-ccc-value char)))
+           (and (or (fix:= ccc 0)
+                    (fix:>= ccc last-ccc))
+                (char-nfd-quick-check? char)
+                (loop (fix:+ i 1) ccc)))
+         #t))))
+
+(define (canonical-decomposition string)
+  (let ((end (ustring-length string)))
+    (let ((result
+          (make-ustring
+           (do ((i 0 (fix:+ i 1))
+                (j 0 (fix:+ j (length (ucd-dm-value (ustring-ref string i))))))
+               ((not (fix:< i end)) j)))))
+      (let loop ((i 0) (j 0))
+       (if (fix:< i end)
+           (loop (fix:+ i 1)
+                 (do ((chars (ucd-dm-value (ustring-ref string i))
+                             (cdr chars))
+                      (j j (fix:+ j 1)))
+                     ((not (pair? chars)) j)
+                   (ustring-set! result j (car chars))))))
+      result)))
+
+(define (canonical-ordering! string)
+  (let ((end (ustring-length string)))
+
+    (define (scan-for-non-starter i)
+      (if (fix:< i end)
+         (let* ((char (ustring-ref string i))
+                (ccc (ucd-ccc-value char)))
+           (if (fix:= 0 ccc)
+               (scan-for-non-starter (fix:+ i 1))
+               (maybe-twiddle char ccc i)))))
+
+    (define (maybe-twiddle char1 ccc1 i1)
+      (let ((i2 (fix:+ i1 1)))
+       (if (fix:< i2 end)
+           (let* ((char2 (ustring-ref string i2))
+                  (ccc2 (ucd-ccc-value char2)))
+             (cond ((fix:= 0 ccc2)
+                    (scan-for-non-starter (fix:+ i2 1)))
+                   ((fix:<= ccc1 ccc2)
+                    (maybe-twiddle char2 ccc2 i2))
+                   (else
+                    (ustring-set! string i1 char2)
+                    (ustring-set! string i2 char1)
+                    (maybe-twiddle char1 ccc1 i2)))))))
+
+    (scan-for-non-starter 0))
+  string)
+
+(define (quick-check string qc-value)
+  (let ((n (ustring-length string)))
+    (let loop ((i 0) (last-ccc 0) (result #t))
+      (if (fix:< i n)
+         (let* ((char (ustring-ref string i))
+                (ccc (ucd-ccc-value char)))
+           (if (and (fix:> ccc 0)
+                    (fix:< ccc last-ccc))
+               #f
+               (let ((check (qc-value char)))
+                 (and check
+                      (if (eq? check 'maybe)
+                          (loop (fix:+ i 1) ccc check)
+                          (loop (fix:+ i 1) ccc result))))))
+         result))))
\ No newline at end of file