Initial import
authorMatthew Mondor <mmondor@pulsar-zone.net>
Tue, 30 Aug 2011 08:01:36 +0000 (08:01 +0000)
committerMatthew Mondor <mmondor@pulsar-zone.net>
Tue, 30 Aug 2011 08:01:36 +0000 (08:01 +0000)
mmsoftware/cl/server/character.lisp [new file with mode: 0644]

diff --git a/mmsoftware/cl/server/character.lisp b/mmsoftware/cl/server/character.lisp
new file mode 100644 (file)
index 0000000..d725638
--- /dev/null
@@ -0,0 +1,229 @@
+;;; $Id: character.lisp,v 1.1 2011/08/30 08:01:36 mmondor Exp $
+
+#|
+
+Copyright (c) 2011, Matthew Mondor
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY MATTHEW MONDOR ``AS IS'' AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
+IN NO EVENT SHALL MATTHEW MONDOR BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
+USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+|#
+
+;;; character.lisp - Character conversion utilities
+
+
+(declaim (optimize (speed 3) (safety 1) (debug 3)))
+
+(defpackage :character
+  (:use :cl)
+  (:export #:utf-8-string-encode
+          #:utf-8-string-decode
+          #:string-normalize))
+
+(in-package :character)
+
+(defparameter *rcsid*
+  "$Id: character.lisp,v 1.1 2011/08/30 08:01:36 mmondor Exp $")
+
+
+(defun utf-8-string-encode (string)
+  "Encodes the supplied STRING to an UTF-8 octets vector which it returns."
+  (let ((v (make-array (+ 5 (length string)) ; Best case but we might grow
+                      :element-type '(unsigned-byte 8)
+                      :adjustable t
+                      :fill-pointer 0)))
+    (with-open-stream (s (ext:make-sequence-output-stream
+                         v :external-format :utf-8))
+      (loop
+        for c across string
+        do
+          (write-char c s)
+          (let ((d (array-dimension v 0)))
+            (when (< (- d (fill-pointer v)) 5)
+              (adjust-array v (* 2 d))))))
+    v))
+
+(defun utf-8-string-decode (bytes)
+  "Decodes the UTF-8 octets vector BYTES to string which it returns.
+Invalid sequence octets are imported as LATIN-1 characters."
+  (macrolet ((add-char (c)
+              `(vector-push-extend ,c string 1024)))
+    (with-open-stream (s (ext:make-sequence-input-stream
+                         bytes :external-format :utf-8))
+      (loop
+        with string = (make-array 1024
+                                  :element-type 'character
+                                  :adjustable t
+                                  :fill-pointer 0)
+        for c of-type character =
+          (handler-bind
+              ((ext:stream-decoding-error
+                #'(lambda (e)
+                    (mapc #'(lambda (o)
+                              ;; Assume LATIN-1 and import
+                              (add-char (code-char o)))
+                          (ext:character-decoding-error-octets e))
+                    (invoke-restart 'continue)))
+               (end-of-file
+                #'(lambda (e)
+                    (declare (ignore e))
+                    (loop-finish))))
+            (read-char s))
+        do (add-char c)
+        finally (return string)))))
+
+
+(defparameter *normalize*
+  '((#\a (#\A
+         #\À #\Á #\ #\à#\Ä #\Å #\Ā
+         #\à #\á #\â #\ã #\ä #\å #\ā))
+    (#\b (#\B
+         #\Ḃ
+         #\ḃ))
+    (#\c (#\C
+         #\Ç #\Ċ
+         #\ç #\ċ))
+    (#\d (#\D
+         #\Р#\Ḋ
+         #\ð #\ḋ))
+    (#\e (#\E
+         #\È #\É #\Ê #\Ë #\Ē
+         #\è #\é #\ê #\ë #\ē))
+    (#\f (#\F
+         #\Ḟ
+         #\ḟ))
+    (#\g (#\G
+         #\Ġ
+         #\ġ))
+    (#\h (#\H))
+    (#\i (#\I
+         #\Ì #\Í #\Π#\Ï #\Ī
+         #\ì #\í #\î #\ï #\ī))
+    (#\j (#\J))
+    (#\k (#\K))
+    (#\l (#\L))
+    (#\m (#\M
+         #\Ṁ
+         #\ṁ
+         #\µ))
+    (#\n (#\N
+         #\Ñ
+         #\ñ))
+    (#\o (#\O
+         #\Ò #\Ó #\Ô #\Õ #\Ö #\Ø #\Ő #\Ō
+         #\ò #\ó #\ô #\õ #\ö #\ø #\ő #\ō))
+    (#\p (#\P))
+    (#\q (#\Q))
+    (#\r (#\R))
+    (#\s (#\S
+         #\Š #\Ṡ
+         #\š #\ṡ))
+    (#\t (#\T
+         #\Ṫ
+         #\ṫ))
+    (#\u (#\U
+         #\Ù #\Ú #\Û #\Ü #\Ű #\Ū
+         #\ù #\ú #\û #\ü #\ű #\ū))
+    (#\v (#\V))
+    (#\w (#\W
+         #\Ŵ
+         #\ŵ))
+    (#\x (#\X))
+    (#\y (#\Y
+         #\Ý #\Ÿ #\Ŷ
+         #\ý #\ÿ #\ŷ))
+    (#\z (#\Z
+         #\Ž
+         #\ž))
+    ("1/4" (#\¼))
+    ("1/2" (#\½))
+    ("3/4" (#\¾))
+    ("ae" (#\Æ #\æ))
+    ("db" (#\ȸ))
+    ("dz" (#\ʣ #\ʥ #\ʤ))
+    ("ff" (#\ff))
+    ("ffi" (#\ffi))
+    ("ffl" (#\ffl))
+    ("fi" (#\fi))
+    ("fl" (#\fl))
+;   ("fŋ" (#\ʩ))
+    ("ft" (#\ſt))
+    ("ij" (#\IJ #\ij))
+    ("ls" (#\ʪ))
+    ("lz" (#\ʫ))
+    ("oe" (#\Œ #\œ))
+    ("qp" (#\ȹ))
+    ("ss" (#\ß))
+    ("st" (#\st))
+    ("tc" (#\ʨ))
+    ("th" (#\Þ #\þ))
+    ("ts" (#\ʦ))
+;   ("tʃ" (#\ʧ))
+    ("ue" (#\ᵫ))
+    ("(c)" (#\©))
+    ("(r)" (#\®))
+    ("tm" (#\™))))
+
+(defun fill-tables ()
+  (let ((v (make-array 256))
+       (ta (make-hash-table :test #'eq)))
+    (loop
+       for i from 0 to 255
+       do (setf (aref v i) (code-char i)))
+    (mapc #'(lambda (l)
+             (destructuring-bind (to from) l
+               (mapc #'(lambda (c)
+                         (let ((i (char-code c)))
+                           (if (< i 256)
+                               (setf (aref v i) to)
+                               (setf (gethash c ta) to))))
+                     from)))
+         *normalize*)
+    (values v ta)))
+
+(multiple-value-bind (normalize-vector normalize-table)
+    (fill-tables)
+  (defun char-normalize (c)
+    (let ((i (char-code c)))
+      (if (< i 256)
+         ;; Optimize common LATIN-1 case
+         (aref normalize-vector i)
+         (multiple-value-bind (to exists-p)
+             (gethash c normalize-table)
+           (if exists-p
+               to
+               c))))))
+
+(defun string-normalize (string)
+  "Returns a copy of STRING normalized for easier matching.
+The returned string is lowercase, with the various LATIN special characters
+resolved to simpler ASCII ones.  Various ligatures are also converted."
+  (with-output-to-string (out)
+    (with-input-from-string (in string)
+      (loop
+        for c = (handler-case
+                    (read-char in)
+                  (end-of-file ()
+                    nil))
+        for toc = (if c (char-normalize c) nil)
+        while toc
+        when (characterp toc) do (write-char toc out)
+        else do (write-string toc out)))))