home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / clisp / src / archive / clisp.faslsp.lha / screen.lsp < prev    next >
Lisp/Scheme  |  1996-07-23  |  14KB  |  440 lines
  1. (in-package "SCREEN" :use '("LISP"))
  2.  
  3. #|
  4. ; Re-Export von importierten Symbolen kann man nicht mit der
  5. ; P I S E R U I - Regel erreichen. Diese Symbole muß man zuerst importieren.
  6. (in-package "SYSTEM")
  7. (import '(make-window window-size
  8.           window-cursor-position set-window-cursor-position
  9.           clear-window clear-window-to-eot clear-window-to-eol
  10.           delete-window-line insert-window-line
  11.           highlight-on highlight-off window-cursor-on window-cursor-off
  12.          )
  13.         "SCREEN"
  14. )
  15. (in-package "SCREEN")
  16. |#
  17.  
  18. (export '(; exported functions and macros:
  19.           make-window window-size
  20.           window-cursor-position set-window-cursor-position
  21.           clear-window clear-window-to-eot clear-window-to-eol
  22.           delete-window-line insert-window-line
  23.           highlight-on highlight-off window-cursor-on window-cursor-off
  24.           with-window *window*
  25.           read-keyboard-char
  26.           ; user-settable things:
  27.           *new-window*
  28. )        )
  29.  
  30. (proclaim '(special *window*))
  31.  
  32. #-AMIGA
  33. (defun read-keyboard-char (stream)
  34.   (declare (ignore stream))
  35.   (read-char *keyboard-input*)
  36. )
  37.  
  38. #-AMIGA
  39. (defconstant *new-window* nil)
  40.  
  41.  
  42. ;;;; SCREEN-Package for Amiga
  43. ;;;; Jörg Höhle, 23.7.1996
  44.  
  45. #+AMIGA (use-package "CLOS")
  46. #+AMIGA
  47. (progn
  48.  
  49. ; Determines the "new window" policy.
  50. (defvar *new-window* "RAW:0/11/581/231/CLISP Window"
  51.   "This variables determines the behaviour of SCREEN:MAKE-WINDOW.
  52. If NIL, it uses *TERMINAL-IO*. If non-NIL, it should be the specification
  53. string of a special file to be OPENed, e.g. \"RAW:0/11/581/231/Window Title\"."
  54. )
  55.  
  56. ;;; Why is this so complex? Because applications (Punimax) need to use
  57. ;;; the raw mode functions but nevertheless expect to read input in
  58. ;;; cooked mode. Cooked mode is also nicer if you happen to fall into
  59. ;;; the debugger. Thus I provide special streams that switch modes
  60. ;;; automatically.
  61.  
  62.  
  63. ;; The class of all data present in SCREEN's generic streams.
  64. (defclass screen-controller (generic-stream-controller)
  65.   ((stream :reader controller-stream
  66.            :type stream
  67. ) ))
  68.  
  69. ; The screen's mode: either T (raw) or NIL (line editing enabled)
  70. (defgeneric controller-mode (controller))
  71. (defgeneric (setf controller-mode) (mode controller))
  72.  
  73.  
  74. ;; Two subclasses:
  75.  
  76. ; terminal-controller generic streams refer to *terminal-io*.
  77. (defclass terminal-controller (screen-controller)
  78.   ((stream :initform *terminal-io*) ; cache so that *terminal-io* can be rebound
  79.    ; The terminal's mode is cached in stream.d, no need to cache it here.
  80. ) )
  81.  
  82. ; window-controller generic streams refer to a special device stream.
  83. (defclass window-controller (screen-controller)
  84.   ((stream :initarg :stream)
  85.    (mode :accessor controller-mode
  86.          :initform 'unknown ; the initial mode is unknown
  87.   ))
  88. )
  89.  
  90.  
  91. ;; (raw-mode stream mode) puts the stream into the given mode (T or NIL)
  92. ;; and returns the old mode.
  93. (defun raw-mode (stream mode)
  94.   (if (generic-stream-p stream)
  95.     (generic-raw-mode (generic-stream-controller stream) mode)
  96.     ; handle low-level streams here
  97.     (sys::terminal-raw stream mode t)
  98. ) )
  99. (defgeneric generic-raw-mode (controller mode))
  100. (defmethod generic-raw-mode ((controller screen-controller) mode)
  101.   (raw-mode (controller-stream controller) mode)
  102. )
  103. (defmethod generic-raw-mode ((controller window-controller) mode)
  104.   (let ((old-mode (controller-mode controller)))
  105.     ; compare against the cached current mode
  106.     (if (eq mode old-mode)
  107.       old-mode
  108.       (prog1
  109.         (raw-mode (controller-stream controller) mode)
  110.         (setf (controller-mode controller) mode)
  111. ) ) ) )
  112.  
  113.  
  114. ;; Return a new window stream.
  115. (defun make-window (&optional (*new-window* *new-window*))
  116.   (let ((stream
  117.           (make-generic-stream
  118.             (if *new-window*
  119.               (make-instance 'window-controller
  120.                 :stream (etypecase *new-window*
  121.                           (STREAM *new-window*)
  122.                           ((OR PATHNAME STRING) (open *new-window* :direction :io))
  123.               )         )
  124.               (make-instance 'terminal-controller)
  125.        )) ) )
  126.     ; (raw-mode stream t) ; Don't need this because modes are switched automatically.
  127.     stream
  128. ) )
  129.  
  130.  
  131. ;; Operations on SCREEN streams.
  132.  
  133. (defmethod generic-stream-read-char ((controller screen-controller))
  134.   (generic-raw-mode controller nil) ;; want to switch to cooked mode
  135.   (read-char (controller-stream controller))
  136. )
  137.  
  138. (defmethod generic-stream-listen ((controller screen-controller))
  139.   (generic-raw-mode controller nil) ;; want to switch to cooked mode
  140.   (if (listen (controller-stream controller))
  141.     0 ; something available
  142.     +1 ; nothing available, not EOF
  143. ) )
  144.  
  145. (defmethod generic-stream-clear-input ((controller screen-controller))
  146.   (generic-raw-mode controller nil) ;; want to switch to cooked mode
  147.   (clear-input (controller-stream controller))
  148.   T
  149. )
  150.  
  151. (defmethod generic-stream-write-char ((controller screen-controller) ch)
  152.   (write-char ch (controller-stream controller))
  153. )
  154.  
  155. ;; for speed only
  156. (defmethod generic-stream-write-string ((controller screen-controller) string start len)
  157.   (write-string (substring string start (+ start len))
  158.                 (controller-stream controller)
  159. ) )
  160.  
  161. (defmethod generic-stream-finish-output ((controller screen-controller))
  162.   (finish-output (controller-stream controller))
  163. )
  164.  
  165. (defmethod generic-stream-force-output ((controller screen-controller))
  166.   (force-output (controller-stream controller))
  167. )
  168.  
  169. (defmethod generic-stream-clear-output ((controller screen-controller))
  170.   (clear-output (controller-stream controller))
  171. )
  172.  
  173. (defmethod generic-stream-close ((controller screen-controller))
  174.   (raw-mode (controller-stream controller) nil)
  175.   T
  176. )
  177. (defmethod generic-stream-close ((controller window-controller))
  178.   ; Don't need to call raw-mode on this window since it will go away anyway.
  179.   (close (controller-stream controller))
  180. )
  181.  
  182. ; Return a list of all characters immediately available on stream
  183. (defun stream-chars (stream)
  184.   (let ((res '()))
  185.     (loop
  186.       (let ((c (read-char-no-hang stream)))
  187.         (unless c (return))
  188.         (push c res)
  189.     ) )
  190.     (nreverse res)
  191. ) )
  192.  
  193. ; Parse an ANSI Control String:
  194. ; { #\CSI | #\ESC #\[ } { digits #\; }* [ digits [ #\; ] ] { rest }
  195. ; Return (rest . ... num2 num1)
  196. (defun parse-csi (string)
  197.   (let ((res '())
  198.         num
  199.         (start (cond ((eq (aref string 0) #\CSI)      1)
  200.                      ((and (eq (aref string 0) #\ESC)
  201.                            (> (length string) 1)
  202.                            (eq (aref string 1) #\[))  2)
  203.                      (t (error "Not a CSI sequence: ~S" string))
  204.        ))      )
  205.     (loop
  206.       (multiple-value-setq (num start) (parse-integer string :start start :junk-allowed t))
  207.       (when (null num) (return))
  208.       (push num res)
  209.       (when (and (< start (length string)) (eq (aref string start) #\;))
  210.         (incf start)                 ; skip ANSI separator
  211.     ) )
  212.     (cons (subseq string start) res) ; push rest
  213. ) )
  214.  
  215. ; Send a CSI sequence to the terminal and read the response, an ANSI sequence.
  216. ; Return a reversed list of numbers.
  217. ; (Note: As a side effect, a (clear-input stream) is done, which throws away
  218. ; characters.)
  219. (defun read-csi-response (stream send expected)
  220.   (clear-input stream)
  221.   (write-string send stream)
  222.   (let* ((chars
  223.            (or (stream-chars stream)
  224.                (error "Got no response from ~S." stream)
  225.          ) )
  226.          (response (parse-csi (coerce chars 'string))))
  227.     (unless (string= expected (first response))
  228.       (error 
  229.        #L{
  230.        DEUTSCH "Von ~S schlechte Antwort erhalten: ~S"
  231.        ENGLISH "Got bad response from ~S: ~S"
  232.        FRANCAIS "Mauvaise réponse par ~S : ~S"
  233.        }
  234.        stream chars
  235.     ) )
  236.     (cdr response)
  237. ) )
  238.  
  239. (defun window-size (stream)
  240.   "Reports window size.
  241. Will flush pending characters!"
  242.   ;; (window-checks stream)
  243.   (when (and (generic-stream-p stream)
  244.              (typep (generic-stream-controller stream) 'screen-controller))
  245.     (raw-mode stream t)
  246.     (setq stream (controller-stream (generic-stream-controller stream)))
  247.   )
  248.   (let ((response
  249.           (read-csi-response
  250.             stream
  251.             (load-time-value (coerce '(#\CSI #\0 #\Space #\q) 'string))
  252.             "r"               ; parse-integer ate the space
  253.        )) )
  254.     (let ((width (first response))
  255.           (height (second response)))
  256.       ; Decrement width to avoid problems with wrapping/scrolling of the last line.
  257.       (values height (- width 1))
  258. ) ) )
  259.  
  260. (defun window-cursor-position (stream)
  261.   "Reports cursor position, report origin as 0;0.
  262. Will flush pending characters!"
  263.   ;; (window-checks stream)
  264.   (when (and (generic-stream-p stream)
  265.              (typep (generic-stream-controller stream) 'screen-controller))
  266.     (raw-mode stream t)
  267.     (setq stream (controller-stream (generic-stream-controller stream)))
  268.   )
  269.   (let ((response
  270.           (read-csi-response
  271.             stream
  272.             (load-time-value (coerce '(#\CSI #\6 #\n) 'string))
  273.             "R"
  274.        )) )
  275.     (values (1- (second response)) (1- (first response))) ; line;column
  276. ) )
  277.  
  278. (defun set-window-cursor-position (stream line column)
  279.   ;; ANSI position origin is 1;1, but SCREEN uses 0;0
  280.   (format stream "~a~d;~dH" #\CSI (1+ line) (1+ column))
  281.   (values)
  282. )
  283.  
  284. (defun clear-window (stream)
  285.   (write-char '#\FF stream)
  286.   (values)
  287. )
  288.  
  289. (defun clear-window-to-eot (stream)
  290.   (write-string (load-time-value (coerce '(#\CSI #\J) 'string)) stream)
  291.   (values)
  292. )
  293.  
  294. (defun clear-window-to-eol (stream)
  295.   (write-string (load-time-value (coerce '(#\CSI #\K) 'string)) stream)
  296.   (values)
  297. )
  298.  
  299. (defun delete-window-line (stream)
  300.   (write-string (load-time-value (coerce '(#\CSI #\M) 'string)) stream)
  301.   (values)
  302. )
  303.  
  304. (defun insert-window-line (stream)
  305.   (write-string (load-time-value (coerce '(#\CSI #\L) 'string)) stream)
  306.   (values)
  307. )
  308.  
  309. (defun highlight-on (stream)
  310.   (write-string (load-time-value (coerce '(#\CSI #\1 #\m) 'string)) stream)
  311.   (values)
  312. )
  313.  
  314. (defun highlight-off (stream)
  315.   (write-string (load-time-value (coerce '(#\CSI #\m) 'string)) stream)
  316.   (values)
  317. )
  318.  
  319. (defun window-cursor-on (stream)
  320.   (write-string (load-time-value (coerce '(#\CSI #\Space #\p) 'string)) stream)
  321.   (values)
  322. )
  323.  
  324. (defun window-cursor-off (stream)
  325.   (write-string (load-time-value (coerce '(#\CSI #\0 #\Space #\p) 'string)) stream)
  326.   (values)
  327. )
  328.  
  329.  
  330. ;; This function does a simple mapping from CSI-sequences as reported
  331. ;; by the Amiga keyboard to characters with HYPER (even SUPER or CONTROL) bit
  332. ;; set. Furthermore, most codes between 1 and 26 get the CONTROL bit set.
  333. ;; key   codes  shift   character
  334. ;; f1    CSI0~  CSI10~  #\f1, #\s-f1
  335. ;; f10   CSI9~  CSI19~  #\f10, #\s-f10
  336. ;; Help  CSI?~  CSI?~   #\Help
  337. ;; Up    CSIA   CSIT    #\Up,    #\S-Up
  338. ;; Down  CSIB   CSIS    #\Down,  #\S-Down
  339. ;; Left  CSID   CSI A   #\Left,  #\S-Left
  340. ;; Right CSIC   CSI @   #\Right, #\S-Right
  341. (defun read-keyboard-char (stream)
  342.   ; In order to minimize mode switches, switch once then read from low-level stream
  343.   (raw-mode stream t)
  344.   (when (generic-stream-p stream)
  345.     (setq stream (controller-stream (generic-stream-controller stream))))
  346.   (let ((c (read-char stream)))
  347.     (if (char= c '#\CSI)
  348.       (let ((chars '()) c)
  349.         (loop
  350.           (setq c (read-char stream))
  351.           (unless (char<= #\Space c #\?) (return))
  352.           (push c chars)
  353.         )
  354.         (cond ((char/= c '#\~) ; arrow keys
  355.                (or (cdr (assoc c (if chars
  356.                                    '((#\A . #\S-Left)
  357.                                      (#\@ . #\S-Right)
  358.                                     )
  359.                                    '((#\A . #\Up)
  360.                                      (#\B . #\Down)
  361.                                      (#\C . #\Right)
  362.                                      (#\D . #\Left)
  363.                                      (#\S . #\S-Down)
  364.                                      (#\T . #\S-Up)
  365.                                     )
  366.                    )    )        )
  367.                    '#\CSI
  368.               ))
  369.               ((null chars) '#\CSI) ; don't parse this...
  370.               ((eq (first chars) '#\?) '#\Help) ; Help key
  371.               ((not (digit-char-p (first chars))) '#\CSI) ; don't parse this...
  372.               ((null (rest chars)) ; f1 ... f10
  373.                (int-char (+ (char-int '#\f1) (digit-char-p (first chars))))
  374.               )
  375.               ((eq '#\1 (second chars)) ; F1 ... F10
  376.                (int-char (+ (char-int '#\s-f1) (digit-char-p (first chars))))
  377.               )
  378.               (t '#\CSI) ; don't parse this...
  379.       ) )
  380.       (if (and (<= 1 (char-int c) 26) ; Ctrl-A ... Ctrl-Z
  381.                (not (or (eql c #\Newline) (eql c #\Backspace) (eql c #\Tab)
  382.                         (eql c #\Return)
  383.           )    )    )
  384.         (set-char-bit (int-char (+ 64 (char-int c))) :CONTROL t)
  385.         c
  386. ) ) ) )
  387.  
  388.  
  389. ;; Support for WITH-KEYBOARD and *KEYBOARD-INPUT*
  390.  
  391. ;; The mode is switched to raw when the stream is created and switched back
  392. ;; when the stream is closed.
  393.  
  394. (defclass keyboard-controller (terminal-controller)
  395.   ((orig-mode :initform (raw-mode *terminal-io* t))
  396.    ; *terminal-io* is cached by terminal-controller
  397. ) )
  398.  
  399. (defmethod generic-stream-read-char ((controller keyboard-controller))
  400.   ; make some cursor and function keys mappings, see above
  401.   (read-keyboard-char (controller-stream controller))
  402. )
  403.  
  404. (defmethod generic-stream-listen ((controller screen-controller))
  405.   (generic-raw-mode controller t) ;; need to switch to raw mode
  406.   (if (listen (controller-stream controller))
  407.     0 ; something available
  408.     +1 ; nothing available, not EOF
  409. ) )
  410.  
  411. (defmethod generic-stream-clear-input ((controller screen-controller))
  412.   (generic-raw-mode controller t) ;; need to switch to raw mode
  413.   (clear-input (controller-stream controller))
  414.   T
  415. )
  416.  
  417. (defmethod generic-stream-close ((controller keyboard-controller))
  418.   (with-slots (stream orig-mode) controller
  419.     (raw-mode stream orig-mode)
  420. ) )
  421.  
  422. ; refine WITH-KEYBOARD expansion from USER1.LSP
  423. (defun system::do-with-keyboard (fn)
  424.   (let ((*keyboard-input* (make-generic-stream
  425.                            (make-instance 'keyboard-controller))))
  426.     (unwind-protect
  427.       (funcall fn)
  428.       (close *keyboard-input*)
  429. ) ) )
  430.  
  431. ) ; #+AMIGA
  432.  
  433.  
  434. (defmacro with-window (&body body)
  435.   `(LET ((*WINDOW* (MAKE-WINDOW)))
  436.      (UNWIND-PROTECT (PROGN ,@body) (CLOSE *WINDOW*))
  437.    )
  438. )
  439.  
  440.