From 768d6a348cbad25cfe57d664a3784e639b3878e7 Mon Sep 17 00:00:00 2001 From: Raymond Toy <toy.raymond@gmail.com> Date: Tue, 31 Jan 2012 19:34:14 -0800 Subject: [PATCH] Fix ticket:52. Thanks to Paul Foley for rewriting {{{UNICODE-COMPLETE-NAME}}} to make it work. --- src/code/unidata.lisp | 147 ++++++++++++++++-------------------------- 1 file changed, 57 insertions(+), 90 deletions(-) diff --git a/src/code/unidata.lisp b/src/code/unidata.lisp index 4f9468436..91b5bda68 100644 --- a/src/code/unidata.lisp +++ b/src/code/unidata.lisp @@ -1231,98 +1231,65 @@ Three values are returned: (1) The best match of prefix, (2) a list of possible completions, (3) a boolean indicating whether the best match is a complete unicode name. " - (unless dict - ;; Load the names dictionary, if needed. - (unless (unidata-name+ *unicode-data*) - (load-names)) + (load-names) (setf dict (unidata-name+ *unicode-data*))) - (let ((prefix (nsubstitute #\Space #\_ (string-upcase prefix))) - completep) - (multiple-value-bind (n p) - (search-dictionary prefix dict) - (when n - (setq completep (> (aref (dictionary-codev dict) n) -1))) - #+(or debug-uc) - (progn - (format t "n,p,complete = ~S ~S ~S~%" n p completep) - (when n (format t "match = ~S~%" (subseq prefix 0 p)))) - (cond ((not p) - (values (%str prefix) nil nil)) - ((= p (length prefix)) - ;; The prefix is an exact match to something in the code - ;; book. Try to find possible completions of this - ;; prefix. - (let ((x (node-next n dict)) - (suffix "")) - #+(or debug-uc) - (format t "init x = ~S~%" x) - (when (= (length x) 1) - ;; There was only one possible extension. Try to - ;; extend from there. - #+(or debug-uc) - (format t "extending~%") - (setq suffix (caar x) - n (cdar x) - x (node-next (cdar x) dict))) - #+(or debug-uc) - (progn - (format t "x = ~S~%" x) - (format t "suffix = ~S~%" suffix)) - (when (<= (length x) 1) - (setq prefix (concatenate 'string prefix suffix)) - (setf suffix "")) - (values (%str prefix) - (sort (mapcar #'(lambda (e) - (%str (concatenate 'string suffix (car e)))) - x) - #'string<) - (or (> (aref (dictionary-codev dict) n) -1) - completep)))) - (t - ;; The prefix was not an exact match of some entry in the - ;; codebook. Try to find some completions from there. - (let* ((nodex (node-next n dict)) - (x (remove-if-not (lambda (x) - (%match (car x) prefix p)) - nodex))) - #+(or debug-uc) - (progn - (format t "nodex = ~S~%" nodex) - (format t "x = ~S~%" x)) - (setq prefix (subseq prefix 0 p)) - (cond ((= (length x) 1) - ;; Only one possible completion. Try to extend - ;; the completions from there. - (setq prefix (concatenate 'string prefix (caar x)) - n (cdar x) - x (node-next (cdar x) dict)) - (values (%str prefix) - (sort (mapcar #'%strx x) #'string<) - (> (aref (dictionary-codev dict) n) -1))) - (t - ;; There's more than one possible completion. - ;; Try to extend each of those completions one - ;; more step, but we still want to keep the - ;; original completions. - (let* ((p (append (mapcar #'car x) - (mapcan #'(lambda (ex) - (let ((next (node-next (cdr ex) dict))) - (if next - (mapcar #'(lambda (n) - (concatenate 'string (car ex) (car n))) - (node-next (cdr ex) dict)) - (list (car ex))))) - x))) - (q (%mip p))) - (setq prefix (concatenate 'string prefix q)) - - (do ((tmp p (cdr tmp))) - ((endp tmp)) - (setf (car tmp) (subseq (car tmp) (length q)))) - (values (%str prefix) - (sort (mapcar #'%str p) #'string<) - nil)))))))))) + (let* ((prefix (nsubstitute #\Space #\_ (string-upcase prefix))) + (result nil)) + (labels ((keybase (node) + (ash (aref (dictionary-nextv dict) node) -18)) + (keylen (base) + (aref (dictionary-keyl dict) base)) + (keystr (base offset) + (aref (dictionary-cdbk dict) + (aref (dictionary-keyv dict) (+ base offset)))) + (next (node keypos) + (+ (logand (aref (dictionary-nextv dict) node) #x3FFFF) + keypos)) + (completep (node) + (> (aref (dictionary-codev dict) node) -1)) + (match (part prefix posn) + (let ((s1 (search part prefix :start2 posn)) + (s2 (search prefix part :start1 posn))) + (or (and s1 (= s1 posn)) + (and s2 (zerop s2))))) + (rec (node posn) + (let ((keyv (keybase node))) + (dotimes (i (keylen keyv)) + (let* ((str (keystr keyv i)) (len (length str))) + (when (match str prefix posn) + (cond ((<= (+ len posn) (length prefix)) + (rec (next node i) (+ posn len))) + (t + (push (fillout (concatenate 'string (subseq prefix 0 posn) + str) + (next node i)) + result)))))))) + (fillout (string node) + (let ((keyv (keybase node))) + (if (and (= (keylen keyv) 1) (not (completep node))) + (fillout (concatenate 'string string (keystr keyv 0)) + (next node 0)) + string))) + (mip (strings) + (let* ((first (first strings)) + (posn (length first))) + (dolist (string (rest strings)) + (let ((n (mismatch first string :end1 posn))) + (when n (setq posn n)))) + (subseq first 0 posn))) + (str (x) (nsubstitute #\_ #\Space (string-capitalize x)))) + (rec 0 0) + (unless (cdr result) + (setq prefix (car result)) + (rec 0 0)) + (let* ((base (mip result)) + (node (search-dictionary base dict))) + (values (str base) + (sort (mapcar (lambda (x) (str (subseq x (length base)))) + (delete base result :test #'string=)) + #'string<) + (and node (completep node))))))) ;; Like unicode-complete-name, but we also try to handle the names ;; that can be computed algorithmically like the Hangul syllables and -- GitLab