home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / MENUSPCS.ZIP / MENKEY.S < prev    next >
Encoding:
Text File  |  1987-12-26  |  4.2 KB  |  119 lines
  1. ;;; ------------------------------------------------------------
  2. ;;; Menus for Scheme (tm)
  3. ;;; AN EXPERIMENTAL MENU-DRIVEN USER INTERFACE FOR PC SCHEME
  4. ;;; TOP-LEVEL DRIVER FOR SYSTEMS WITHOUT A MOUSE
  5. ;;; $Revision:   1.1  $   $Date:   26 Dec 1987 21:29:28  $
  6. ;;; ------------------------------------------------------------
  7. ;;; Copyright (c) 1987 by Morton Goldberg.  
  8. ;;;
  9. ;;; Permission is granted to make copies of this program text
  10. ;;; for personal, non-commercial use provided this notice of
  11. ;;; copyright appears in all copies and derived works.  All
  12. ;;; other rights reserved.  In particular, you may not publish
  13. ;;; or otherwise distribute any copies of this text or any
  14. ;;; derived works without permission from the copyright holder.
  15. ;;; ------------------------------------------------------------
  16. ;;; Implementation Language: Texas Instruments' PC Scheme
  17. ;;; (Version 3.0)
  18. ;;; ------------------------------------------------------------
  19.  
  20. (writeln "Menu-Driven User Interface -- For Systems Without A Mouse")
  21. (writeln "Copyright (c) 1987 by Morton Goldberg")
  22. (let ((rev-number "$Revision:   1.1  $"))
  23.   ;; Write the revision number string without the leading
  24.   ;; and trailing dollar-signs (which are needed by the
  25.   ;; version control system).
  26.   (writeln (substring rev-number
  27.                       1
  28.                       (sub1 (string-length rev-number)))))
  29.  
  30. ;;; ------------------------------------------------------------
  31.  
  32. ;;; popup menu colors
  33. (define *menu-norm* #x70) ; black text on white background
  34. (define *menu-high* #x07) ; white text on black background
  35.  
  36. ;;; popup text and query colors
  37. (define *popup-norm* #x70) ; black text on white background
  38. (define *popup-high* #x07) ; white text on black background
  39.  
  40. ;;; DOS directory and file paths.  IMPORTANT: When installing
  41. ;;; the menu-driven user interface, replace the following path
  42. ;;; and file specification strings with specifications
  43. ;;; appropriate to your computer's DOS directory structure:
  44.  
  45. ;;; Remove *external-editor-spec* definition if not using
  46. ;;; external editor.
  47. (define *external-editor-spec* "\\BIN\\EP.EXE")
  48.  
  49. (define *make-fsl-spec*
  50.   (string-append pcs-sysdir "\\MAKE_FSL.EXE"))
  51.  
  52. ;;; -------------------------------------------------------------
  53. ;;; VERTICAL MENU INIT LIST
  54. ;;; ------------------------------------------------------------
  55. ;;; This is the init-list for the vertical menus.
  56. (define *vertical-menu-init*
  57.   `('w-top 1
  58.     'w-left 1
  59.     'n-attr ,*menu-norm*
  60.     'hl-attr ,*menu-high*
  61.     'border? #t))
  62.  
  63. ;;; ------------------------------------------------------------
  64. ;;; POPUP QUERY WINDOW
  65. ;;; ------------------------------------------------------------
  66.  
  67. ;;; One of these strings appears on 1-st line of any query made
  68. ;;; by this application.
  69. (define *file-spec-msg*
  70.   "Enter a file specification -- no wild cards")
  71. (define *wild-spec-msg*
  72.   "Enter a file specification -- wild cards OK")
  73. (define *file-path-msg*
  74.   "Enter a directory path")
  75.  
  76. ;;; This is the init-list for the popup query windows.
  77. (define *query-window-init*
  78.   `('w-top 1
  79.     'w-left 1
  80.     'cursor-row 1
  81.     'cursor-col 0
  82.     'input-width 40
  83.     'n-attr ,*popup-norm*
  84.     'hl-attr ,*popup-high*
  85.     'border? #t))
  86.  
  87. ;;; The following code creates a two-line popup query window.
  88. (define *query-window*
  89.   (let ((query (make-popup-query-window *query-window-init*
  90.                                         '#(" " " "))))
  91.     (h-justify 'CENTER query)
  92.     (v-justify 'CENTER query)
  93.     query))
  94.  
  95. ;;; Prompt the user with `query-text', a vector consisting of
  96. ;;; two strings, and return the response if it is a non-empty
  97. ;;; string; otherwise, return '().
  98. (define (get-response-to-query query-text)
  99.   (send *query-window* set-text query-text)
  100.   (send *query-window* popup)
  101.   (let ((rspns (send *query-window* get-response)))
  102.     (if (and (string? rspns) (> (string-length rspns) 0))
  103.       rspns
  104.       '())))
  105.  
  106. ;;; ------------------------------------------------------------
  107. ;;; SHORT, EASY-TO-REMEMBER (?) ALIASES FOR MENU PROCEDURES
  108. ;;; ------------------------------------------------------------
  109.  
  110. (alias mco compile-menu)
  111.  
  112. (alias mdos dos-menu)
  113.  
  114. (alias mld load-menu)
  115.  
  116. (alias med edit-menu)
  117.  
  118. ;;; ------------------------------------------------------------
  119.