home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / MENUSPCS.ZIP / MENDOS.S < prev    next >
Encoding:
Text File  |  1987-12-14  |  9.0 KB  |  249 lines
  1. ;;; ------------------------------------------------------------
  2. ;;; Menus for Scheme (tm)
  3. ;;; AN EXPERIMENTAL MENU-DRIVEN USER INTERFACE FOR PC SCHEME
  4. ;;; DOS MENU
  5. ;;; $Revision:   1.0  $   $Date:   14 Dec 1987  0:38:12  $
  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 -- DOS Menu")
  21. (writeln "Copyright (c) 1987 by Morton Goldberg")
  22. (let ((rev-number "$Revision:   1.0  $"))
  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. ;;; DOS COMMAND WITH FILE SPECIFICATION ARGUMENTS
  32.  
  33. ;;; Activate the file specification popup query window once for
  34. ;;; each file argument needed, test the file argument(s), and if
  35. ;;; OK, call the `cmd' argument, a `dos-...' procedure (e.g.,
  36. ;;; `dos-delete'), with the string(s) typed-in by the user.  The
  37. ;;; procedure can be called with either three or five arguments,
  38. ;;; depending on whether the `dos-...' procedure takes one or
  39. ;;; two arguments:
  40. ;;; 
  41. ;;; (cmd-with-file-args cmd test-1 text-1)
  42. ;;; 
  43. ;;; (cmd-with-file-args cmd test-1 text-1 test-2 text-2)
  44. ;;; 
  45. ;;; The `test-' arguments should be one of the symbols NEW-FILE,
  46. ;;; OLD-FILE, or NO-TEST and the `text-' arguments are strings
  47. ;;; to be displayed in the query windows.  The procedure returns
  48. ;;; whatever `cmd' returns.
  49. (define (cmd-with-file-args cmd test-1 text-1 . file-2-args)
  50.   (define (file-test test file-spec)
  51.     (case test
  52.       (OLD-FILE
  53.        (if (not (file-exists? file-spec))
  54.          (begin
  55.            (window-clear pcs-status-window)
  56.            (display "No such file" pcs-status-window)
  57.            #f)
  58.          #t))
  59.       (NEW-FILE
  60.        (if (file-exists? file-spec)
  61.          (begin
  62.            (window-clear pcs-status-window)
  63.            (display "File already exists" pcs-status-window)
  64.            #f)
  65.          #t))
  66.       (else
  67.        #t)))
  68.   (let ((spec-1 (get-response-to-query text-1)))
  69.     (if (and spec-1 (file-test test-1 spec-1))
  70.       (if file-2-args
  71.         (let* ((test-2 (car file-2-args))
  72.                (text-2 (cadr file-2-args))
  73.                (spec-2 (get-response-to-query text-2)))
  74.           (if (and spec-2 (file-test test-2 spec-2))
  75.             (cmd spec-1 spec-2)))
  76.         (cmd spec-1)))))
  77.  
  78. ;;; ------------------------------------------------------------
  79. ;;; (dos-dir ?) CHOICE
  80.  
  81. ;;; Chop a list in equal length sublists (except maybe for the
  82. ;;; last sublist).  This is a non-destructive function.  It
  83. ;;; returns a list comprised of the sublists.
  84. (define (chop-list the-list sublist-length)
  85.   (define (copy-n the-list sublist-length)
  86.     (if (and the-list (> sublist-length 0))
  87.       (cons (car the-list)
  88.             (copy-n (cdr the-list) (sub1 sublist-length)))
  89.       ()))
  90.   (and
  91.     (positive? sublist-length)
  92.     (if the-list
  93.       (cons (copy-n the-list sublist-length)
  94.             (chop-list (list-tail the-list sublist-length)
  95.                        sublist-length))
  96.       '())))
  97.  
  98. ;;; Make a table from a list of lists.  Returns a vector of
  99. ;;; strings representing a table where the strings represent one
  100. ;;; row of table data.
  101. ;;; 
  102. ;;; height is the length of vector; i.e., the number of rows in
  103. ;;; the table.
  104. ;;; 
  105. ;;; width is the length of the row strings.
  106. ;;; 
  107. ;;; tabs is a list of the form: (tab-1 tab-2 ... ) where tab-j
  108. ;;; is such that (string-ref row-i tab-j) returns the first
  109. ;;; character in the j-th data column of the i-th table row.
  110. ;;; 
  111. ;;; data is a list of the form (col-1 col-2 ... ) where col-j is
  112. ;;; a list comprised of the strings which will form the j-th
  113. ;;; column of the table.
  114. (define (make-table height width tabs data)
  115.   (define (first-str list-of-strings)
  116.     (if list-of-strings
  117.       (car list-of-strings)
  118.       ""))
  119.   (let ((table (make-vector height))
  120.         (cols (min (length tabs) (length data))))
  121.     ;; Do loop for the rows.
  122.     (do ((ii 0 (add1 ii))
  123.          (dd data (map cdr dd)))
  124.         ((>= ii height) table)
  125.       (let ((row-strings (map first-str dd)))
  126.         (set! (vector-ref table ii) (make-string width #\space))
  127.         ;; Do loop for the columns.
  128.         (do ((jj 0 (add1 jj))
  129.              (tt tabs (cdr tt))
  130.              (rr row-strings (cdr rr)))
  131.             ((>= jj cols))
  132.           (let ((item (car rr))
  133.                 (pos (car tt)))
  134.             (substring-move-left! item
  135.                                   0
  136.                                   (string-length item)
  137.                                   (vector-ref table ii)
  138.                                   pos)))))))
  139.  
  140. ;;; This is the init-list for the *files-display-rpt* popup text
  141. ;;; window.
  142. (define *files-rpt-init*
  143.   `('w-top 1
  144.     'w-left 1
  145.     'n-attr ,*popup-norm*
  146.     'border? #t))
  147.  
  148. ;;; Create the popup text window which will display the file
  149. ;;; name strings returned by `dos-dir'.
  150. (define *files-rpt*
  151.   (make-popup-text-window *files-rpt-init* '#(" ")))
  152.  
  153. (define (dos-dir-cmd)
  154.   (define range-error
  155.     "Can't show files -- no such files or too many")
  156.   (define tabs '(0 15 30 45 60))
  157.   (define items (cmd-with-file-args dos-dir
  158.                                     'NO-TEST
  159.                                     (vector *wild-spec-msg* "")))
  160.   (if (and items (<= (length items) (* 5 22)))
  161.     (let* ((item-cols (chop-list items 22))
  162.            (dir-table (make-table 22
  163.                                   (- (* 15 (length item-cols)) 3)
  164.                                   tabs
  165.                                   item-cols)))
  166.       (send *files-rpt* set-text dir-table)
  167.       (window-clear pcs-status-window)
  168.       (display "Press [Esc] to Proceed" pcs-status-window)
  169.       (send *files-rpt* popup)
  170.       (window-clear pcs-status-window))
  171.     (begin
  172.       (window-clear pcs-status-window)
  173.       (display range-error pcs-status-window))))
  174.  
  175. ;;; ------------------------------------------------------------
  176. ;;; (dos-chdir ?) CHOICE
  177.  
  178. ;;; Activate the directory path popup query window.  Call
  179. ;;; #<procedure dos-chdir> with the string typed-in by the user.
  180. (define (dos-cd-cmd)
  181.   (cmd-with-file-args dos-chdir
  182.                       'NO-TEST
  183.                       (vector *file-path-msg* "")))
  184.  
  185. ;;; ------------------------------------------------------------
  186. ;;; (dos-file-copy ? ?) CHOICE
  187.  
  188. (define (dos-copy-cmd)
  189.   (cmd-with-file-args dos-file-copy
  190.                       'OLD-FILE
  191.                       (vector *file-spec-msg* "Copy: ")
  192.                       'NO-TEST
  193.                       (vector *file-spec-msg* "To: ")))
  194.  
  195. ;;; ------------------------------------------------------------
  196. ;;; (dos-delete ?) CHOICE
  197.  
  198. (define (dos-del-cmd)
  199.   (cmd-with-file-args dos-delete
  200.                       'OLD-FILE
  201.                       (vector *file-spec-msg* "Delete: ")))
  202.  
  203. ;;; ------------------------------------------------------------
  204. ;;; (dos-rename ? ?) CHOICE
  205.  
  206. (define (dos-ren-cmd)
  207.   (cmd-with-file-args dos-rename
  208.                       'OLD-FILE
  209.                       (vector *file-spec-msg* "Rename: ")
  210.                       'NEW-FILE
  211.                       (vector *file-spec-msg* "To: ")))
  212.  
  213. ;;; ------------------------------------------------------------
  214. ;;; (dos-call ? 16384) CHOICE
  215.  
  216. ;;; Query for a DOS command.  Call DOS with the string typed-in
  217. ;;; by the user.
  218. (define (any-dos-cmd)
  219.   (let ((cmd (get-response-to-query
  220.                 (vector "Enter any DOS Command" ""))))
  221.     (if cmd
  222.       (dos-call "" cmd 16384))))
  223.  
  224. ;;; ------------------------------------------------------------
  225.  
  226. ;;; This is the item list for the DOS menu.
  227. (define *dos-menu-items*
  228.   `(("a (dos-dir ?)" #\a ,dos-dir-cmd)
  229.     ("b (dos-chdir ?)" #\b ,dos-cd-cmd)
  230.     ("c (dos-file-copy ? ?)" #\c ,dos-copy-cmd)
  231.     ("d (dos-delete ?)" #\d ,dos-del-cmd)
  232.     ("e (dos-rename ? ?)" #\e ,dos-ren-cmd)
  233.     ("f (dos-call ? 16384)" #\f ,any-dos-cmd)))
  234.  
  235. ;;; Create the dos menu, which is a vertical menu.
  236. (define *dos-menu*
  237.   (let ((menu (make-vertical-menu *vertical-menu-init*
  238.                                   *dos-menu-items*)))
  239.     (h-justify 'CENTER menu)
  240.     (v-justify 'TOP menu)
  241.     menu))
  242.  
  243. ;;; Link to the top-level menu.
  244. (define (dos-menu)
  245.   (send *dos-menu* popup)
  246.   *the-non-printing-object*)
  247.  
  248. ;;; ------------------------------------------------------------
  249.