(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)
(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 "<compat>" array)
array))
- (setq *decomposition-length-max* 0)
(setq *decomposition-base* (make-array (ash #x110000
(- *page-size-exponent*))
:initial-element nil))
while line
do (slurp-ucd-line line)))
(second-pass)
- (build-misc-table)
(fixup-hangul-syllables)
- *decompositions*)
+ (build-misc-table)
+ (length *long-decompositions*))
(defun fixup-hangul-syllables ()
;; "Hangul Syllable Composition, Unicode 5.1 section 3-12"
(let* ((l (+ lbase (floor sindex ncount)))
(v (+ vbase (floor (mod sindex ncount) tcount)))
(tee (+ tbase (mod sindex tcount)))
+ (code-point (+ sbase sindex))
(name (format nil "HANGUL_SYLLABLE_~A~A~:[~A~;~]"
(gethash l table) (gethash v table)
(= tee tbase) (gethash tee table))))
- (setf (gethash (+ sbase sindex) *unicode-names*) name)))))
+ (setf (gethash code-point *unicode-names*) name)
+ (unless (aref *decomposition-base* (cp-high code-point))
+ (setf (aref *decomposition-base* (cp-high code-point))
+ (make-array (ash 1 *page-size-exponent*)
+ :initial-element nil)))
+ (setf (aref (aref *decomposition-base* (cp-high code-point))
+ (cp-low code-point))
+ (cons (if (= tee tbase) 2 3) 0))))))
(defun add-jamo-information (line table)
(let* ((split (split-string line #\;))
(defun split-string (line character)
(loop for prev-position = 0 then (1+ position)
- for position = (position character line :start prev-position)
- collect (subseq line prev-position position)
- do (unless position
- (loop-finish))))
+ for position = (position character line :start prev-position)
+ collect (subseq line prev-position position)
+ do (unless position
+ (loop-finish))))
(defun init-indices (strings)
(let ((hash (make-hash-table :test #'equal)))
(loop for string in strings
- for index from 0
- do (setf (gethash string hash) index))
+ for index from 0
+ do (setf (gethash string hash) index))
hash))
(defparameter *general-categories*
: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*)))))))))
+ ;; Hangul decomposition; see Unicode 6.2 section 3-12
+ (when (= code-point #xd7a3)
+ ;; KLUDGE: it's a bit ugly to do this here when we've got
+ ;; a reasonable function to do this in
+ ;; (FIXUP-HANGUL-SYLLABLES). The problem is that the
+ ;; fixup would be somewhat tedious to do, what with all
+ ;; the careful hashing of misc data going on.
+ (setf decomposition-info 1)
+ ;; the construction of *decomposition-base* entries is,
+ ;; however, easy to handle within FIXUP-HANGUL-SYLLABLES.
+ )
(when (and (string/= "" simple-uppercase)
(string/= "" simple-lowercase))
(push (list code-point upper-index lower-index) *both-cases*))
decimal-digit digit bidi-mirrored
nil decomposition-info))))))
-(defun write-3-byte (triplet stream)
- (write-byte (ldb (byte 8 0) triplet) stream)
- (write-byte (ldb (byte 8 8) triplet) stream)
- (write-byte (ldb (byte 8 16) triplet) stream))
-
(defun write-4-byte (quadruplet stream)
(write-byte (ldb (byte 8 24) quadruplet) stream)
(write-byte (ldb (byte 8 16) quadruplet) stream)
(loop for (gc-index bidi-index ccc-index decimal-digit digit
bidi-mirrored nil decomposition-info)
across *misc-table*
+ ;; three bits spare here
do (write-byte gc-index stream)
+ ;; three bits spare here
do (write-byte bidi-index stream)
do (write-byte ccc-index stream)
+ ;; we could save some space here: decimal-digit and
+ ;; digit are constrained (CHECKME) to be between 0 and
+ ;; 9, so we could encode the pair in a single byte.
+ ;; (Also, decimal-digit is equal to digit or undefined,
+ ;; so we could encode decimal-digit as a single bit,
+ ;; meaning that we could save 11 bits here.
do (write-byte (digit-to-byte decimal-digit) stream)
do (write-byte (digit-to-byte digit) stream)
+ ;; there's an easy 7 bits to spare here
do (write-byte (if (string= "N" bidi-mirrored) 0 1) stream)
+ ;; at the moment we store information about which type
+ ;; of compatibility decomposition is used, costing c.3
+ ;; bits. We could elide that.
do (write-byte decomposition-info stream)
do (write-byte 0 stream))
(loop for page across *ucd-base*
(dpb (if entry (aref *misc-mapping* (ucd-misc entry)) #x7ff)
(byte 11 21)
(if entry (ucd-transform entry) 0))
- stream)
- #+nil #+nil
- do (write-byte (if entry
- (aref *misc-mapping* (ucd-misc entry))
- 255)
- stream)
- #+nil #+nil
- do (write-3-byte (if entry (ucd-transform entry) 0)
- stream))))))
+ 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
projects / sbcl.git / blobdiff