[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

symbol-complete: NOW Powerbook friendly

Using MCL on powerBooks (not plugged in to the wall) more and more I'm
getting really sensitive towards every unecessary hard disk access.
Symbol-completion in FRED will show you the list of arguments in the mini
buffer if a completed symbol is FBOUNDP. Unfortunately, this will spin up
your disk and significatly shorten the time you get out of you batteries.
Now version 2.0.5 of symbol-complete will take the environment variable
*Arglist-On-Space* into account. If you set it to nil => no HD access.

Below is the new version. I tried to load it up to cambridge.apple.com 
contrib:fred but it didn't let me do it. Any ideas?

Btw, has anybody hacked a relyable POWER-BOOK-P gestallt function?

   Happy PowerBook hacking,  Alex

     _/_/_/    _/_/_/  _/_/_/    Alex Repenning (ralex@cs.colorado.edu)
   _/      _/    _/      _/      University of Colorado
  _/            _/      _/       Department of Computer Science and
 _/            _/      _/        Institute of Cognitive Science
_/      _/    _/      _/         Boulder, CO 80309-0430
 _/_/_/        _/_/_/            Phone: (303) 492-1349   

;;; -*- package: ccl -*-
;*                                                                   *
;*    PROGRAM      S Y M B O L   C O M P L E T I O N                 *
;*    PACKAGE      :ccl                                              *
;*                                                                   *
   ;* Author:     Alex Repenning, ralex@cs.colorado.edu              *
   ;*             Copyright (c) 1992 Alex Repenning                  *
   ;*                                                                *
   ;* Address:    Computer Science Department                        *
   ;*             University of Colorado at Boulder                  *
   ;*             Boulder, CO 80309-0430                             *
   ;*                                                                *
   ;* Filename         : symbol-complete.lisp                        *
   ;* Last Update      : 10/27/94                                    *
   ;* Version   :                                                    *
   ;*   1.0   07/24/90  Alex Repenning                               *
   ;*   1.1   04/13/91  Alex & Brigham Bell   completion works also  *
   ;*                   if cursor in the middle of symbol.           *
   ;*   2.0    1/ 6/92  Alex, MCL 2.0                                *
   ;*   2.0.1  3/31/92  left trim "#'", "#`", "#", "'", "`"          *
   ;*   2.0.2  8/25/92  Preserve package qualifier.                  *
   ;*   2.0.3  12/8/92  Show arglist                                 *
   ;*   2.0.4  12/16/92 Use shortest package qualifiers              *
   ;*   2.0.5  10/27/94 Powerbook: *Arglist-On-Space* can be used to *
   ;*                   prevent HD access.                           *
   ;* System    : Macintosh II, MCL 2.0                              *
   ;* Abstract  : A simple line completion mechanism.                *
   ;* Features:                                                      *
   ;*   - Simple one key operation: Since most users do not like to  *
   ;*       remember many different completion functions, this       *
   ;*       completion package combines several completion           *
   ;*       strategies into one function (using a cascading filter   *
   ;*       scheme).                                                 *
   ;*         1) prefix search in window package                     *
   ;*         2) prefix search in all packages                       *
   ;*         3) substring search in window package                  *
   ;*         4) substring search in all packages                    *
   ;*       If no symbol is found the next strategy is employed.     *
   ;*       If only one symbol is found it will be used as           *
   ;*       completion.                                              *
   ;*       If multiple symbols are found then either the symbol     *
   ;*       is completed as far as possible or a menu is offered.    *
   ;*   - Partial Completion (sounds like a contradiction):          *
   ;*       If at any stage in the search there is more than one     *
   ;*       interned symbol matching what you typed so far and if    *
   ;*       the common prefix of these symbols is longer than what   *
   ;*       is typed so far you will get this common prefix.         *
   ;*   - Preserves Case: The completion will assume the same case   *
   ;*       of the string typed so far (lower case, upper case, or   *
   ;*       capitalized),                                            *
   ;*       e.g., "*Apple-" gets completed to "*Apple-Menu*"         *
   ;*   - Works also with Dialog Boxes                               *
   ;*   - It's Small: more comments than code ;-)                    *
   ;* Bugs, Problems: Haven't found a good strategy yet to deal with *
   ;*   package prefixes of partial completions:                     *
   ;*    - use partial completion only if all symbol from same       *
   ;*      package?                                                  *
   ;*    - strip package prefix?                                     *
   ;*      Any ideas?                                                *
   ;*   Completion can be slow in very crowded packages (e.g., :ccl) *
   ;* Acknowledgements:                                              *
   ;*   Guillaume Cartier (cartier@mipsmath.math.uqam.ca)            *
   ;*     preserve keyword qualifier in partial completion           *
   ;*                                                                *

