home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / EDWIN / MESSAGES.S < prev    next >
Encoding:
Text File  |  1993-06-15  |  5.7 KB  |  178 lines
  1. ;;;
  2. ;;;    Copyright (c) 1985 Massachusetts Institute of Technology
  3. ;;;
  4. ;;;    This material was developed by the Scheme project at the
  5. ;;;    Massachusetts Institute of Technology, Department of
  6. ;;;    Electrical Engineering and Computer Science.  Permission to
  7. ;;;    copy this software, to redistribute it, and to use it for any
  8. ;;;    purpose is granted, subject to the following restrictions and
  9. ;;;    understandings.
  10. ;;;
  11. ;;;    1. Any copy made of this software must include this copyright
  12. ;;;    notice in full.
  13. ;;;
  14. ;;;    2. Users of this software agree to make their best efforts (a)
  15. ;;;    to return to the MIT Scheme project any improvements or
  16. ;;;    extensions that they make, so that these may be included in
  17. ;;;    future releases; and (b) to inform MIT of noteworthy uses of
  18. ;;;    this software.
  19. ;;;
  20. ;;;    3.  All materials developed as a consequence of the use of
  21. ;;;    this software shall duly acknowledge such use, in accordance
  22. ;;;    with the usual standards of acknowledging credit in academic
  23. ;;;    research.
  24. ;;;
  25. ;;;    4. MIT has made no warrantee or representation that the
  26. ;;;    operation of this software will be error-free, and MIT is
  27. ;;;    under no obligation to provide any services, by way of
  28. ;;;    maintenance, update, or otherwise.
  29. ;;;
  30. ;;;    5.  In conjunction with products arising from the use of this
  31. ;;;    material, there shall be no use of the name of the
  32. ;;;    Massachusetts Institute of Technology nor of any adaptation
  33. ;;;    thereof in any advertising, promotional, or sales literature
  34. ;;;    without prior written consent from MIT in each case.
  35. ;;;
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ;;;
  38. ;;;     Modified by Texas Instruments Inc 8/15/85
  39. ;;;
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41.  
  42. (define reset-typein-window
  43.   (lambda ()
  44.     (%clear-window typein-screen)))
  45.  
  46.  ;;; command-prompts
  47.  
  48. (define *command-prompt-string* #F)
  49.  
  50. (define *command-prompt-displayed?* #F)
  51.  
  52. (define *temporary-message-displayed?* #F)
  53.  
  54. (define *prompt-should-be-erased?* #F)
  55.  
  56. (define *t-msg* "")
  57.  
  58. (define reset-command-prompt!
  59.   (lambda ()
  60.     (set! *command-prompt-string* #F)
  61.     (set! *command-prompt-displayed?* #F)))
  62.  
  63. (define set-command-prompt!
  64.   (lambda (prompt)
  65.     (set! *command-prompt-string* prompt)))
  66.  
  67. (define set-echo-prompt!
  68.   (lambda (string)
  69.     (set! *command-prompt-string* #F)
  70.     (set! *command-prompt-displayed?* #F)
  71.     (set! *temporary-message-displayed?* #F)
  72.     (set! *prompt-should-be-erased?* #F)
  73.     (write-prompt! string)))
  74.  
  75. (define erase-echo-prompt!
  76.   (lambda ()
  77.     (set! *command-prompt-string* #F)
  78.     (set! *command-prompt-displayed?* #F)
  79.     (set! *temporary-message-displayed?* #F)
  80.     (set! *prompt-should-be-erased?* #F)
  81.     (clear-prompt!)))
  82.  
  83. (define update-typein-window!
  84.   (lambda ()
  85.     (cond (*command-prompt-string* 
  86.              (write-prompt! *command-prompt-string*)
  87.              (set! *command-prompt-string* #F)
  88.              (set! *command-prompt-displayed?* #T)
  89.              (set! *temporary-message-displayed?* #F)
  90.              (set! *prompt-should-be-erased?* #T))
  91.  
  92.           (*prompt-should-be-erased?*  
  93.              (set! *command-prompt-displayed?* #F)
  94.              (set! *temporary-message-displayed?* #F)
  95.              (set! *prompt-should-be-erased?* #F)
  96.              (clear-prompt!))
  97.    
  98.           (*temporary-message-displayed?* 
  99.              (set! *prompt-should-be-erased?* #T)
  100.              (set! *command-prompt-displayed?* #F)
  101.              (set! *temporary-message-displayed?* #F)))))
  102.  
  103. (define write-prompt!
  104.   (lambda (string)
  105.     (%clear-window typein-screen)
  106.     (write-string! typein-screen string 0 0)))
  107.  
  108. (define clear-prompt!
  109.   (lambda ()
  110.     (%clear-window typein-screen)))
  111.  
  112. (define temporary-message
  113.   (lambda (string)
  114.     (set! *t-msg* string)
  115.     (set-temp-message-status)
  116.     (write-prompt! string)))
  117.  
  118. (define set-temp-message-status
  119.   (lambda ()
  120.     (set! *command-prompt-string* #F)
  121.     (set! *command-prompt-displayed?* #F)
  122.     (set! *prompt-should-be-erased?* #F)
  123.     (set! *temporary-message-displayed?* #T)))
  124.  
  125. (define append-message
  126.   (lambda (string)
  127.     (set! *t-msg* (string-append *t-msg* string))
  128.     (temporary-message *t-msg*)))
  129.  
  130.  ;;; prompting
  131.  
  132. (define prompt-for-pathname
  133.   (lambda (prompt)
  134.     (temporary-message prompt)
  135.     (read-pathname-from-screen typein-screen)))
  136.  
  137. (define prompt-for-confirmation?
  138.   (lambda (prompt)
  139.     (define (loop)
  140.       (let ((char (char-upcase (editor-read-char typein-screen))))
  141.         (if (or (char=? #\Y char) (char=? #\N char))
  142.             (char=? #\Y char)
  143.             (loop))))
  144.     (temporary-message prompt)
  145.     (loop)))
  146.  
  147.  
  148. (define read-pathname-from-screen
  149.   (let ((input-buffer (make-string (ncols) #\space)))
  150.     (lambda (screen)
  151.       (define erase-move-back
  152.     (lambda (screen)
  153.       (let ((cursor-x (%reify-port screen screen:cursor-x))
  154.         (cursor-y (%reify-port screen screen:cursor-y))
  155.         (set-cursor-pos
  156.          (lambda (x y)
  157.            (%reify-port! screen screen:cursor-x x)
  158.            (%reify-port! screen screen:cursor-y y))))
  159.         (set-cursor-pos (-1+ cursor-x) cursor-y)
  160.         (princ #\space screen)
  161.         (set-cursor-pos (-1+ cursor-x) cursor-y))))
  162.  
  163.       (define (loop char ptr)
  164.     (cond ((char=? char #\return) (substring input-buffer 0 ptr))
  165.           ((char=? char #\Backspace)
  166.                (if (not (= ptr 0))
  167.                    (begin
  168.                      (erase-move-back screen)
  169.              (loop (editor-read-char screen) (-1+ ptr)))
  170.            (loop (editor-read-char screen) ptr)))
  171.               ((char-graphic? char)
  172.            (princ char screen)
  173.            (string-set! input-buffer ptr char)
  174.            (loop (editor-read-char screen) (1+ ptr)))
  175.               (else (loop (editor-read-char screen) ptr))))
  176.     (loop (editor-read-char screen) 0))))
  177.  
  178.