Skip to content

Commit

Permalink
Rewrote stream-write-char and output recording of text. It seems to …
Browse files Browse the repository at this point in the history 
…work now!!!

(What's displayed originally and what's rdisplayed match. Wrapping and vertical
scrolling also appear correct.)
  • Loading branch information
CVS pserver daemon committed Dec 1, 2000
1 parent 553f67a commit 6b78580
Show file tree
Hide file tree
Showing 2 changed files with 151 additions and 152 deletions.
106 changes: 55 additions & 51 deletions recording.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -74,14 +74,13 @@
(defun replay (record stream &optional region)
(let ((old-record-p (stream-recording-p stream))
(old-draw-p (stream-drawing-p stream)))
(when old-record-p
(unwind-protect
(progn
(setf (stream-recording-p stream) nil
(stream-drawing-p stream) t)
(replay-output-record record stream region))
(setf (stream-recording-p stream) old-record-p
(stream-drawing-p stream) old-draw-p)))))
(unwind-protect
(progn
(setf (stream-recording-p stream) nil
(stream-drawing-p stream) t)
(replay-output-record record stream region))
(setf (stream-recording-p stream) old-record-p
(stream-drawing-p stream) old-draw-p))))

(defmethod replay-output-record ((record output-record) stream
&optional region x-offset y-offset)
Expand Down Expand Up @@ -433,11 +432,19 @@
(start-x :initarg :start-x)
(start-y :initarg :start-y)
(end-x)
(end-y)))
(end-y)
(wrapped :initform nil
:accessor text-record-wrapped)))

