Programmer 7500/MAX_PROGRAMMERS.iso/CLIPPER/MISC/MENUSPCS.ZIP/MENUS.S

Text File | 1987-12-14 | 31.5 KB | 833 lines

;;; ------------------------------------------------------------
;;; Menus for Scheme (tm)
;;; CLASS DEFINITIONS, METHODS, CONSTRUCTORS, AND UTILITIES
;;; $Revision:   1.4  $    $Date:   14 Dec 1987  0:18:00  $
;;; ------------------------------------------------------------
;;; Copyright (c) 1987 by Morton Goldberg.
;;;
;;; Permission is granted to make copies of this program text
;;; for personal, non-commercial use provided this notice of
;;; copyright appears in all copies and derived works.  All
;;; other rights reserved.  In particular, you may not publish
;;; or otherwise distribute any copies of this text or any
;;; derived works without permission from the copyright holder.
;;; ------------------------------------------------------------
;;; Implementation Language: Texas Instruments' PC SCHEME
;;; (Version 3.0)
;;; ------------------------------------------------------------

(writeln "Menus for Scheme (tm)")
(writeln "Copyright (c) 1987 by Morton Goldberg")
(let ((rev-number "$Revision:   1.4  $"))
  ;; Write the revision number string without the leading and
  ;; trailing dollar-signs (which are needed by the version
  ;; control system).
  (writeln (substring rev-number
                      1
                      (sub1 (string-length rev-number)))))

;;; ------------------------------------------------------------
;;; READ A LINE OF CHARACTERS FROM A WINDOW
;;; ------------------------------------------------------------

