/[cl-screen]/cl-screen/cl-screen-stream.lisp
ViewVC logotype

Contents of /cl-screen/cl-screen-stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Tue May 15 21:53:01 2007 UTC (6 years, 11 months ago) by jconnors
Branch: MAIN
CVS Tags: HEAD
Changes since 1.2: +1 -1 lines
Committing for version 0.9.
1
2 (in-package :cl-screen)
3
4 ;;
5 ;; Stream used to write to a slang screen. If you don't provide a
6 ;; screen on initialization, it will create one. Uses
7 ;; trivial-gray-streams
8 ;;
9 (defclass cl-screen-stream
10 (fundamental-character-output-stream
11 trivial-gray-stream-mixin)
12 ((screen :initform nil
13 :initarg :screen
14 :accessor screen-of
15 :documentation "Screen that this stream interacts with" )
16 (background-color
17 :initform 'black
18 :accessor background-color-of
19 :documentation "Foreground colour currently being used for characters writen to the stream")
20 (foreground-color
21 :initform 'white
22 :accessor foreground-color-of
23 :documentation "Foreground colour currently being used for chararcters written to the stream")
24 (current-char
25 :type character
26 :initform nil
27 :accessor current-char-of
28 :documentation "Char currently read from this stream")
29 (previous-char
30 :type character
31 :initform nil
32 :accessor previous-char-of
33 :documentation "Char previously read from this stream")))
34
35
36 ;;
37 ;; Standard methods used to initialise a stream
38 ;;
39
40 (defmethod initialize-instance :after ((s cl-screen-stream) &rest args)
41 (declare (ignore args))
42 (when (null (screen-of s))
43 (setf (screen-of s) (make-instance 'tty-screen))
44 (initialize-screen (screen-of s))))
45
46 (defmethod stream-read-char ((s cl-screen-stream))
47 (let ((result (slang-getkey)))
48 (setf (previous-char-of s) (current-char-of s))
49 (setf (current-char-of s) result)))
50
51 (defmethod stream-unread-char ((s cl-screen-stream) (c character))
52 (slang-unget-key c)
53 (setf (current-char-of s) c))
54
55 (defmethod stream-read-char-no-hang ((s cl-screen-stream))
56 (when (> (slang-input-pending 0) 0)
57 (stream-read-char s)))
58
59 (defmethod stream-clear-input ((s cl-screen-stream))
60 (slang-flush-input))
61
62 (defmethod stream-write-char ((s cl-screen-stream) (c character))
63 (set-color (screen-of s) (foreground-color-of s) (background-color-of s))
64 (slsmg-write-char (char-code c)))
65
66 (defmethod stream-line-column ((s cl-screen-stream))
67 (slsmg-get-column))
68
69 (defmethod stream-start-line-p ((s cl-screen-stream))
70 (= 0 (slsmg-get-column)))
71
72 (defmethod stream-terpri ((s cl-screen-stream))
73 (slsmg-gotorc (1+ (slsmg-get-row)) 0))
74
75 (defmethod stream-advance-to-column ((s cl-screen-stream) column)
76 (slsmg-gotorc (slsmg-get-row) column))
77
78 (defmethod stream-clear-output ((s cl-screen-stream))
79 (clear-screen (screen-of s)))
80
81 (defmethod stream-finish-output ((s cl-screen-stream))
82 (finish-screen (screen-of s)))
83
84 (defmethod stream-force-output ((s cl-screen-stream))
85 (finish-screen (screen-of s)))
86
87 (defmethod close ((s cl-screen-stream) &key abort)
88 (declare (ignore abort))
89 (release-screen (screen-of s))
90 (setf (screen-of s) nil))
91
92 (defmethod open-stream-p ((s cl-screen-stream))
93 (not (null (screen-of s))))
94

  ViewVC Help
Powered by ViewVC 1.1.5