(in-package :ccl)

(defvar *Maximum-Pop-up-Size* 100
  "if the number of matches exceeds this number then warn user")

;  high-level completion functions             |

(defmethod COMPLETE-SYMBOL ((Self fred-mixin)) "
  in: Self {fred-mixin}.
  Try to complete the selected symbol using a decreasingly constraining
  search through existing (interened) symbols."
  (let ((*Package* (or (window-package Self) *Package*)))
    (multiple-value-bind (String Start End Package Package-Qualifier) 
        (selected-symbol-string Self)
      (when String
          (search-for-matching-symbols Self (string-upcase String) Package)
        (when *Arglist-On-Space* (ed-arglist Self))))))

(defmethod SELECTED-SYMBOL-STRING ((Self fred-mixin)) "
  in:  Self {fred-mixin}.
  out: String {string} or nil, Start {position}, End {position}, Package
  Return the selected symbol (the one highlighted or just being to the
  left of the insertion marker."
  (let ((Mark (fred-buffer Self)))
    (multiple-value-bind (Start End) (buffer-current-sexp-bounds Mark)
      (when Start 
        (let* ((Start (case (buffer-char Mark Start)
                         (if (< (1+ Start) End)
                           (case (buffer-char Mark (1+ Start))
                             ((#\' #\`) (+ Start 2))
                             (t (1+ Start)))
                           (1+ Start)))
                        ((#\' #\` #\,) (1+ Start))
                        (t Start)))
               (String (buffer-substring Mark End Start)))
           (string->name String)
           (package-name (gracefully-find-package 
                          (or (string->package String) 
                              (window-package Self)
           (string->package-qualifier String)))))))

(defmethod CHOOSE-ONE-SYMBOL-NAME ((Self fred-mixin) String Symbols
Package-Qualifier) "
  in:  Self {fred-mixin}, String {string}, Symbols {list of: {symbol}},
       Package-Qualifier {string}.
  out: Name {string}.
  Pick a symbol close to <String> using the following strategy:
  |<Symbols>| = 0 -> <String>
  |<Symbols>| = 1 -> (first <Symbols>)
  |<Symbols>| > 1  and |common-prefix| = 0 -> user-choice
  |<Symbols>| > 1  and |common-prefix| > 0 -> common-prefix."
  (case (length Symbols)
    (0 (format (view-mini-buffer Self) "no matches") String)
    (1 (spn-print-to-string (first Symbols)))
    (t (multiple-value-bind (Prefix Common-Package) 
           (common-symbol-name-prefix Symbols)
         (if (> (length Prefix) (length String))
           (if (and Common-Package
                    (equal (string->package Package-Qualifier)
                           (package-name Common-Package)))
             (concatenate 'string Package-Qualifier Prefix)
            ((<= (length Symbols) *Maximum-Pop-Up-Size*)
             (spn-print-to-string (first (select-item-from-list 
                                      :window-title "select completion"
                                      :table-print-function #'spn-print))))
             (format (view-mini-buffer Self) "too many matches: ~A"
(length Symbols))

  in:  Symbols {list of: {symbol}}.
  out: Prefix {string} or nil, Common-Package {package}."
  (let ((First-String (symbol-name (first Symbols))))
     (with-output-to-string (S)
       (block done
         (dotimes (I (length First-String))
           (let ((Char (char First-String I)))
             (dolist (String (mapcar #'symbol-name (rest Symbols)) (princ
Char S))
               (when (or (> I (length String)) (char/= (char String I) Char))
                 (return-from done nil)))))))
     (let* ((Packages (mapcar #'symbol-package Symbols))
            (Package (first Packages)))
       (when (every #'(lambda (P) (eq P Package)) Packages) Package)))))

(defmethod SEARCH-FOR-MATCHING-SYMBOLS ((Self fred-mixin) String Package) "
  in:  Self {fred-mixin}, String {string}, Package {string}.
  out: Matches {list of: {symbol}}. "
  ; 1) search prefix, same package
  (let ((MB (view-mini-buffer Self)))
    (format MB ".")
    (mini-buffer-update Self)
    (let* ((Local-Symbols (apropos-list String Package))
           (Symbols (matching-prefix-symbols String Local-Symbols)))
      (if Symbols
        ; 2) search prefix, all packages
          (format MB ".")
          (mini-buffer-update Self)
          (let* ((Global-Symbols (apropos-list String))
                 (Symbols (matching-prefix-symbols String Global-Symbols)))
            (if Symbols
              ; 3) search substring, same package
                (format MB ".")
                (mini-buffer-update Self)
                (if Local-Symbols
                  ; 4) return any match: substring in all packages
                    (format MB ".")
                    (mini-buffer-update Self)

(defun MATCHING-PREFIX-SYMBOLS (String Symbols) "
  in:  String {string}, Symbols {list of: {symbol}}.
  out: Symbols {list of: {symbol}}.
  Return only the symbols of which <String> is a prefix."
  (let ((L (length String)))
     #'(lambda (Symbol) (string= String (symbol-name Symbol) :end1 L :end2 L))

;  low-level functions                         |

(defmethod BUFFER-REPLACE-STRING ((Self fred-mixin) Start End String
&optional Old-String) "
  in:  Self {fred-mixin}, Start End {position}, String {string}, 
       &optional Old-String {string}.
  Delete the buffer content between <Start> and <End>, insert
  <String> and place insertion marker to <End> position."
  (let ((Mark (fred-buffer Self)))
    (buffer-delete Mark Start End)
     (if Old-String
       (case (string-format Old-String)
         (:upper (string-upcase String))
         (:lower (string-downcase String))
         (:capital (string-capitalize String)))

(defun STRING-FORMAT (String) "
  in:  String {string}.
  out: Capitalization {keyword} :upper, :lower :capital.
  Return the capitalization status of a string"
  (case (length String)
    (0 :lower)
    (1 (if (lower-case-p (char String 0)) :lower :upper))
    (t (if (char= (char String 0) #\*)
         (string-format (subseq String 1))
         (if (upper-case-p  (char String 0))
           (if (upper-case-p (char String 1))

  in:  Package {string}.
  out: Package {string}.
  If FIND-PACKAGE doesn't find <Package> then prompt the user for an
  (or (find-package Package) 
       (first (select-item-from-list 
               (mapcar #'package-name (list-all-packages))
               :window-title "Select an existing Package")))))

(defun STRING->PACKAGE (String) "
  in:  String {string}. out: Package {string} or nil.
  Return package prefix of string (if any)"
  (let ((P (position #\: String)))
    (when P
      (if (zerop P)
        (string-upcase (subseq String 0 P))))))

(defun STRING->NAME (String) "
  in: String {string}. out: Name {string}.
  Return <string> without a package prefix."
  (let ((P (position #\: String)))
    (if P
      (string-left-trim ":" (subseq String P))

  in:  String {string}.
  out: Package-Qualifer {string}. "
  (let ((P (position #\: String)))
    (when P
      (if (zerop P)
        (if (and (< P (1- (length String))) (char= (char String (1+ P)) #\:))
          (subseq String 0 (+ P 2))
          (subseq String 0 (+ P 1)))))))

;  Shortest Package Names                      |

#-:mcl       ; MCL defines this function, but .. just in case
  in:  Package {package}.
  out: Name {string}.
  Return the package name or if there are any nicknames
  return the shortest nickname."
  (let ((Nicknames (package-nicknames Package)))
    (if Nicknames
      (let ((Shortest-Name (first Nicknames)))
        (dolist (Name (rest Nicknames))
          (when (< (length Name) (length Shortest-Name))
            (setq Shortest-Name Name)))
      (package-name Package))))

(defun SPN-PRINT (Symbol &optional Stream) "
  in: Symbol {symbol}, &optional Stream {output-stream}.
  Like PRIN1 for symbols but use shortest package nicknames for 
  package qualifiers (if any)."
  (unless (find-symbol (symbol-name Symbol))
    (let ((Home-Package (symbol-package Symbol)))
      (unless (eq Home-Package (find-package :keyword))
        (princ (shortest-package-nickname Home-Package) Stream))
      (multiple-value-bind (S Status) 
           (find-symbol (symbol-name Symbol) Home-Package)
        (declare (ignore S))
        (ecase Status
          (:internal (princ "::" Stream))
          (:external (princ ":" Stream))))))
  (princ Symbol Stream))

(defun SPN-PRINT-TO-STRING (Symbol) "
  in:  Symbol {symbol}.
  out: String {string}.
  Write <Symbol> to <String>. Use shortest package qualifiers (if any)"
  (with-output-to-string (Stream)
    (spn-print Symbol Stream)))
;  keyboard bindings                           |

;this overwrites the set-mark EMACS command
(comtab-set-key *Comtab* '(:control #\space) 'complete-symbol)
#| stuff:

(common-symbol-name-prefix '(bla-lkfdflkdf blappppppp bla)) -> "BLA"
(common-symbol-name-prefix (apropos-list "WITH-OP")) -> "WITH-OPEN-"

(string->package "dsdsd")  -> nil
(string->package "ccl::gc")  -> "CCL"
(string->package ":rest") -> "KEYWORD"

(shortest-package-nickname :common-lisp-user) => "CL-USER"