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

Text File | 1987-12-14 | 5.4 KB | 151 lines

;;; ------------------------------------------------------------
;;; Menus for Scheme (tm)
;;; AN EXPERIMENTAL MENU-DRIVEN USER INTERFACE FOR PC SCHEME
;;; TOP-LEVEL DRIVER FOR SYSTEMS WITH A MOUSE
;;; $Revision:   1.0  $   $Date:   14 Dec 1987  0:38:46  $
;;; ------------------------------------------------------------
;;; 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 "Menu-Driven User Interface -- For Systems With A Mouse")
(writeln "Copyright (c) 1987 by Morton Goldberg")
(let ((rev-number "$Revision:   1.0  $"))
  ;; 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)))))

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

;;; Console window colors
(define *console-colors* #x07) ; white text on black background

;;; Popup menu colors
(define *menu-norm* #x70) ; black text on white background
(define *menu-high* #x07) ; white text on black background

;;; Popup text and query colors
(define *popup-norm* #x70) ; black text on white background
(define *popup-high* #x07) ; white text on black background

;;; DOS directory and file paths.  IMPORTANT: When installing
;;; the menu-driven user interface, replace the following path
;;; and file specification strings with specifications
;;; appropriate to your computer's DOS directory structure:

;;; Remove *external-editor-spec* definition if not using
;;; external editor.
(define *external-editor-spec* "\\BIN\\EP.EXE")

(define *make-fsl-spec*
  (string-append pcs-sysdir "\\MAKE_FSL.EXE"))

(define *transcript-spec*
  (string-append pcs-sysdir "\\SESSION.PCS"))

;;; -------------------------------------------------------------
;;; VERTICAL MENU INIT LIST
;;; ------------------------------------------------------------
;;; This is the init-list for the vertical menus.
(define *vertical-menu-init*
  `('w-top 1
    'w-left 1
    'n-attr ,*menu-norm*
    'hl-attr ,*menu-high*
    'border? #t))

;;; ------------------------------------------------------------
;;; POPUP QUERY WINDOW
;;; ------------------------------------------------------------

;;; One of these strings appears on 1-st line of any query made
;;; by this application.
(define *file-spec-msg*
  "Enter a file specification -- no wild cards")
(define *wild-spec-msg*
  "Enter a file specification -- wild cards OK")
(define *file-path-msg*
  "Enter a directory path")

;;; This is the init-list for the popup query windows.
(define *query-window-init*
  `('w-top 1
    'w-left 1
    'cursor-row 1
    'cursor-col 0
    'input-width 40
    'n-attr ,*popup-norm*
    'hl-attr ,*popup-high*
    'border? #t))

;;; The following code creates a two-line popup query window.
(define *query-window*
  (let ((query (make-popup-query-window *query-window-init*
                                        '#(" " " "))))
    (h-justify 'CENTER query)
    (v-justify 'CENTER query)
    query))

;;; Prompt the user with `query-text', a vector consisting of
;;; two strings, and return the response if it is a non-empty
;;; string; otherwise, return '().
(define (get-response-to-query query-text)
  (send *query-window* set-text query-text)
  (send *query-window* popup)
  (let ((rspns (send *query-window* get-response)))
    (if (and (string? rspns) (> (string-length rspns) 0))
      rspns
      '())))

;;; ------------------------------------------------------------
;;; IMPLEMENT THE OTHER MOUSE MENU CHOICES
;;; ------------------------------------------------------------

;;; Clear screen.  More precisely, clear the console window.
(define (clr-console)
  (window-set-attribute! 'console
                         'text-attributes
                         *console-colors*)
  (window-clear 'console)
  *the-non-printing-object*)

;;; Debug on/off toggle.  If debug mode is off, turn it on;
;;; otherwise, turn it off.
(define debug-toggle
  (lambda ()
    (set! pcs-debug-mode (not pcs-debug-mode))
    (window-clear pcs-status-window)
    (display (string-append "Debug mode now "
                            (if pcs-debug-mode "ON" "OFF"))
             pcs-status-window)
    *the-non-printing-object*))

;;; Transcript on/off toggle.   If transcript recording is off,
;;; turn it on; otherwise, turn it off.
(define trnscrpt-toggle
  (let ((trnscrpt-on '()))
    (lambda ()
      (set! trnscrpt-on (not trnscrpt-on))
      (if trnscrpt-on
        (transcript-on *transcript-spec*)
        (transcript-off))
      (window-clear pcs-status-window)
      (display (string-append "Transcript now "
                              (if trnscrpt-on "ON" "OFF"))
               pcs-status-window)
      *the-non-printing-object*)))

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