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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Wed May 23 20:55:17 2007 UTC (6 years, 10 months ago) by jconnors
Branch: MAIN
CVS Tags: HEAD
Changes since 1.3: +1 -0 lines
Tidy-ups: changing name of example game, ignoring var that produced error
1
2 ;;
3 ;; A stream that writes to a window on a cl-screen stream, and has a
4 ;; scrollback / history buffer, as well as colour attributes. No cursor
5 ;; positioning within the window is allowed other than setting the column.
6 ;;
7
8 (in-package :cl-screen)
9
10 ;;
11 ;; A window has a sequence of logical lines which are lines of text
12 ;; written to the window via the stream the window retains a complete
13 ;; history.
14 ;;
15 (defclass history-line ()
16 ((line-cursor
17 :initform 0
18 :accessor cursor-of
19 :documentation "The position the next character will be printed at in this line")
20 (line-width
21 :initarg :width
22 :reader width-of)
23 (line-text
24 :initform nil
25 :accessor text-of
26 :documentation "A line of text in a window history"))
27 (:documentation "An entry in a history buffer of text lines sent to a window"))
28
29 (defmethod initialize-instance :after ((self history-line) &rest args)
30 (declare (ignore args))
31 (setf (text-of self)
32 (make-array (width-of self) :element-type 'character :adjustable nil :initial-element #\Space)))
33
34 (defgeneric add-space-to-history-line (line))
35
36 (defgeneric add-char-to-history-line (line chr))
37
38 (defgeneric remove-char-from-history-line (line))
39
40 (defgeneric print-history-line-to-window (line window row))
41
42 (defmethod add-space-to-history-line ((line history-line))
43 "(add-space-to-history-line line)
44 Pad a logical line with a space on the end"
45 (when (< (cursor-of line) (length (text-of line)))
46 (setf (aref (text-of line) (cursor-of line)) #\Space)
47 (incf (cursor-of line))))
48
49 (defmethod add-char-to-history-line ((line history-line) chr)
50 "(add-char-to-history-line line chr column)
51 Add a character to a logical line, positioned at the given column index."
52 (assert (typep chr 'character))
53 ;; change final space to our emitted char
54 (when (< (cursor-of line) (length (text-of line)))
55 (setf (aref (text-of line) (cursor-of line)) chr)
56 (incf (cursor-of line))))
57
58 (defun trim-last-char (str)
59 (subseq str 0 (1- (length str))))
60
61 (defmethod remove-char-from-history-line ((line history-line))
62 "(remove-char-from-history-line chr column)
63 Remove the character from the line at column from history"
64 (when (not (zerop (length (text-of line))))
65 (setf (text-of line) (trim-last-char (text-of line)))
66 (decf (cursor-of line))))
67
68
69 (defmethod print-history-line-to-window ((line history-line)
70 (window cl-screen-window) row)
71 "(print-history-line-to-window history-line cl-screen-window)
72 Print max-length chars of a given logical line on a cl-screen window starting from the given column"
73 (position-window-cursor window 0 row)
74 (let ((line-length
75 (min (length (text-of line)) (width-of window))))
76 (flet ((nth-char-in-line (nth line)
77 (char (text-of line) nth)))
78 (loop
79 :for i from 0 below line-length
80 :do
81 (add-char-to-window window (nth-char-in-line i line))))))
82
83 ;;
84 ;; The actual stream for writing to a window
85 ;;
86 (defclass cl-screen-window-stream
87 (cl-screen-window cl-screen-stream)
88 ((lines :initarg nil :accessor lines-of
89 :documentation "Stream that prints to a history buffer for window")))
90
91
92 (defmethod initialize-instance :after
93 ((self cl-screen-window-stream) &rest args)
94 (declare (ignore args))
95 ;; create a vector of logical lines
96 (setf (lines-of self)
97 (make-array 0 :element-type 'history-line :adjustable t :fill-pointer 0))
98 ;; push first logical line into vector
99 (vector-push-extend (make-instance 'history-line :width (width-of self)) (lines-of self)))
100
101
102 (defgeneric last-line-of (strm))
103
104 (defgeneric add-char (strm chr))
105
106 (defgeneric add-line (strm))
107
108 (defgeneric refresh-window (strm &key position-cursor))
109
110 (defmethod last-line-of ((s cl-screen-window-stream))
111 "(last-line-of cl-screen-window-stream)
112 Return the last line in the array of logical lines (the one we write to)"
113 (aref (lines-of s) (1- (length (lines-of s)))))
114
115 (defmethod add-char ((s cl-screen-window-stream) chr)
116 "(add-char cl-screen-window-stream chr)
117 Add a sigle character to the stream window"
118 (assert (typep chr 'character))
119 (cond
120 ((graphic-char-p chr)
121 (progn
122 (add-char-to-history-line
123 (last-line-of s)
124 chr)))
125 ((char= #\Backspace)
126 (remove-char-from-history-line
127 (last-line-of s)))))
128
129 ;;
130 ;; Adds a new history line to the lines associated with a window
131 ;;
132 (defmethod add-line ((s cl-screen-window-stream))
133 "(add-line cl-screen-window-stream)
134 Add a new line to the history buffer stream"
135 (vector-push-extend (make-instance 'history-line :width (width-of s)) (lines-of s)))
136
137 ;;
138 ;; standard stream - defining methods
139 ;;
140 (defmethod stream-write-char ((s cl-screen-window-stream) (c character))
141 "(stream-write-char cl-screen-window-stream character)
142 Stream based write char to window method"
143 (cond
144 ;; if we write a new line, bump down the cursor
145 ((char= c #\Newline)
146 (add-line s))
147 ;; if we write a tab, bump on x modulo 4
148 ((char= c #\Tab)
149 (let
150 ((new-cursor-x (mod (+ (cursor-of (last-line-of s)) 4) 4)))
151 (when (< new-cursor-x (length (text-of (last-line-of s))))
152 (setf (cursor-of (last-line-of s)) new-cursor-x))))
153 ;; carriage return sets the first column to leftmost
154 ((char= c #\Return)
155 (setf (cursor-of (last-line-of s)) 0))
156 ;; otherwise just show the char in place
157 (t
158 (add-char s c))))
159
160
161 (defmethod stream-line-column ((s cl-screen-window-stream))
162 "(stream-line-column cl-screen-window-stream)
163 Return the column # of the cursor in the stream window"
164 (cursor-of (last-line-of s)))
165
166 (defmethod stream-start-line-p ((s cl-screen-window-stream))
167 "(stream-start-line-p cl-screen-window-stream)
168 Return t if the cursor is at the lhs of the window"
169 (= 0 (cursor-of (last-line-of s))))
170
171 (defmethod stream-terpri ((s cl-screen-window-stream))
172 "Print a newline in the window"
173 (add-line s))
174
175 (defmethod stream-advance-to-column ((s cl-screen-window-stream) column)
176 "Advance the cursor to the given column in the window"
177 (setf (cursor-of (last-line-of s)) (min column (width-of s))))
178
179
180 (defmethod stream-clear-output ((s cl-screen-window-stream))
181 "(stream-clear-output cl-screen-window-stream))
182 Clears the history buffer completely"
183 ;; create a vector of logical lines
184 (setf (lines-of s)
185 (make-array 0 :element-type 'history-line :adjustable t :fill-pointer 0))
186 ;; push first logical line into vector
187 (vector-push-extend (make-instance 'history-line :width (width-of s)) (lines-of s)))
188
189 (defmethod stream-finish-output ((strm cl-screen-window-stream))
190 "(stream-finish-output cl-screen-window-stream)
191 Write the stored logical lines that are visible in the stream window to the screen"
192 (loop
193 for y from (1- (height-of strm)) downto 0
194 for index from (1- (length (lines-of strm))) downto 0
195 do
196 (print-history-line-to-window
197 (the history-line
198 (aref (lines-of strm) index))
199 strm
200 y)))
201
202 (defmethod stream-force-output ((s cl-screen-window-stream))
203 "(stream-finish-output cl-screen-window-stream) Write the stored
204 logical lines that are visible in the stream window to the screen"
205 (stream-finish-output s))
206
207 (defmethod refresh-window ((s cl-screen-window-stream) &key position-cursor)
208 "(refresh-window cl-screen-window :position-cursor p) Send the
209 history lines to the window, then write the text of the window to
210 the main screen. If p is non nil position the screen cursor at
211 the window cursors position."
212 (declare (ignore position-cursor))
213 (stream-force-output s)
214 (call-next-method))

  ViewVC Help
Powered by ViewVC 1.1.5