;;; This procedure reads characters as they are typed into a
;;; window.  It echos the characters so the user can see the
;;; type-in.  Destructive backspace is supported for minor
;;; editing.  Pressing the enter-key, ends reading and returns
;;; the characters typed as a string.  Pressing the escape-key,
;;; ends reading characters and returns an empty string.  The
;;; procedure is used by the read-response method of class popup
;;; query window.
(define (readln window)
  (define chr #\?)
  (define ln '())
  (define (read-loop window)
    (set! chr (read-char window))
    (case (char->integer chr)
      ;; Typing a #\RETURN exits the loop and returns
      ;; a list of the characters read.
      (#xD ln)
      ;; Typing an #\ESC exits the loop and returns an
      ;; empty list.
      (#x1B '())
      ;; This implements a destructive backspace.
      (#x8
       (set! ln (cdr ln))
       (let ((cursor (window-get-cursor window)))
         (window-set-cursor! window
                             (car cursor)
                             (sub1 (cdr cursor)))
         (write-char #\SPACE window)
         (window-set-cursor! window
                             (car cursor)
                             (sub1 (cdr cursor))))
       (read-loop window))
      ;; Add another character to the list.
      (else
       (write-char chr window)
       (set! ln (cons chr ln))
       (read-loop window))))
  (list->string (reverse (read-loop window))))

;;; ------------------------------------------------------------
;;; CLASS KEY MONITOR
;;; ------------------------------------------------------------
;;; Class key-monitor is a component of the SCOOPS-based menu
;;; system for Scheme programs, where it is used as a mixin.
;;; However, class key-monitor may be instantiated; instances of
;;; key-monitor can be created and used without any reference to
;;; the rest of menu-system.

;;; A key-monitor object reads characters from the current input
;;; port, usually but not necessarily the keyboard, and produces
;;; an action; that is, it executes a procedure that has been
;;; associated with the character.  The association between the
;;; character and the action is maintained in a key action
;;; table.  The class provides methods for modifying a key
;;; action table at run time.  Consequently, a program using
;;; class key-monitor may implement dynamic key-to-action
;;; mapping.
(define-class key-monitor
  ;; The class variables are the key actions which are used
  ;; to initialize the key action tables.  Each key action
  ;; is a procedure taking one argument, a character.
  (classvars
    ;; Just return the character.
    (no-op
      (lambda (ch)
        ch))
    ;; Get another character and use the special-key action
    ;; table to handle it.
    (special-key
      (lambda (ignore)
        (read-again-and-act)))
    ;; Just return the abort symbol.
    (user-abort
      (lambda (ignore)
        'USER-ABORT)))
  ;; The instance variables are key action tables.  A key
  ;; action table is a vector of 128 procedures of the form:
  ;;     #(key-action-0 key-action-1 ... key-action-127)
  (instvars
    ;; This table holds the actions for the keys producing
    ;; characters in the normal ASCII range.
    (actions-for-ascii-keys
      (let ((tmp (make-vector 128 no-op)))
        (vector-set! tmp 0 special-key)
        (vector-set! tmp #x1B user-abort)
        tmp))
    ;; This table holds the actions for the function keys,
    ;; the cursor control keys, and the so-called word
    ;; processing keys.
    (actions-for-special-keys
      (make-vector 128 no-op)))
  (options
    (gettable-variables no-op special-key user-abort)))

(compile-class key-monitor)

;;; ------------------------------------------------------------
;;; METHODS FOR CLASS KEY MONITOR

;;; Install a key action procedure in the designated table at
;;; the designated index.  This the shared, private key
;;; installation method.  Programs using key monitors should use
;;; one of two following methods rather than this one.
(define-method (key-monitor install-key) (table indx proc)
  (vector-set! table indx proc))

;;; Install a key action procedure, proc, in the ASCII key table
;;; at the position, indx.  Use for effect; returns nothing
;;; useful.
(define-method (key-monitor install-ascii-key) (indx proc)
  (install-key actions-for-ascii-keys indx proc))

;;; Install a key action procedure, proc, in the special key
;;; table at the position, indx.  Use for effect; returns
;;; nothing useful.
(define-method (key-monitor install-special-key) (indx proc)
  (install-key actions-for-special-keys indx proc))

;;; Process a key if one is ready, but don't waste time waiting
;;; if one isn't ready.  Returns whatever the key action
;;; associated with the character returns if a character is
;;; avaliable; otherwise returns #f.
(define-method (key-monitor look-for-key) ()
  (if (char-ready?)
    (read-key-and-act actions-for-ascii-keys)))

;;; Reads a byte (character) and executes the action stored in
;;; the designated key action table at the position indexed by
;;; the byte.  Returns whatever the key action returns.
(define-method (key-monitor read-key-and-act) (table)
  (let((ch (read-char)))
    ((vector-ref table (char->integer ch)) ch)))

;;; Reads the second byte of a special key and executes the
;;; action in the special key table at the position indexed by
;;; the byte.  Returns whatever the special key action returns.
(define-method (key-monitor read-again-and-act) ()
  (read-key-and-act actions-for-special-keys))

;;; ------------------------------------------------------------
;;; CLASS BASIC POPUP WINDOW
;;; ------------------------------------------------------------
;;; This class supplies defines the instance variables and basic
;;; methods for simple popup windows that can be used for
;;; various purposes.  The class can only be used as a mixin.
;;;
;;; (*) indicates a user-supplied value; the values for the
;;; other instvars are computed.
(define-class basic-popup-window
  (instvars
    w-rows  ; height of the window (*)
    w-cols  ; width of the window (*)
    n-attr  ; window normal attribute (*)
    border? ; if #f, window won't have border (*)
    w-top   ; top row of the window on the screen
    w-left  ; left column of the window on the screen
    window) ; the port assigned to the window
  (options
    (gettable-variables
      w-top w-left w-rows w-cols border?)
    (settable-variables
      w-top w-left)
    (inittable-variables
      w-top w-left n-attr border?)))

(compile-class basic-popup-window)

;;; ------------------------------------------------------------
;;; METHODS FOR CLASS BASIC POPUP WINDOW

;;; Make the popup window appear on the screen.
(define-method (basic-popup-window expose) ()
  (if border?
    (window-set-attribute! window
                           'border-attributes
                           n-attr))
  (window-set-attribute! window 'text-attributes n-attr)
  (window-set-position! window w-top w-left)
  (window-set-size! window w-rows w-cols)
  (window-popup window))

;;; Erase the popup window from the screen.
(define-method (basic-popup-window expunge) ()
  (window-popup-delete window))

;;; ------------------------------------------------------------
;;; CLASS POPUP TEXT WINDOW
;;; ------------------------------------------------------------
;;; This class is built on the basic-popup-window class.  It
;;; adds the methods for writing one or more lines of text into
;;; a popup window.  The class can be instantiated or it can be
;;; used as a mixin.
;;;
;;; (*) indicates a user-supplied value; the values for the
;;; other instvars are computed.
(define-class popup-text-window
  (instvars
    ;; The contents of the window, a vector of text strings.
    ;; Each element of the vector appears as one line of
    ;; text in the window.  The size of the window is
    ;; adjusted to fit the text by the adjust-size method.
    (text (active "" #f adjust-size)))
  (mixins
    basic-popup-window))

(compile-class popup-text-window)

;;; ------------------------------------------------------------
;;; CONSTRUCTOR
;;;
;;; The constructor returns the instance it creates.  Init-list
;;; is a list of form
;;;
;;; (instvar-name initial-value ... )
;;;
;;; and text is a vector of the form
;;;
;;; #(string ... ).
(define (make-popup-text-window init-list text)
  (let ((a-popup-text-window
    (eval `(make-instance popup-text-window ,@init-list))))
    (send a-popup-text-window init)
    (send a-popup-text-window set-text text)
    a-popup-text-window))

;;; ------------------------------------------------------------
;;; METHODS FOR CLASS POPUP TEXT WINDOW

;;; This method must be called before an instance of popup-
;;; text-window can be used for the first time.  This is done by
;;; the constructor make-popup-text-window.
(define-method (popup-text-window init) ()
  ;; Assign a window to the popup
  (set! window (make-window #f border?)))

;;; This method is called whenever the instvar text, an active
;;; value, is changed by a (send ... set-text .. ) message.
(define-method (popup-text-window adjust-size) (txt)
  ;; Determine the size of the window.
  (set! w-rows (vector-length txt))
  (set! w-cols
        (apply max (map string-length (vector->list txt))))
  txt)

;;; The method used by applications to popup a popup-text-
;;; window.  The popup-text-window disappears when [ESC] is
;;; pressed.  Used for effect; returns nothing useful.
(define-method (popup-text-window popup) ()
  (expose)
  (write-text)
  (watch-for-esc)
  (expunge))

;;; Write a vector of text strings into the popup-text-window.
;;; The vector is the stored in the instvar text.
(define-method (popup-text-window write-text) ()
  (do ((row 0 (add1 row)))
      ((>= row w-rows))
    (window-set-attribute! window 'text-attributes n-attr)
    (window-set-cursor! window row 0)
    (display (vector-ref text row) window)))

;;; Watch for keystrokes, ignore everything but [ESC].
(define-method (popup-text-window watch-for-esc) ()
  (case (char->integer (read-char))
    (#x1B
     '())
    (#x0
     (read-char)
     (watch-for-esc))
    (else
     (watch-for-esc))))

;;; ------------------------------------------------------------
;;; CLASS POPUP QUERY WINDOW
;;; ------------------------------------------------------------
;;; This class is built on the popup-text-window class.  It adds
;;; the methods for placing an input field within a text window
;;; and for reading data into the field.  The class can be
;;; instantiated.
;;;
;;; (*) indicates a user-supplied value; the values for the
;;; other instvars are computed.
(define-class popup-query-window
  (instvars
    hl-attr     ; window highlight attribute (*)
    cursor-row  ; starting row of the input field (*)
    cursor-col  ; starting column of the input field (*)
    input-width ; width of the input field (*)
    spaces      ; empty input field
    response    ; the response made by the user, a string
    ;; The contents of the window, a vector of text strings.
    ;; Each element of the vector appears as one line of
    ;; text in the window.  The spaces representing the
    ;; input field are added to one of elements by the
    ;; add-input-field method.
    (text (active "" #f add-input-field)))
  (mixins
    popup-text-window)
  (options
    (gettable-variables
      response)
    (inittable-variables
      hl-attr cursor-row cursor-col input-width)))

(compile-class popup-query-window)

;;; ------------------------------------------------------------
;;; CONSTRUCTOR
;;;
;;; The constructor returns the instance it creates.  Init-list
;;; is a list of form
;;;
;;; (instvar-name initial-value ... )
;;;
;;; and text is a vector of the form
;;;
;;; #(string ... ).
(define (make-popup-query-window init-list text)
  (let ((a-popup-query-window
    (eval `(make-instance popup-query-window ,@init-list))))
    (send a-popup-query-window init)
    (send a-popup-query-window set-text text)
    a-popup-query-window))

;;; ------------------------------------------------------------
;;; METHODS FOR CLASS POPUP QUERY WINDOW

;;; This method is called whenever the instvar text, an active
;;; value, is changed by a (send ... set-text .. ) message.
(define-method (popup-query-window add-input-field) (txt)
  (set! spaces (make-string input-width #\SPACE))
  (set! cursor-col
        (string-length (vector-ref txt cursor-row)))
  (vector-set! txt
               cursor-row
               (string-append (vector-ref txt cursor-row)
                              spaces))
  (adjust-size txt)
  txt)

;;; The method used by applications to popup a popup-query-
;;; window.  It calls the method read-response to get the user's
;;; reponse.  When read-repsponse return, this method expuges
;;; the popup-query-window from the screen.  The users response
;;; is put in the instance variable response from which it can
;;; be retrieve by the sending the get-response message.
(define-method (popup-query-window popup) ()
    (set! response "")
    (expose)
    (write-text)
    (set! response (read-response))
    (expunge))

;;; This method displays the input field using the window
;;; high-light attribute, reads in a line of characters with
;;; echo to the input field, and converts the characters into a
;;; string, which it returns.
(define-method (popup-query-window read-response) ()
  (window-set-attribute! window 'text-attributes hl-attr)
  (window-set-cursor! window cursor-row cursor-col)
  (display spaces window)
  (window-set-cursor! window cursor-row cursor-col)
  (readln window))

;;; ------------------------------------------------------------
;;; CLASS MENU-ITEM
;;; ------------------------------------------------------------
;;; This class provides the instance variables, i.e., the
;;; internal representation, of a menu item.  A vector of
;;; instances of this class forms an item-table, which is the
;;; principal structure of class basic-menu (see below).
;;;
;;; (*) indicates a user-supplied value; the values for the
;;; other instvars are computed.
(define-class menu-item
  (instvars
    action     ; action taken when this item is selected (*)
    label      ; string describing the menu item (*)
    label-row  ; row position of the label in the menu
    label-col) ; column position of the label in the menu
  (options
    gettable-variables
    (settable-variables
      label-row label-col)
    (inittable-variables
      action label)))

(compile-class menu-item)

;;; ------------------------------------------------------------
;;; CONSTRUCTOR
;;;
;;; The constructor returns the instance it creates.  Its
;;; argument is a list of the form
;;;
;;; (label-string selector action)
;;;
;;; which is the standard format of an item table entry.  Note
;;; that the second element of the argument list, the selector,
;;; is ignored by the constructor but is used by the menu object
;;; that contains the menu item constructed here.
(define (make-menu-item item-inits)
  (let ((labl-val (car item-inits))
        (actn-val (caddr item-inits)))
  (make-instance menu-item 'action actn-val
                           'label labl-val)))

;;; ------------------------------------------------------------
;;; CLASS BASIC MENU
;;; ------------------------------------------------------------
;;; This is the base class.  It supplies the methods for
;;; creating and dealing with the basic representation of a
;;; menu.  It is intended to be used as a mixin.
;;;
;;; (*) indicates a user-supplied or defaulted value; the values
;;; for the other instvars are computed.
(define-class basic-menu
  (instvars
    hl-attr     ; window highlight attribute (*)
    item-index  ; index into item-table
    items       ; total entries in item-table
    item-table) ; table of instances of class menu-item
  (mixins
    basic-popup-window key-monitor)
  (options
    (settable-variables
      item-index)
    (inittable-variables
      hl-attr)))

(compile-class basic-menu)

;;; ------------------------------------------------------------
;;; METHODS FOR CLASS BASIC MENU

;;; The init method for all menus.  Item-list is a list of the
;;; form
;;;
;;; ((label selector action) ... )
;;;
;;; where there is one entry for each menu item.  It is passed
;;; to the make-item-table method.
(define-method (basic-menu init) (item-list)
  ;; The arrow keys will move the bar cursor.
  (install-special-key 72 item<-) ; up-arrow
  (install-special-key 75 item<-) ; left-arrow
  (install-special-key 77 item->) ; right-arrow
  (install-special-key 80 item->) ; down-arrow
  ;; The enter key will select the menu item indicated by
  ;; the bar cursor.
  (install-ascii-key 13 select)
  ;; Assign a window to the menu.
  (set! window (make-window #f border?))
  ;; Create and partially initialize the item table.
  (set! item-index 0)
  (make-item-table item-list)
  ;; The following is a method that must be supplied by any
  ;; menu class built on basic-menu.  Its main function is
  ;; to complete the entries in the item table.
  (format-specific-init))

;;; This method is passed an item-list as described for method
;;; menu-init.  It uses the list to create and partially
;;; initialize an item-table entry for each menu item.  At the
;;; same time, it also installs an item selection procedure for
;;; each menu item in the ASCII key-action table.
(define-method (basic-menu make-item-table) (item-list)
  (set! items (length item-list))
  (set! item-table (make-vector items))
  (do ((index 0 (add1 index)))
      ((>= index items))
    (let* ((item-inits (list-ref item-list index))
           (slctr-val (cadr item-inits)))
      ;; Install one item in the item-table.
      (vector-set! item-table
                   index
                   (make-menu-item item-inits))
      ;; Install the selection procedure(s) in the key-action
      ;; table.
      (for-each (lambda (slctr-char)
                  (install-ascii-key (char->integer slctr-char)
                                     (lambda (ignore)
                                       (shift index)
                                       (select 'IGNORE))))
                (if (atom? slctr-val)
                  ;; This `if' expression makes the case of a
                  ;; single selector character the same as the
                  ;; case of multiple selector characters.
                  (list slctr-val)
                  slctr-val)))))

;;; The method used by applications to invoke a menu.
(define-method (basic-menu popup) ()
  (expose-menu)
  (keybd-watch)
  (expunge))

;;; Watch for keystrokes and act on them.
(define-method (basic-menu keybd-watch) ()
  (if (not (eq? 'USER-ABORT (look-for-key)))
    (keybd-watch)))

;;; Make the menu appear on the screen.
(define-method (basic-menu expose-menu) ()
  (expose)
  (do ((index 0 (add1 index)))
      ((>= index items))
    (write-label index n-attr))
  (write-label item-index hl-attr))

;;; Advance item-index and the bar cursor forward by one menu
;;; item.
(define-method (basic-menu item->) (ignore)
    (shift (modulo (add1 item-index) items)))

;;; Advance item-index and the bar cursor backward by one menu
;;; item.
(define-method (basic-menu item<-) (ignore)
    (shift (modulo (sub1 item-index) items)))

;;; This the general item-index and bar cursor mover.
(define-method (basic-menu shift) (new-index)
  (write-label item-index n-attr)
  (write-label new-index hl-attr)
  (set! item-index new-index))

;;; Write an item's label with the designated color attribute.
;;; The method is passed the color attribute and the index of
;;; the item.
(define-method (basic-menu write-label) (index attr)
  (let* ((item (vector-ref item-table index))
         (label (send item get-label))
         (row (send item get-label-row))
         (col (send item get-label-col)))
    (window-set-attribute! window 'text-attributes attr)
    (window-set-cursor! window row col)
    (display label window)))

;;; For whatever menu item is at the item-index position of the
;;; item-table, extract its action (a thunk) and call it.  The
;;; init-menu method installs this method in the ASCII key-
;;; action table at the index for the enter-key, so it can
;;; provide the hit-enter component for the traditional move-
;;; the-bar-cursor-and-hit-enter way of selecting menu items.
(define-method (basic-menu select) (ignore)
  ((send (vector-ref item-table item-index) get-action)))

;;; ------------------------------------------------------------
;;; CLASS HORIZONTAL MENU
;;; ------------------------------------------------------------
;;; This class can be instantiated.  It adds a method supplying
;;; the form-specific initializaton to the methods supplied by
;;; the class basic-menu.
(define-class horizontal-menu
  (instvars
    label-spacing) ; how many space chars between labels (*)
  (mixins
    basic-menu)
  (options
    (inittable-variables
      label-spacing)))

(compile-class horizontal-menu)

;;; ------------------------------------------------------------
;;; CONSTRUCTOR
;;;
;;; The constructor returns the instance it creates.  Its
;;; arguments are init-list and item-list.  Init-list is a list
;;; of the form
;;;
;;; (instvar-name initial-value ... )
;;;
;;; and item-list is a list of the form
;;;
;;; ((label selector action) ... )
;;;
;;; where there is one entry for each menu item.
(define (make-horizontal-menu init-list item-list)
  (let ((a-menu (eval `(make-instance horizontal-menu
                                      ,@init-list))))
    (send a-menu init item-list)
    a-menu))

;;; ------------------------------------------------------------
;;; METHOD FOR CLASS HORIZONTAL MENU
;;; ------------------------------------------------------------

;;; This is the format-specific intializer required of any class
;;; built on basic-menu.  For each item entry in the item table
;;; of a menu, it completes the entry by filling-in the fields
;;; which hold computed values.
(define-method (horizontal-menu format-specific-init) ()
  (let* ((offset 0)
         (complete-an-entry
           (lambda (index)
             (let* ((item (vector-ref item-table index))
                    (width (string-length
                             (send item get-label))))
               (send item set-label-row 0)
               (send item set-label-col offset)
               (set! offset (+ offset
                               width
                               label-spacing))))))
  (do ((index 0 (add1 index)))
      ((>= index items))
    (complete-an-entry index))
  (set! w-rows 1)
  (set! w-cols offset)))

;;; ------------------------------------------------------------
;;; CLASS VERTICAL MENU
;;; ------------------------------------------------------------
;;; This class can be instantiated.  It adds a method supplying
;;; the form-specific initializaton to the methods supplied by
;;; the class basic-menu.
(define-class vertical-menu
  (mixins
    basic-menu))

(compile-class vertical-menu)

;;; ------------------------------------------------------------
;;; CONSTRUCTOR
;;;
;;; The constructor returns the instance it creates.  Its
;;; arguments are init-list and item-list.  Init-list is a list
;;; of the form
;;;
;;; (instvar-name initial-value ... )
;;;
;;; and item-list is a list of the form
;;;
;;; ((label selector action) ... )
;;;
;;; where there is one entry for each menu item.
(define (make-vertical-menu init-list item-list)
  (let ((a-menu (eval `(make-instance vertical-menu
                                      ,@init-list))))
    (send a-menu init item-list)
    a-menu))

;;; ------------------------------------------------------------
;;; METHOD FOR CLASS VERTICAL MENU

;;; This is the format-specific intializer required of any class
;;; built on basic-menu.  For each item entry in the item table
;;; of a menu, it completes the entry by filling- in the fields
;;; which hold computed values.
(define-method (vertical-menu format-specific-init) ()
  (let* ((offset 0)
         (label-widths '())
         (complete-an-entry
           (lambda (index)
             (let* ((item (vector-ref item-table index))
                    (width (string-length
                             (send item get-label))))
               (send item set-label-row offset)
               (send item set-label-col 0)
               (set! label-widths (cons width label-widths))
               (set! offset (add1 offset))))))
  (do ((index 0 (add1 index)))
      ((>= index items))
    (complete-an-entry index))
  (set! w-rows items)
  (set! w-cols (apply max label-widths))))

;;; -------------------------------------------------------------
;;; POSITIONING FUNCTIONS FOR POPUP WINDOWS
;;; -------------------------------------------------------------
;;; VERTICAL POSITIONING

;;; Perform the specified vertical justification on the
;;; specified window.  Used for effect; returns nothing useful.
(define (v-justify to-where window)
  ;; Return a screen row so that if the window designated by the
  ;; second argument were so placed, it would be vertically
  ;; positioned on the screen as specified by the first argument,
  ;; which must be one of the symbols TOP, CENTER, or BOTTOM,
  ;; where TOP and BOTTOM indicate flush-to-top and flush-to-
  ;; bottom, respectively.
  (define (top-row to-where window)
    (let ((border? (send window get-border?))
          (tmp (- 24 (send window get-w-rows))))
          ;; the definition of tmp assumes that the working area
          ;; of the screen has 24 rows.
      (case to-where
        (TOP
         (if border?
           1
           0))
        (CENTER
         (quotient tmp 2))
        (BOTTOM
          (if border?
            (- tmp 1)
            tmp)))))
  (send window set-w-top (top-row to-where window)))

;;; -------------------------------------------------------------
;;; HORIZONTAL POSITIONING

;;; Perform the specified horizontal justification on the
;;; specified window.  Used for effect; returns nothing useful.
(define (h-justify to-where window)
  ;; Return a screen column so that if the window designated by
  ;; the second argument were so placed, it would be horizontally
  ;; positioned on the screen as specified by the first argument,
  ;; which must be one of the symbols LEFT, CENTER, or RIGHT,
  ;; where LEFT and RIGHT indicate flush-left and flush-right,
  ;; respectively.
  (define (left-col to-where window)
    (let ((border? (send window get-border?))
          (tmp (- 80 (send window get-w-cols))))
          ;; the definition of tmp assumes that the working area
          ;; of the screen has 80 columns.
      (case to-where
        (LEFT
         (if border?
           1
           0))
        (CENTER
         (quotient tmp 2))
        (RIGHT
          (if border?
            (- tmp 1)
            tmp)))))
  (send window set-w-left (left-col to-where window)))

;;; ------------------------------------------------------------
;;; MAKE AN ITEM-LIST FOR A MENU FROM A LIST OF STRINGS
;;; ------------------------------------------------------------

;;; This procedure will help the programmer build a menu from a
;;; list of strings.  The resulting menu will have the follow-
;;; ing properties: 1) each string in the list appears in the
;;; menu along with a selector character which is automatically
;;; assigned, and 2) a specifed action will be applied to any
;;; of the strings when it is selected from the menu by the
;;; user.
;;;
;;; The first argument `strings' is a list of strings.  The
;;; second argument `action' is a procedure taking one argu-
;;; ment, a string on which it will act.
;;;
;;; The procedure returns a list where each element is a menu
;;; item descriptor of the form
;;;
;;; ("<u-chr> <string>" #\<l-chr> action-thunk)
;;;
;;; and where <u-chr> is the uppercase form and <l-chr> is the
;;; lowercase form of a letter of the alphabet and <string> is
;;; one the strings in the `strings' list.
(define (strings->items strings action)
  (define nn 96) ; one less than the ASCII value of `a'
  (define (make-item string)
    (set! nn (1+ nn)) ; the ASCII value of <l-chr>
    (list
      ;; The menu item label: "<l-chr> <string>".
      (string-append
        (list->string (list (integer->char nn) #\space))
        string)
      ;; The menu item selector character, #\<l-chr>
      (integer->char nn)
      ;; The menu item action thunk.
      (lambda () (action string) 'USER-ABORT)))
  (map make-item strings))

;;; ------------------------------------------------------------
;;; MAKE A MENU FROM THE LIST RETURN BY A DOS-DIR CALL
;;; ------------------------------------------------------------

;;; This procedure returns a menu built from the list returned
;;; by the call (dos-dir wild-card), providing the returned list
;;; contains between one and `max-vertical' elements.  Other-
;;; wise, a range error message is displayed in the status line
;;; and the procedure returns #f.  The menu will have the
;;; following properties: 1) it will be created using the menu
;;; init-list passed via the argument `init-list', 2) each label
;;; appearing in the menu will show one file-spec matching the
;;; `wild-card' along with an automatically assigned selector
;;; character, and 3) `action', a procedure of one argument,
;;; will be applied to the file corresponding to a menu item
;;; when the item is selected by the user.  See the procedure
;;; `strings->items', which does most of the work, for more
;;; details.
(define (files->menu wild-card max-vertical action init-list)
  (define range-error
    "Can't make menu -- no such files or too many")
  (define files (dos-dir wild-card))
  (if (and files (<= (length files) max-vertical))
    (make-vertical-menu init-list
                        (strings->items files action))
    (begin
      (window-clear pcs-status-window)
      (display range-error pcs-status-window)
      #f)))

;;; ------------------------------------------------------------