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

Text File | 1987-12-14 | 13.0 KB | 372 lines

;;; --------------------------------------------------------
;;; Menus for Scheme (tm)
;;; EXAMPLES
;;; $Revision:   1.2  $    $Date:   14 Dec 1987  0:43:50  $
;;; --------------------------------------------------------
;;; 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.  You
;;; may also distribute unmodified copies of this text as
;;; shareware.  All other rights reserved.
;;; --------------------------------------------------------
;;; Implementation Language: Texas Instruments' PC SCHEME
;;; (Version 3.0)
;;; --------------------------------------------------------

(writeln "Menu Examples")
(writeln "Copyright (c) 1987 by Morton Goldberg")
(let ((rev-number "$Revision:   1.2  $"))
  ;; 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)))))

;;; If you have a color monitor and would like to see the
;;; examples displayed in color, replace FALSE with TRUE in
;;; the following statement.  If you have a monochrome
;;; monitor, let it be.
(define *rgb-monitor* #f)

;;; --------------------------------------------------------
;;; COLOR ATTRIBUTES FOR TEXT WINDOWS
;;; --------------------------------------------------------

;;; The environment *text-colors* provides a name space from
;;; which commonly used text window color combinations can
;;; be extracted.
;;;
(define *text-colors*
  (make-environment
    ;; The following are the components of the color
    ;; combinations.  They are not intended to be extracted
    ;; from the environment.
    (define text-black   #x00)
    (define text-blue    #x01)
    (define text-green   #x02)
    (define text-cyan    #x03)
    (define text-red     #x04)
    (define text-magenta #x05)
    (define text-amber   #x06)
    (define text-white   #x07)
    (define bkgrnd-black   #x00)
    (define bkgrnd-blue    #x10)
    (define bkgrnd-green   #x20)
    (define bkgrnd-cyan    #x30)
    (define bkgrnd-red     #x40)
    (define bkgrnd-magenta #x50)
    (define bkgrnd-amber   #x60)
    (define bkgrnd-white   #x70)
    ;; The following are the color combinations available for
    ;; use.  They provide a full set of CGA low-intensity
    ;; colors against a white or black background plus the
    ;; respective reverse video colors.
    (define white-black   (+ text-white bkgrnd-black))
    (define white-blue    (+ text-white bkgrnd-blue))
    (define white-green   (+ text-white bkgrnd-green))
    (define white-cyan    (+ text-white bkgrnd-cyan))
    (define white-red     (+ text-white bkgrnd-red))
    (define white-magenta (+ text-white bkgrnd-magenta))
    (define white-amber   (+ text-white bkgrnd-amber))
    (define black-white   (+ text-black bkgrnd-white))
    (define blue-white    (+ text-blue bkgrnd-white))
    (define green-white   (+ text-green bkgrnd-white))
    (define cyan-white    (+ text-cyan bkgrnd-white))
    (define red-white     (+ text-red bkgrnd-white))
    (define magenta-white (+ text-magenta bkgrnd-white))
    (define amber-white   (+ text-amber bkgrnd-white))
    (define black-blue    (+ text-black bkgrnd-blue))
    (define black-green   (+ text-black bkgrnd-green))
    (define black-cyan    (+ text-black bkgrnd-cyan))
    (define black-red     (+ text-black bkgrnd-red))
    (define black-magenta (+ text-black bkgrnd-magenta))
    (define black-amber   (+ text-black bkgrnd-amber))
    (define blue-black    (+ text-blue bkgrnd-black))
    (define green-black   (+ text-green bkgrnd-black))
    (define cyan-black    (+ text-cyan bkgrnd-black))
    (define red-black     (+ text-red bkgrnd-black))
    (define magenta-black (+ text-magenta bkgrnd-black))
    (define amber-black   (+ text-amber bkgrnd-black))))

;;; --------------------------------------------------------
;;; EXAMPLE 1 -- THE "QUICK BROWN FOX" POPUP TEXT WINDOW
;;; --------------------------------------------------------
;;; This example creates a popup text window and moves it
;;; around on the screen.  The code provides procedures for
;;; performing vertical (top, center, and bottom) and
;;; horizontal (left, center, and right) justification of a
;;; popup text window.

;;; Procedure for demonstrating the "quick brown fox"
;;; example.  After typing (do-fox) to start the demo, you
;;; must type [Esc] five times to complete it.  The window
;;; will move to a new position each time [Esc] is typed,
;;; excepting the 5-th [Esc], which ends the demo.
;;;
(define (do-fox)
  (v-justify 'TOP fox-popup)
  (h-justify 'LEFT fox-popup)
  (send fox-popup popup)
  (v-justify 'TOP fox-popup)
  (h-justify 'RIGHT fox-popup)
  (send fox-popup popup)
  (v-justify 'BOTTOM fox-popup)
  (h-justify 'RIGHT fox-popup)
  (send fox-popup popup)
  (v-justify 'BOTTOM fox-popup)
  (h-justify 'LEFT fox-popup)
  (send fox-popup popup)
  (v-justify 'CENTER fox-popup)
  (h-justify 'CENTER fox-popup)
  (send fox-popup popup))

;;; This is the init-list for the "quick brown fox" popup
;;; text window; it determines the visual properties (screen
;;; position, colors, format) of the window.
;;;
(define *fox-data*
  (let ((attr1 (if *rgb-monitor*
                   (access black-green *text-colors*)
                   (access black-white *text-colors*))))
    `('w-top 1
      'w-left 1
      'n-attr ,attr1
      'border? #t)))

;;; This is text of the "quick brown fox" popup text window.
;;; It is supplied to the window as a vector of text
;;; strings, one string for each line of displayed text.
;;;
(define *fox-text*
  '#("The quick brown fox jumped"
     "over the lazy dog.  The quick"
     "brown fox jumped over the"
     "lazy dog."
     ""
     "Press [Esc] to Proceed"))

;;; Create the "quick brown fox" popup text window.
;;;
(define fox-popup
  (make-popup-text-window *fox-data* *fox-text*))

;;; --------------------------------------------------------
;;; EXAMPLE 2 -- A VERTICAL AND A HORIZONTAL MENU
;;; --------------------------------------------------------
;;; This example creates a horizontal menu and a vertical
;;; menu, both offering the same choices.  The menus invoke
;;; commonly used Scheme facilities such as the garbage
;;; collector.  To experiment with a menu, type (do-h) to
;;; get the horizontal menu or (do-v) to get the vertical
;;; one.

;;; Procedure for demonstrating the vertical menu.  This
;;; menu will appear with its 2-nd item highlighted.
;;;
(define (do-v)
  (send vertical set-item-index 2)
  (send vertical popup))

;;; Procedure for demonstrating the horizontal menu.
;;;
(define (do-h)
  (send horizontal popup))

;;; --------------------------------------------------------
;;; EXECUTE A DOS COMMAND
;;;
;;; The following code creates a two-line popup query window
;;; which prompts for a DOS command.  To activate the window,
;;; type (do-dos).  After the command is entered and [Enter]
;;; is pressed, the DOS command is executed and the window
;;; is erased.

;;; This is the init-list for the DOS-command popup query
;;; window; it determines the visual properties (screen
;;; position, colors, format) of the window.
;;;
(define *query-data*
  (let ((attr1 (if *rgb-monitor*
                   (access white-blue *text-colors*)
                   (access black-white *text-colors*)))
        (attr2 (if *rgb-monitor*
                   (access black-white *text-colors*)
                   (access white-black *text-colors*))))
    `('w-top 4
      'w-left 35
      'cursor-row 1
      'cursor-col 0
      'input-width 40
      'n-attr ,attr1
      'hl-attr ,attr2
      'border? #t)))

;;; This is the vector of text strings for the DOS-command
;;; popup query window.  Note that the 2-nd element is an
;;; empty string; it serves as a place holder for the
;;; type-in area.
;;;
(define *query-text*
  '#("Enter a DOS Command or Press [Esc] to Cancel" ""))

;;; Create the DOS-command popup query window.
;;;
(define dos-cmd
  (make-popup-query-window *query-data* *query-text*))

;;; Activate the DOS-command popup query window.  Call DOS
;;; with the string typed-in by the user.
;;;
(define (do-dos)
  (send dos-cmd popup)
  (let ((cmd (send dos-cmd get-response)))
    (if (> (string-length cmd) 0)
      (dos-call "" cmd 16384))))

;;; --------------------------------------------------------
;;; REPORT ON FREE SPACE
;;;
;;; The following code creates a two-line popup text window
;;; which shows the amount to free space remaining to Scheme
;;; at the time the window is exposed.  To activate the
;;; window type (do-freesp).  Press [ESC] to erase the
;;; window.

;;; This is the init-list for the report-free-space popup
;;; text window; it determines the visual properties (screen
;;; position, colors, format) of the window.
;;;
(define *freesp-data*
  (let ((attr1 (if *rgb-monitor*
                   (access white-blue *text-colors*)
                   (access black-white *text-colors*))))
    `('w-top 4
      'w-left 41
      'n-attr ,attr1
      'border? #t)))

;;; Create the report-free-space popup text window.
(define freesp-rpt
  (let ((dummy-text '#(" ")))
    (make-popup-text-window *freesp-data*
                            dummy-text)))

;;; Activate the report-free-space popup text window.
;;;
(define (do-freesp)
  (let ((line-1 (string-append "Free Space Remaining: "
                               (integer->string (freesp)
                                                10)))
        (line-2 "Press [Esc] to Proceed"))
    (send freesp-rpt set-text (vector line-1 line-2))
    (send freesp-rpt popup)))

;;; --------------------------------------------------------
;;; DO A COMPACTING GARBAGE COLLECTION
;;;
(define (do-gc)
  (gc #t))

;;; --------------------------------------------------------
;;; EXIT FROM THE MENU -- SAME A PRESSING ESC
;;;
(define (do-abort)
  'USER-ABORT)

;;; --------------------------------------------------------
;;; EXIT TO DOS
;;;
(define (do-exit)
  (exit))

;;; --------------------------------------------------------
;;; MENUS PROVIDING THE SERVICES DEFINED ABOVE

;;; This is the item-list for both menus; it determines the
;;; selections provided to the user by the menus.
;;;
(define *item-list*
  `(("Do a DOS command" (#\d #\D) ,do-dos)
    ("report Free space" (#\f #\F) ,do-freesp)
    ("Garbage collect" (#\g #\G) ,do-gc)
    ("Exit menu" (#\e #\E) ,do-abort)
    ("eXit to DOS" (#\x #\X) ,do-exit)))

;;; This is the init-list for the vertical form of the menu.
;;; It determines the visual properties (screen position,
;;; colors, format) of the menu.
;;;
(define *vertical-menu-data*
  (let ((attr1 (if *rgb-monitor*
                   (access white-blue *text-colors*)
                   (access black-white *text-colors*)))
        (attr2 (if *rgb-monitor*
                   (access white-red *text-colors*)
                   (access white-black *text-colors*))))
    `('w-top 1
      'w-left 1
      'n-attr ,attr1
      'hl-attr ,attr2
      'border? #t)))

;;; Create the vertical version of the menu.
;;;
(define vertical
  (make-vertical-menu *vertical-menu-data*
                      *item-list*))

;;; This is the init-list for the horizontal form of the
;;; menu.
;;;
(define *horizontal-menu-data*
  (let ((attr1 (if *rgb-monitor*
                   (access white-blue *text-colors*)
                   (access black-white *text-colors*)))
        (attr2 (if *rgb-monitor*
                   (access white-red *text-colors*)
                   (access white-black *text-colors*))))
    `('w-top 1
      'w-left 1
      'n-attr ,attr1
      'hl-attr ,attr2
      'border? #t
      'label-spacing 2)))

;;; Create the horizontal version of the menu.
;;;
(define horizontal
  (make-horizontal-menu *horizontal-menu-data*
                        *item-list*))

;;; --------------------------------------------------------
;;; Just for fun, here is a menu that runs all the examples
;;; in this file.
;;;
(define *examples*
  `(("Quick fox example" (#\q #\Q) ,do-fox)
    ("Horizontal menu example" (#\h #\H) ,do-h)
    ("Vertical menu example" (#\v #\V) ,do-v)
    ("Exit menu" (#\e #\E) ,do-abort)))

(define *demo-menu* '())

;;; This procedure constructs the demo menu the first time
;;; it is called, but only brings it back to the screen
;;; after the first time.  Because there is no reason for
;;; this menu to be different, *vertical-menu-data* is used
;;; for the init-list.
;;;
(define (menus)
  (if (null? *demo-menu*)
    (begin
      (set! *demo-menu*
            (make-vertical-menu *vertical-menu-data*
                                *examples*))
      (v-justify 'CENTER *demo-menu*)
      (h-justify 'CENTER *demo-menu*)))
  (send *demo-menu* popup))

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