typeout.lisp 8.62 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
;;; -*- Mode: Lisp; Package: CLIMACS-CORE -*-

;;;  (c) copyright 2008 by
;;;           Troels Henriksen (athas@sigkill.dk)

;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA  02111-1307  USA.

;;; Typeout pane support.

(in-package :climacs-gui)

(defclass typeout-view (drei-view textual-view)
  ((%output-history :accessor output-history
                    :initform (make-instance 'standard-tree-output-record)
                    :initarg :output-history
                    :documentation "The output record history
that will be replayed whenever the views contents are shown.")
   (%dirty :accessor dirty
           :initform t
           :documentation "This value indicates whether the
34
35
36
37
38
39
output has changed since it was last replayed.")
   (%cursor-position :accessor last-cursor-position
                     :initform nil
                     :documentation "A list (X Y) specifying
where drawing ended the last time, and where it should start the
next time. If NIL, no previous position has been recorded."))
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
  (:metaclass modual-class)
  (:documentation "A noneditable Drei view displaying an output
record history."))

(defun typeout-view-p (view)
  "Return true if `view' is a typeout view, false otherwise."
  (typep view 'typeout-view))

(defmethod handle-redisplay ((pane drei-pane) (view typeout-view) (region region))
  (if (and (not (dirty view))
           (find (output-history view)
                 (output-record-children (stream-output-history pane))))
      (replay (stream-output-history pane) pane region)
      (call-next-method)))

(defmethod display-drei-view-contents ((pane pane) (view typeout-view))
56
57
58
59
60
61
62
63
64
65
66
67
68
69
  (when (or (dirty view)
            (not (eq (output-record-parent (output-history view))
                     (stream-output-history pane))))
    (with-output-recording-options (pane :record nil :draw t)
      (with-bounding-rectangle* (x1 y1 x2 y2) (or (pane-viewport-region pane)
                                                  (sheet-region pane))
        (draw-rectangle* pane x1 y1 x2 y2 :ink +background-ink+))
      (replay-output-record (output-history view) pane
                            (or (pane-viewport-region pane)
                                (sheet-region pane))))
    (unless (eq (output-record-parent (output-history view))
                (stream-output-history pane))
      (setf (output-record-parent (output-history view)) nil)
      (add-output-record (output-history view) (stream-output-history pane))))
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
  (setf (dirty view) nil))

(defmethod bounding-rectangle* ((view typeout-view))
  (if (output-history view)
      (bounding-rectangle* (output-history view))
      (values 0 0 0 0)))

(defun scroll-typeout-window (window y)
  "Scroll `window' down by `y' device units, but taking care not
to scroll past the size of `window'. If `window' does not have a
viewport, do nothing."
  (let ((viewport (pane-viewport window)))
    (unless (null viewport)            ; Can't scroll without viewport
      (multiple-value-bind (x-displacement y-displacement)
          (transform-position (sheet-transformation window) 0 0)
        (scroll-extent window
                       (- x-displacement)
                       (max 0 (min (+ (- y-displacement) y)
                                   (- (bounding-rectangle-height window)
                                      (bounding-rectangle-height viewport)))))))))

(defmethod page-down ((pane sheet) (view typeout-view))
  (scroll-typeout-window pane (bounding-rectangle-height (pane-viewport pane))))

(defmethod page-up ((pane sheet) (view typeout-view))
  (scroll-typeout-window
   pane (- (bounding-rectangle-height (pane-viewport pane)))))

(defun ensure-typeout-view (climacs label)
  "Ensure that `climacs' has a typeout view with the name
`label', and return that view."
  (check-type label string)
  (or (find-if #'(lambda (view)
                   (and (typeout-view-p view)
                        (string= (name view) label)))
               (views climacs))
      (make-new-view-for-climacs climacs 'typeout-view
       :name label)))

;; Because specialising on the type of `climacs' is so useful...
(defun invoke-with-typeout (climacs label continuation)
  "Call `continuation' with a single argument, a
stream meant for typeout. `Climacs' is the Climacs instance in
which the typeout pane should be shown, and `label' is the name
of the created typeout view."
  (let* ((typeout-view (ensure-typeout-view climacs label))
         (pane-with-typeout (or (find typeout-view (windows climacs)
                                 :key #'view)
                                (let ((pane (split-window t)))
                                  (setf (view pane) typeout-view)
                                  pane))))
    (let ((new-record (with-output-to-output-record (pane-with-typeout)
                        (with-output-recording-options (pane-with-typeout :record t :draw t)
123
124
125
126
127
128
                          (when (last-cursor-position typeout-view)
                            (setf (stream-cursor-position pane-with-typeout)
                                  (values-list (last-cursor-position typeout-view))))
                          (funcall continuation pane-with-typeout)
                          (setf (last-cursor-position typeout-view)
                                (multiple-value-list (stream-cursor-position pane-with-typeout)))))))
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
      (add-output-record new-record (output-history typeout-view))
      (setf (dirty typeout-view) t))))

(defmacro with-typeout ((stream &optional (label "Typeout")) &body body)
  "Evaluate `body' with `stream' bound to a stream that can be
used for typeout. `Label' is the name of the created typeout
view."
  `(invoke-with-typeout *esa-instance* ,label
                        #'(lambda (,stream)
                            ,@body)))

;;; An implementation of the Gray streams protocol that uses a Climacs
;;; typeout view to draw the output.

(defclass typeout-stream (fundamental-character-output-stream)
  ((%climacs :reader climacs-instance
             :initform (error "Must provide a Climacs instance for typeout streams")
             :initarg :climacs)
   (%label :reader label
           :initform (error "A typeout stream must have a label")
           :initarg :label))
  (:documentation "An output stream that performs output on
a (single) Climacs typeout pane. If the typeout pane is deleted
manually by the user, the stream will recreate it the next time
output is performed."))

(defmethod stream-write-char ((stream typeout-stream) char)
  (with-typeout (typeout (label stream))
    (stream-write-char typeout char)))

(defmethod stream-line-column ((stream typeout-stream))
  (with-typeout (typeout (label stream))
    (stream-line-column typeout)))

(defmethod stream-start-line-p ((stream typeout-stream))
  (with-typeout (typeout (label stream))
    (stream-start-line-p typeout)))

(defmethod stream-write-string ((stream typeout-stream) string &optional (start 0) end)
  (with-typeout (typeout (label stream))
    (stream-write-string typeout string start end)))

(defmethod stream-terpri ((stream typeout-stream))
  (with-typeout (typeout (label stream))
    (stream-terpri typeout)))

(defmethod stream-fresh-line ((stream typeout-stream))
  (with-typeout (typeout (label stream))
    (stream-fresh-line typeout)))

(defmethod stream-finish-output ((stream typeout-stream))
  (with-typeout (typeout (label stream))
    (stream-finish-output typeout)))

(defmethod stream-force-output ((stream typeout-stream))
  (with-typeout (typeout (label stream))
    (stream-force-output typeout)))

(defmethod stream-clear-output ((stream typeout-stream))
  (with-typeout (typeout (label stream))
    (stream-clear-output typeout)))

(defmethod stream-advance-to-column ((stream typeout-stream) (column integer))
  (with-typeout (typeout (label stream))
    (stream-advance-to-column typeout column)))

(defmethod interactive-stream-p ((stream typeout-stream))
  (with-typeout (typeout (label stream))
    (interactive-stream-p typeout)))

(defun make-typeout-stream (climacs label)
  (make-instance 'typeout-stream :climacs climacs :label label))