majka@ubc-vision.UUCP (Marc Majka) (08/02/85)
<Take and eat, these are my bits>
Here is an Mlisp string completion function for Unipress #264 Emacs. It
behaves like get-tty-command except that it looks up permissible strings in
a buffer. Lots of in-line comments to describe the algorithm.
It is supplied with a demo program called "animal". Try it out! Just save
the part below the CUT line, and execute-mlisp-buffer it.
Bug reports and suggestions to Marc Majka <majka@ubc-vision.UUCP>
or ...decvax!tektronix!uw-beaver!ubc-vision!majka
---
Marc Majka - UBC Laboratory for Computational Vision
--- CUT --- CUT --- CUT --- CUT --- CUT --- CUT ---
;
;************************************************************
; Copyright (c) 1985 *
; Marc S. Majka - UBC Laboratory for Computational Vision *
; *
; Permission is hereby granted to copy all or any part of *
; this program for non-commercial use. The author's name *
; and this copyright notice must be included in any copy. *
;************************************************************
;
;
; NAME: get-word-in-buffer - get a line from a buffer,
; providing help and string completion.
;
; SYNOPSIS: (get-word-in-buffer buffer-name prompt-string)
;
; DESCRIPTION: get-word-in-buffer is designed to give MLISP
; functions a mechanism for providing the user
; with command completion for arbitrary sets of
; strings. The buffer argument should contain a
; sorted list of strings. get-word-in-buffer
; prompts the user with the prompt argument, and
; reads characters from the keyboard. A <space>
; character causes completion (or extension) to
; be invoked. A "?" character causes a menu of
; possible strings to be displayed. The user input
; sections are designed to mimic the EMACS built-in
; completion commands, such as get-tty-file,
; get-tty-buffer, and get-tty-command.
;
; The completion (extension) algorithm proceeds by
; moving two pointers, p1 and p2, from the beginning
; and end of the buffer in order to "bracket" a
; region. The top pointer, p1, is moved forward to
; the first line in the buffer which has the current
; user string as a prefix. If no such line exists,
; the last character in the user string is dropped
; and the search is attempted again. Similarly, p2
; is moved to the last line containing the user
; string as a prefix.
;
; If the pointers meet, then there is a single line
; in the buffer which matches the user's input, so
; the string is completed.
;
; If the pointers do not meet, then the string is
; extended to be the longest possible prefix in the
; bracketed region.
;
; SYSTEM: This software runs on a UNIPRESS #264. It should be easy
; to convert to Gosling (change "error-occurred" to
; "error-occured"). GNU? forget it. Note that it calls
; /bin/pr to format the help window.
;
(defun
(get-word-in-buffer buf prompt str c found b s shelp
(setq buf (arg 1 ": get-word-in-buffer buffer: "))
(setq prompt (arg 2 (concat ": get-word-in-buffer buffer: "
buf " prompt: ")))
(setq str "")
(setq found 0)
(setq c (getchar (concat prompt str)))
(while (! found)
(setq str (concat str c))
;
; space: push the pointers together, dropping unacceptable characters.
;
(if (= c " ")
(save-window-excursion p1 p2 str1 str2 c1 c2 len tstr
(setq str (substr str 1 (- (length str) 1)))
(setq tstr str)
(pop-to-buffer buf)
; top pointer (p1)
(beginning-of-file)
(while (error-occurred
(re-search-forward (concat "^" str)))
(setq str (substr str 1 (- (length str) 1))))
(beginning-of-line)
(setq p1 (dot))
; bottom pointer (p2)
(end-of-file)
(while (error-occurred
(re-search-reverse (concat "^" str)))
(setq str (substr str 1 (- (length str) 1))))
(beginning-of-line)
(setq p2 (dot))
;
; test if any characters were dropped. if so, do nothing.
;
(if (!= str tstr) (setq found 0)
(if (= p1 p2)
;
; pointers met. found a unique string
;
(progn
(set-mark)
(end-of-line)
(setq str (region-to-string))
(setq found 1))
;
; pointers did not meet. extend string
;
(progn
(setq len (+ 1 (length str)))
(goto-character p1)
(set-mark)
(end-of-line)
(setq str1 (region-to-string))
(goto-character p2)
(set-mark)
(end-of-line)
(setq str2 (region-to-string))
(setq c1 (substr str1 len 1))
(setq c2 (substr str2 len 1))
(while (= c1 c2)
(setq str (concat str c1))
(setq len (+ len 1))
(setq c1 (substr str1 len 1))
(setq c2 (substr str2 len 1)))
(setq found 0))))))
;
; backspace: delete last string character
;
(if (= c "")
(setq str (substr str 1 (- (length str) 2))))
;
; del: erase string
;
(if (= c "")
(setq str ""))
;
; ^G: abort
;
(if (= c "")
(error-message "Aborted."))
;
; return: force the current string to be returned
;
(if (= c "
")
(progn
(setq str (substr str 1 (- (length str) 1)))
(setq found 1)))
;
; question: construct a list of possible extensions
;
(if (= c "?")
(progn cw
;
; pull the bracketed section out of the buffer
;
(save-window-excursion p1 p2
(setq str (substr str 1 (- (length str) 1)))
(pop-to-buffer buf)
(beginning-of-file)
(while (error-occurred
(re-search-forward (concat "^" str)))
(setq str
(substr str 1 (- (length str) 1))))
(beginning-of-line)
(set-mark)
(end-of-file)
(while (error-occurred
(re-search-reverse (concat "^" str)))
(setq str
(substr str 1 (- (length str) 1))))
(next-line)
(beginning-of-line)
(setq shelp (region-to-string)))
;
; make the help window
;
(setq cw (current-buffer-name))
(pop-to-buffer "Help")
(setq needs-checkpointing 0)
(erase-buffer)
(insert-string shelp)
(beginning-of-file)
(set-mark)
(end-of-file)
(fast-filter-region "/bin/pr -3 -l1 -t")
(beginning-of-file)
(insert-string "Choose one of the following:\n")
(pop-to-buffer cw)))
;
; get another character from the user
;
(if (! found)
(setq c (getchar (concat prompt str)))))
str))
;
; getchar - prompt the user for a single character
;
(defun
(getchar c
(save-window-excursion
(pop-to-buffer " Minibuf")
(erase-buffer)
(message (arg 1))
(sit-for 0)
(end-of-file)
(setq c (char-to-string (get-tty-character)))
(erase-buffer)
c)))
;
; test/demo function
;
(defun
(animal str
(setq str (get-word-in-buffer "XanimX" ": animal "))
(message "You chose " str)))
;
; my favorite animals
;
(save-window-excursion
(pop-to-buffer "XanimX")
(setq needs-checkpointing 0)
(erase-buffer)
(insert-string "aardvark\n")
(insert-string "ant\n")
(insert-string "bat\n")
(insert-string "bear\n")
(insert-string "bumblebee\n")
(insert-string "cat\n")
(insert-string "catfish\n")
(insert-string "cow\n")
(insert-string "dog\n")
(insert-string "duck\n")
(insert-string "elephant\n")
(insert-string "emu\n")
(insert-string "ferret\n")
(insert-string "frog\n")
(insert-string "gnu\n")
(insert-string "goat\n")
(insert-string "horse\n")
(insert-string "hound\n")
(insert-string "indigo bunting\n")
(insert-string "jackrabbit\n")
(insert-string "koala\n")
(insert-string "llama\n")
(insert-string "moose\n")
(insert-string "mouse\n")
(insert-string "newt\n")
(insert-string "ostrich\n")
(insert-string "pig\n")
(insert-string "porqupine\n")
(insert-string "quahaug\n")
(insert-string "rat\n")
(insert-string "spider\n")
(insert-string "teal\n")
(insert-string "unicorn\n")
(insert-string "vampire\n")
(insert-string "wolf\n")
(insert-string "wombat\n")
(insert-string "yeti\n")
(insert-string "zebra\n"))