(defun text-displayed-output-record-p (x)
(typep x 'text-displayed-output-record))

(defmethod print-object ((self text-displayed-output-record) stream)
(print-unreadable-object (self stream :type t :identity t)
(if (slot-boundp self 'start-x)
(with-slots (start-x start-y strings) self
(format stream "~D,~D ~S" start-x start-y (mapcar #'third strings)))
(format stream "empty"))))

(defmethod add-character-output-to-text-record ((text-record text-displayed-output-record)
character text-style width height
Expand Down Expand Up @@ -467,7 +474,7 @@
(defmethod replay-output-record ((record text-displayed-output-record) stream
&optional region x-offset y-offset)
(declare (ignore x-offset y-offset))
(with-slots (strings baseline max-height start-x start-y) record
(with-slots (strings baseline max-height start-x start-y wrapped) record
(let ((old-medium (sheet-medium stream))
(new-medium (make-medium (port stream) stream)))
(unwind-protect
Expand All @@ -478,7 +485,12 @@
for (x text-style string) in strings
do (setf (medium-text-style new-medium) text-style)
(draw-text* stream string x y
:text-style text-style :clipping-region region)))
:text-style text-style :clipping-region region))
(if wrapped
(draw-rectangle* (sheet-medium stream)
(+ wrapped 0) start-y (+ wrapped 4) (+ start-y max-height)
:ink +foreground-ink+
:filled t)))
(setf (sheet-medium stream) old-medium)))))

(defmethod output-record-start-cursor-position ((record text-displayed-output-record))
Expand All @@ -503,51 +515,43 @@
(unless (text-displayed-output-record-p trec)
(setq trec (make-instance 'text-displayed-output-record))
(add-output-record trec (stream-output-history stream))
(setf (stream-current-output-record stream) trec))
(setf (stream-current-output-record stream) trec)
(with-slots (start-x start-y end-x end-y) trec
(multiple-value-bind (cx cy) (stream-cursor-position stream)
(setq start-x cx
start-y (+ cy (stream-vertical-spacing stream))
end-x start-x
end-y start-y))))
trec))

(defmethod stream-write-char :around ((stream output-recording-stream) char)
(when (stream-recording-p stream)
(get-text-record stream))
(call-next-method)
(when (stream-recording-p stream)
(cond
((or (eql char #\return)
(eql char #\newline))
((not (or (eql char #\return)
(eql char #\newline)))
(let* ((medium (sheet-medium stream))
(text-style (medium-text-style medium))
(trec (get-text-record stream))
(port (port stream)))
(add-character-output-to-text-record
trec char text-style
(stream-character-width stream char :text-style text-style)
(text-style-height text-style port)
(text-style-ascent text-style port))))
(t
(let ((trec (make-instance 'text-displayed-output-record)))
(add-output-record trec (stream-output-history stream))
(setf (stream-current-output-record stream) trec)))
(t
(let ((medium (sheet-medium stream))
(trec (get-text-record stream)))
(multiple-value-bind (width height ignore1 ignore2 baseline)
(text-size medium (string char))
(declare (ignore ignore1 ignore2))
(if (not (slot-boundp trec 'start-y))
(with-slots (start-x start-y end-x end-y) trec
(multiple-value-bind (cx cy) (stream-cursor-position stream)
(setq start-x cx
start-y (+ cy (stream-vertical-spacing stream))
end-x cx
end-y cy))))
(add-character-output-to-text-record trec char
(medium-text-style medium)
width height baseline))))))
(call-next-method))

(defmethod stream-write-string :around ((stream output-recording-stream) string
&optional (start 0) end)
(setf (stream-current-output-record stream) trec)
(with-slots (start-x start-y end-x end-y) trec
(multiple-value-bind (cx cy) (stream-cursor-position stream)
(setq start-x cx
start-y (+ cy (stream-vertical-spacing stream))
end-x start-x
end-y start-y))))))))

(defmethod stream-wrap-line :before ((stream output-recording-stream))
(when (stream-recording-p stream)
(let ((medium (sheet-medium stream))
(trec (get-text-record stream)))
(multiple-value-bind (width height ignore1 ignore2 baseline)
(text-size medium string)
(declare (ignore ignore1 ignore2))
(if (not (slot-boundp trec 'start-y))
(with-slots (start-x start-y end-x end-y) trec
(multiple-value-bind (cx cy) (stream-cursor-position stream)
(setq start-x cx
start-y (+ cy (stream-vertical-spacing stream))
end-x cx
end-y cy))))
(add-string-output-to-text-record trec string start end
(medium-text-style medium)
width height baseline))))
(call-next-method))
(setf (text-record-wrapped (get-text-record stream)) (stream-text-margin stream))))
197 changes: 96 additions & 101 deletions stream-output.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -168,120 +168,115 @@
(setf*-cursor-position (+ x dx) (+ y dy) (stream-text-cursor stream))))

(defmethod scroll-vertical ((stream extended-output-stream) dy)
(let* ((port (port stream))
(medium (sheet-medium stream))
(old-transform (medium-transformation medium))
(width (port-mirror-width port stream))
(height (port-mirror-height port stream)))
(setf (medium-transformation medium) +identity-transformation+)
(unwind-protect
(cond
((> dy 0)
(copy-area stream 0 dy width height 0 0)
(draw-rectangle* stream 0 (- height dy) width height
:ink +background-ink+
:filled t))
((< dy 0)
(copy-area stream 0 0 width height 0 dy)
(draw-rectangle* stream 0 0 width dy
:ink +background-ink+
:filled t)))
(setf (medium-transformation medium) old-transform))
(setf (medium-transformation medium)
(compose-transformation-with-translation (medium-transformation medium) 0 (- dy)))))
(with-slots (tx ty) (sheet-transformation stream)
(setq tx (- tx)
ty (- ty))
(scroll-extent stream tx (+ ty dy))))

(defmethod scroll-horizontal ((stream extended-output-stream) dx)
)
(with-slots (tx ty) (sheet-transformation stream)
(setq tx (- tx)
ty (- ty))
(scroll-extent stream (+ tx dx) ty)))

(defmacro with-cursor-off (stream &body body)
`(let* ((cursor (stream-text-cursor ,stream))
(visible (cursor-visibility cursor)))
(unwind-protect
(progn
(if visible
(setf (cursor-visibility cursor) nil))
,@body)
(if visible
(setf (cursor-visibility cursor) t)))))

(defmethod stream-wrap-line ((stream extended-output-stream))
(let ((margin (stream-text-margin stream)))
(multiple-value-bind (cx cy) (stream-cursor-position stream)
(declare (ignore cx))
(draw-rectangle* (sheet-medium stream) margin cy (+ margin 4) (+ cy (slot-value stream 'height))
:ink +foreground-ink+
:filled t)))
(stream-write-char stream #\newline))

(defmacro with-room-for-line (&body body)
`(let* ((cursor (stream-text-cursor stream))
(visible (cursor-visibility cursor))
(medium (sheet-medium stream))
(port (port stream))
(text-style (medium-text-style medium))
(new-baseline (text-style-ascent text-style port))
(new-height (text-style-height text-style port))
(margin (stream-text-margin stream))
(view-height (port-mirror-height port stream)))
(if visible
(setf (cursor-visibility cursor) nil))
(with-slots (baseline height vspace) stream
(multiple-value-bind (cx cy) (stream-cursor-position stream)
(when (> new-baseline baseline)
(when (or (> baseline 0)
(> height 0))
(scroll-vertical stream (- new-baseline baseline))
)
(setq baseline new-baseline))
(if (> new-height height)
(setq height new-height))
,@body))
(if visible
(setf (cursor-visibility cursor) t))))

;;; do-char doesn't do scrolling/wrapping correctly - mikemac 12/19/1998
(defmacro do-char ()
`(cond
((eq char #\Newline)
(when (> (+ cy height vspace height vspace) view-height)
(ecase (stream-end-of-page-action stream)
(:scroll
(scroll-vertical stream (+ height vspace)))
(:wrap
(setq cy (- (+ height vspace))))
(:allow
)))
(setq cx 0
cy (+ cy height vspace)
baseline 0
height 0)
(draw-rectangle* medium cx cy (+ margin 4) (+ cy new-height)
:ink +background-ink+
:filled t)
(setf*-stream-cursor-position cx cy stream))
(t
(let ((width (stream-character-width stream char :text-style text-style)))
(when (> (+ cx width) margin)
(ecase (stream-end-of-line-action stream)
(:wrap
(draw-rectangle* medium margin cy (+ margin 4) (+ cy height)
:ink +foreground-ink+
:filled t)
(when (> (+ cy height vspace height vspace) view-height)
(ecase (stream-end-of-page-action stream)
(:scroll
(scroll-vertical stream (+ height vspace)))
(defmethod stream-write-char ((stream extended-output-stream) char)
(let* ((cursor (stream-text-cursor stream))
(visible (cursor-visibility cursor))
(medium (sheet-medium stream))
(port (port stream))
(text-style (medium-text-style medium))
(new-baseline (text-style-ascent text-style port))
(new-height (text-style-height text-style port))
(margin (stream-text-margin stream))
(view-height (port-mirror-height port stream)))
(if visible
(setf (cursor-visibility cursor) nil))
(with-slots (baseline height vspace) stream
(multiple-value-bind (cx cy) (stream-cursor-position stream)
(when (> new-baseline baseline)
(when (or (> baseline 0)
(> height 0))
(scroll-vertical stream (- new-baseline baseline))
)
(setq baseline new-baseline))
(if (> new-height height)
(setq height new-height))
(cond
((eq char #\Newline)
(setq cx 0
cy (+ cy height vspace))
(when (> (+ cy height vspace) view-height)
(ecase (stream-end-of-page-action stream)
(:scroll
(scroll-vertical stream (+ height vspace)))
(:wrap
(setq cy 0))
(:allow
)))
(draw-rectangle* medium cx cy (+ margin 4) (+ cy height)
:ink +background-ink+
:filled t)
(setq baseline 0
height 0)
(setf*-stream-cursor-position cx cy stream))
(t
(let ((width (stream-character-width stream char :text-style text-style)))
(when (>= (+ cx width) margin)
(ecase (stream-end-of-line-action stream)
(:wrap
(setq cy (- (+ height vspace))))
(let ((current-baseline baseline))
(stream-wrap-line stream)
(multiple-value-bind (new-cx new-cy) (stream-cursor-position stream)
(setq cx new-cx
cy new-cy
baseline current-baseline))))
(:scroll
(scroll-horizontal stream width))
(:allow
)))
(setq cx 0
cy (+ cy height vspace)
baseline new-baseline
height new-height)
(draw-rectangle* medium cx cy (+ margin 4) (+ cy new-height)
:ink +background-ink+
:filled t))
(:scroll
(scroll-horizontal stream width))
(:allow
)))
(draw-text* stream char cx (+ cy baseline) :text-style text-style)
(setq cx (+ cx width))
(setf*-stream-cursor-position cx cy stream)))))

(defmethod stream-write-char ((stream extended-output-stream) char)
(with-room-for-line
(do-char)))
(draw-text* stream char cx (+ cy baseline vspace) :text-style text-style)
(setq cx (+ cx width))
(setf*-stream-cursor-position cx cy stream))))))
(if visible
(setf (cursor-visibility cursor) t))))

(defmethod stream-write-string ((stream extended-output-stream) string
&optional (start 0) end)
(if (null end)
(setq end (length string)))
(with-room-for-line
(with-cursor-off stream
(loop for i from start below end
for char = (aref string i)
do (do-char))))
do (stream-write-char stream char))))

;(defmethod stream-write-string ((stream extended-output-stream) string
; &optional (start 0) end)
; (if (null end)
; (setq end (length string)))
; (with-room-for-line
; (loop for i from start below end
; for char = (aref string i)
; do (do-char))))

(defmethod stream-character-width ((stream extended-output-stream) char &key (text-style nil))
(port-character-width (port stream)
Expand Down

0 comments on commit 6b78580

Please sign in to comment.