;;; Character completion

(defun match-semi-standard (prefix matchp)
  ;; Handle the standard and semi-standard characters.
  (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout"
                      "Linefeed" "Return" "Backspace")
     when (funcall matchp prefix name)
     collect name))

(defimplementation character-completion-set (prefix matchp)
  (let ((names (lisp::unicode-complete prefix)))
    ;; Match prefix against semistandard names.  If there's a match,
    ;; add it to our list of matches.
    (let ((semi-standard (match-semi-standard prefix matchp)))
      (when semi-standard
        (setf names (append semi-standard names))))
    (setf names (mapcar #'string-capitalize names))
    (loop for n in names
       when (funcall matchp prefix n)
       collect n))))

;; This is CMUCL's completion code.  If CMUCL already contains the necessary code, don't try to load this.

(in-package "LISP")

#+(and unicode #.(cl:if (cl:find-symbol "UNICODE-COMPLETE" "LISP") '(and) '(or)))
(ext:without-package-locks
(progn
(defun search-dictionary (string dictionary &optional (current 0) (posn 0))
  "Search the Unicode name dictionary for the longest entry that
  matches STRING.  STRING must be in Unicode name format.  That is, it
  must be upper case with spaces separating each word.

  Two values are returned.  The first value is index into the codebook
  that continues the string..  The second value is the length of the
  substring of string that matches the codebook. "
  
  (declare (optimize (speed 3) (space 0) (safety 0)
		     (ext:inhibit-warnings 3))
	   (type string string) (type dictionary dictionary)
	   (type (unsigned-byte 32) current) (type lisp::index posn))
  (let* ((codebook (dictionary-cdbk dictionary))
	 (stack '()))
    (loop
       (let ((keyv (ash (aref (dictionary-nextv dictionary) current) -18)))
	 (dotimes (i (aref (dictionary-keyl dictionary) keyv)
		   (if stack
		       (let ((next (pop stack)))
			 (setq posn (car next) current (cdr next)))
		       (return-from search-dictionary nil)))
	   (let* ((str (aref codebook (aref (dictionary-keyv dictionary)
					    (+ keyv i))))
		  (len (length str)))
	     (declare (type simple-base-string str))
	     (cond ((and (>= (length string) (+ posn len))
			 (string= string str :start1 posn :end1 (+ posn len)))
		    (setq current
			  (+ (logand (aref (dictionary-nextv dictionary) current)
				     #x3FFFF)
			     i))
		    (when (= (incf posn len) (length string))
		      (return-from search-dictionary (values current posn)))
		    (return))		; from DOTIMES - loop again
		   ((and (< (length string) (+ posn len))
			 (string= string str :start1 posn :end2 (- (length string) posn)))
		    (return-from search-dictionary (values current posn))))
	     (when (or (string= str " ") (string= str "-"))
	       (push (cons posn
			   (+ (logand (aref (dictionary-nextv dictionary)
					    current)
				      #x3FFFF)
			      i))
		     stack))))))))

(defun unicode-complete-name (prefix
			      &optional (dict (lisp::unidata-name+
					       lisp::*unicode-data*)))
  "Try to complete the string Prefix using the dictionary in Dict.
  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.

  The search is only done in the given dictionary so names that are
  derived algorithmically like Hangul syllables and CJK Unified
  Ideographs are not found."

  (unless dict
    ;; Load the names dictionary
    (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)
      (format t "n,p,complete = ~S ~S ~S~%" n p completep)
      (cond ((not p)
	     (values (%str prefix) nil nil))
	    ((= p (length prefix))
	     (let ((x (node-next n))
		   (suffix ""))
	       #+(or debug-uc)
	       (format t "init x = ~S~%" x)
	       (when (= (length x) 1)
		 #+(or debug-uc)
		 (format t "extending~%")
		 (setq suffix (caar x)
		       n (cdar x)
		       x (node-next (cdar x))))
	       #+(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
	     (let* ((nodex (node-next n))
		    (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)
		      (setq prefix (concatenate 'string prefix (caar x))
			    n (cdar x)
			    x (node-next (cdar x)))
		      (values (%str prefix)
			      (sort (mapcar #'%strx x) #'string<)
			      (> (aref (dictionary-codev dict) n) -1)))
		     (t
		      (let* ((p (mapcan #'(lambda (ex)
					    (let ((next (node-next (cdr ex))))
					      (if next
						  (mapcar #'(lambda (n)
							      (concatenate 'string (car ex) (car n)))
							  (node-next (cdr ex)))
						  (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))))))))))

;; Like unicode-complete-name, but we also try to handle 
(defun unicode-complete (prefix
			 &optional (dict (lisp::unidata-name+
					  lisp::*unicode-data*)))
  "Search the dictionary in Dict and return a list of the possible
  completions starting with Prefix.  If there is no match, NIL is
  returned."
  (let (names)
    (cond ((search "Hangul_Syllable_" prefix)
           (lisp::initialize-reverse-hangul-tables)
           ;; We should probably do something better than return all
           ;; the possible matches, but this works.  Slime takes care
           ;; of removing the items that don't match the prefix.
           (loop for choseong across lisp::*reverse-hangul-choseong* do
                (loop for junseong across lisp::*reverse-hangul-jungseong* do
                     (loop for jongseong across lisp::*reverse-hangul-jongseong* do
                          (push (format nil "Hangul_Syllable_~A~A~A"
                                        (car choseong)
                                        (car junseong)
                                        (car jongseong))
                                names))))
	   ;; Remove things that can't have prefix as its prefix.
	   (setf names (delete-if-not #'(lambda (x)
					  (search prefix x :test #'char-equal))
				      names)))
          ((search "Cjk_Unified_Ideograph-" prefix)
           (setf names
                 (loop for x from #x4e00 upto #x9fff
                    collect (format nil "Cjk_Unified_Ideograph-~X" x)))
	   (setf names (delete-if-not #'(lambda (x)
					  (search prefix x :test #'char-equal))
				      names))))
    ;;(format t "Searching name dictionary~%")
    (multiple-value-bind (prefix-match next completep)
	(lisp::unicode-complete-name prefix dict)
      ;;(format t "next = ~S~%" next)
      (loop for x in next
	 do (push (concatenate 'string prefix-match x) names))
      (when completep
	(push prefix-match names))
      ;;(format t "unicode-complete names = ~S~%" names)

      ;; Match prefix against Hangul and/or Hangul_syllable
      (cond ((or (string= prefix-match "Hangul_")
		 (search "Hangul_Syllable_" prefix-match :end1 (min 16 (length prefix-match))))
	     ;; Add syllable as possible completion
	     (push "Hangul_Syllable_" names))
	    ((or ;;(string= prefix-match "Cjk_")
	      (search "Cjk_Unified_Ideograph-" prefix-match :end1 (min 22 (length prefix-match))))
	     ;; Add Unified
	     (format t "adding cjk-unified~%")
	     (push "Cjk_Unified_Ideograph-" names)
	     (format t "cjk-unified names = ~S~%" names)))
      (setf names (mapcar #'string-capitalize names))
      ;;(format t "Final names = ~S~%" names)
      names)))

(defun %str (x) (nsubstitute #\_ #\Space (string-capitalize x)))
(defun %strx (x) (%str (car x)))

(defun %match (part prefix posn)
  (and (>= (length part) (- (length prefix) posn))
       (string= part prefix :start2 posn :end1 (- (length prefix) posn))))

(defun %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)))))

(defun %mip (strings)
  (let* ((first (first strings))
	 (posn (length first)))
    (dolist (string (rest strings))
      (setq posn (mismatch first string :end1 posn)))
    (subseq first 0 posn)))

(defun node-next (i &aux (dict (lisp::unidata-name+ lisp::*unicode-data*)))
  (let* ((j (aref (dictionary-nextv dict) i))
	 (x (ldb (byte 14 18) j))
	 (y (ldb (byte 18 0) j)))
    (loop for i from 0 below (aref (dictionary-keyl dict) x)
       collect (close-node (cons (aref (dictionary-cdbk dict)
				       (aref (dictionary-keyv dict) (+ x i)))
				 (+ y i))))))

(defun close-node (i &aux (dict (lisp::unidata-name+ lisp::*unicode-data*)))
  (loop
     (if (> (aref (dictionary-codev dict) (cdr i)) -1)
	 (return i)
	 (let* ((j (aref (dictionary-nextv dict) (cdr i)))
		(x (ldb (byte 14 18) j))
		(y (ldb (byte 18 0) j)))
	   (if (> (aref (dictionary-keyl dict) x) 1)
	       (return i)
	       (let ((k (aref (dictionary-cdbk dict)
			      (aref (dictionary-keyv dict) x))))
		 (setf (car i) (concatenate 'string (car i) k)
		       (cdr i) y)))))))
))