From 026be5a30130cdb1bc4648fa7daea8e1180a6e46 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Sun, 17 Mar 2013 21:23:59 +0000 Subject: [PATCH] beginnings of decomposition Store enough information in output from ucd.lisp to be able to actually decompose individual characters. Include proof-of-concept implementation of decomposition, not hooked into anything yet. --- src/code/target-char.lisp | 49 ++++++++++++++++++++++++++++++++--- tools-for-build/ucd.lisp | 62 +++++++++++++++++++++++++++++++++++++-------- 2 files changed, 96 insertions(+), 15 deletions(-) diff --git a/src/code/target-char.lisp b/src/code/target-char.lisp index 262cead..0c2b5f7 100644 --- a/src/code/target-char.lisp +++ b/src/code/target-char.lisp @@ -33,9 +33,9 @@ :directory '(:relative :up :up "output") :name name :type type) - sb!xc:*compile-file-truename*))) - (let ((character-database - (with-open-file (stream (file "ucd" "dat") + sb!xc:*compile-file-truename*)) + (read-ub8-vector (pathname) + (with-open-file (stream pathname :direction :input :element-type '(unsigned-byte 8)) (let* ((length (file-length stream)) @@ -43,9 +43,14 @@ length :element-type '(unsigned-byte 8)))) (read-sequence array stream) array)))) + (let ((character-database (read-ub8-vector (file "ucd" "dat"))) + (decompositions (read-ub8-vector (file "decomp" "dat"))) + (long-decompositions (read-ub8-vector (file "ldecomp" "dat")))) `(progn - (declaim (type (simple-array (unsigned-byte 8) (*)) **character-database**)) + (declaim (type (simple-array (unsigned-byte 8) (*)) **character-database** **character-decompositions** **character-long-decompositions**)) (defglobal **character-database** ,character-database) + (defglobal **character-decompositions** ,decompositions) + (defglobal **character-long-decompositions** ,long-decompositions) (defun !character-database-cold-init () (setf **character-database** ,character-database)) ,(with-open-file (stream (file "ucd-names" "lisp-expr") @@ -602,3 +607,39 @@ character exists." (and (typep weight 'fixnum) (>= weight 0) (< weight radix) (< weight 36) (code-char (if (< weight 10) (+ 48 weight) (+ 55 weight))))) + +(defun char-decomposition-info (char) + (aref **character-database** (+ 6 (* 8 (ucd-value-0 char))))) + +(defun char-decomposition (char) + (let* ((cp (char-code char)) + (cp-high (ash cp -8)) + (decompositions **character-decompositions**) + (long-decompositions **character-long-decompositions**) + (index (+ #x1100 + (ash (aref decompositions cp-high) 10) + (ash (ldb (byte 8 0) cp) 2))) + (v0 (aref decompositions index)) + (v1 (aref decompositions (+ index 1))) + (v2 (aref decompositions (+ index 2))) + (v3 (aref decompositions (+ index 3))) + (length (dpb v0 (byte 8 3) (ldb (byte 3 5) v1))) + (entry (dpb (ldb (byte 5 0) v1) (byte 5 16) + (dpb v2 (byte 8 8) v3)))) + (if (= length 1) + (string (code-char entry)) + (let ((result (make-string length)) + (e (* 4 entry))) + (dotimes (i length result) + (let ((code (dpb (aref long-decompositions (+ e 1)) + (byte 8 16) + (dpb (aref long-decompositions (+ e 2)) + (byte 8 8) + (aref long-decompositions (+ e 3)))))) + (setf (char result i) (code-char code))) + (incf e 4)))))) + +(defun decompose-char (char) + (if (= (char-decomposition-info char) 0) + (string char) + (char-decomposition char))) diff --git a/tools-for-build/ucd.lisp b/tools-for-build/ucd.lisp index 1a717f7..623cb21 100644 --- a/tools-for-build/ucd.lisp +++ b/tools-for-build/ucd.lisp @@ -35,8 +35,7 @@ (defparameter *misc-table* nil) (defparameter *misc-mapping* nil) (defparameter *both-cases* nil) -(defparameter *decompositions* nil) -(defparameter *decomposition-length-max* nil) +(defparameter *long-decompositions* nil) (defparameter *decomposition-types* nil) (defparameter *decomposition-base* nil) @@ -98,13 +97,13 @@ (setq *misc-index* -1) (setq *misc-table* (make-array 2048 :fill-pointer 0)) (setq *both-cases* nil) - (setq *decompositions* 0) + (setq *long-decompositions* + (make-array 2048 :fill-pointer 0 :adjustable t)) (setq *decomposition-types* (let ((array (make-array 256 :initial-element nil :fill-pointer 1))) (vector-push "" array) (vector-push "" array) array)) - (setq *decomposition-length-max* 0) (setq *decomposition-base* (make-array (ash #x110000 (- *page-size-exponent*)) :initial-element nil)) @@ -121,7 +120,7 @@ (second-pass) (build-misc-table) (fixup-hangul-syllables) - *decompositions*) + (length *long-decompositions*)) (defun fixup-hangul-syllables () ;; "Hangul Syllable Composition, Unicode 5.1 section 3-12" @@ -247,12 +246,16 @@ :initial-element nil))) (setf (aref (aref *decomposition-base* (cp-high code-point)) (cp-low code-point)) - (mapcar #'(lambda (string) - (parse-integer string :radix 16)) - split)) - (setq *decomposition-length-max* - (max *decomposition-length-max* (length split))) - (incf *decompositions* (length split)))) + (let ((decomposition + (mapcar #'(lambda (string) + (parse-integer string :radix 16)) + split))) + (if (= (length decomposition) 1) + (cons 1 (car decomposition)) + (cons (length decomposition) + (prog1 (fill-pointer *long-decompositions*) + (dolist (code decomposition) + (vector-push-extend code *long-decompositions*))))))))) (when (and (string/= "" simple-uppercase) (string/= "" simple-lowercase)) (push (list code-point upper-index lower-index) *both-cases*)) @@ -396,6 +399,43 @@ (byte 11 21) (if entry (ucd-transform entry) 0)) stream)))))) + ;; KLUDGE: this code, to write out decomposition information, is a + ;; little bit very similar to the ucd entries above. Try factoring + ;; out the common stuff? + (let ((hash (make-hash-table :test #'equalp)) + (index 0)) + (loop for page across *decomposition-base* + do (when page + (unless (gethash page hash) + (setf (gethash page hash) + (prog1 index (incf index)))))) + (let ((array (make-array index))) + (maphash #'(lambda (key value) + (setf (aref array value) key)) + hash) + (with-open-file (stream (make-pathname :name "decomp" :type "dat" + :defaults *output-directory*) + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede + :if-does-not-exist :create) + (loop for page across *decomposition-base* + do (write-byte (if page (gethash page hash) 0) stream)) + (loop for page across array + do (loop for entry across page + do (write-4-byte + (dpb (if entry (car entry) 0) + (byte 11 21) + (if entry (cdr entry) 0)) + stream)))) + (with-open-file (stream (make-pathname :name "ldecomp" :type "dat" + :defaults *output-directory*) + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede + :if-does-not-exist :create) + (loop for code across (copy-seq *long-decompositions*) + do (write-4-byte code stream))))) (with-open-file (f (make-pathname :name "ucd-names" :type "lisp-expr" :defaults *output-directory*) :direction :output -- 1.7.10.4