<commit_before>;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-

;;;  (c) copyright 1998,1999,2000,2001 by <NAME> (<EMAIL>)
;;;  (c) copyright 2000 by
;;;           <NAME> (<EMAIL>)

;;; 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.

(in-package :clim-internals)

;;; Note: in the methods defined on output streams, I often use
;;;	  the sheet's medium as the argument to the draw-* routines.
;;;	  This is so that they don't get recorded if the stream also
;;;	  happens to be an output-recording-stream. - MikeMac 1/7/99

;;; Standard-Output-Stream class

(defclass standard-output-stream (fundamental-character-output-stream)
  ()
  )

(defmethod stream-recording-p ((stream t)) nil)

(defmethod stream-drawing-p ((stream t)) t)

#+ignore(defmethod stream-write-char ((stream standard-output-stream) char)
  (multiple-value-bind (cx cy) (stream-cursor-position stream)
    (cond
     ((eq char #\Newline)
      (setf (stream-cursor-position stream)
            (value 0
                   (+ cy
                      (stream-line-height stream)
                      (stream-vertical-spacing stream)))))
     (t
      (draw-text* (sheet-medium stream) char cx (+ cy (stream-baseline stream)))
      (setf (stream-cursor-position stream)
            (values (+ cx (stream-character-width stream char)) cy))))))



;;; Cursor class
(define-protocol-class cursor ())

(defgeneric cursor-sheet (cursor))

(defgeneric cursor-position (cursor))

(defgeneric* (setf cursor-position) (x y cursor))

(defgeneric cursor-active (cursor))
(defgeneric (setf cursor-active) (value cursor))

(defgeneric cursor-state (cursor))
(defgeneric (setf cursor-state) (value cursor))

(defgeneric cursor-focus (cursor))

(defgeneric cursor-visibility (cursor))
(defgeneric (setf cursor-visibility) (visibility cursor))

;;; Cursor-Mixin class
(defclass cursor-mixin ()
  ((sheet :initarg :sheet
	  :reader cursor-sheet)
   (x :initform 0 :initarg :x-position)
   (y :initform 0 :initarg :y-position)
   (width :initform 8)
   (cursor-active :initform T  ;; XXX what does "cursor is active" mean?                  
                  :accessor cursor-active)
   (cursor-state :initform nil
                 :accessor cursor-state)))

(defgeneric cursor-height (cursor))

(defmethod print-object ((cursor cursor-mixin) stream)
  (with-slots (x y) cursor
    (print-unreadable-object (cursor stream :type t :identity t)
      (format stream "~D ~D " x y))))

(defmethod (setf cursor-state) :around (state (cursor cursor-mixin))
  (unless (eq state (slot-value cursor 'cursor-state))
    (flip-screen-cursor cursor))
  (call-next-method))

(defun decode-cursor-visibility (visibility)
  "Given :on, :off, or nil, returns the needed active and state attributes for the cursor."
  (ecase visibility
    ((:on T) (values T T))
    (:off    (values T nil))
    ((nil)   (values nil nil))))

(defmethod cursor-visibility ((cursor cursor-mixin))
  (let ((a (cursor-active cursor))
        (s (cursor-state cursor)))
    (cond ((and a s) :on)
          ((and a (not s)) :off)
          (T nil))))

(defmethod (setf cursor-visibility) (nv (cursor cursor-mixin))
  (multiple-value-bind (active state)
      (decode-cursor-visibility nv)
    (setf (cursor-state cursor)  state
          (cursor-active cursor) active)))

(defmethod cursor-position ((cursor cursor-mixin))
  (with-slots (x y) cursor
    (values x y)))

(defmethod* (setf cursor-position) (nx ny (cursor cursor-mixin))
  (with-slots (x y) cursor
    (letf (((cursor-state cursor) nil))
      (multiple-value-prog1
	  (setf (values x y) (values nx ny))))
    (when (output-recording-stream-p (cursor-sheet cursor))
    (stream-close-text-output-record (cursor-sheet cursor)))))

(defmethod flip-screen-cursor ((cursor cursor-mixin))
  (with-slots (x y sheet width) cursor
    (let ((height (cursor-height cursor)))
      (draw-rectangle* (sheet-medium (cursor-sheet cursor))
                       x y
                       (+ x width) (+ y height)
                       :filled t
                       :ink +flipping-ink+))))


(defmethod display-cursor ((cursor cursor-mixin) state)
  (with-slots (x y sheet width) cursor
    (let ((height (cursor-height cursor)))
      (case state
	(:draw (draw-rectangle* (sheet-medium (cursor-sheet cursor))
				x y
				(+ x width) (+ y height)
				:filled t
				:ink +foreground-ink+
				))       
        (:erase
               ;; This is how I'd like this to work, as painting over with the background
               ;; ink is repugnant. I leave this disabled because I'm concerned about
               ;; infinite recursion if replay-output-record calls here (which Goatee
               ;; does currently).  --Hefner
                #+nil (repaint-sheet (cursor-sheet cursor)
                                     (make-bounding-rectangle x y (+ 1 x width)
                                                              (+ 1 y height)))
                (draw-rectangle* (sheet-medium (cursor-sheet cursor))
                                 x y
                                 (+ x width) (+ y height)
                                 :filled t
                                 :ink +background-ink+))))))

;;; Standard-Text-Cursor class

(defclass standard-text-cursor (cursor-mixin cursor)
  ())

(defmethod cursor-height ((cursor standard-text-cursor))
  (slot-value (cursor-sheet cursor) 'height))



;;; Extended-Output-Stream class

(define-protocol-class extended-output-stream
    (fundamental-character-output-stream)
  ;; CLIM Specification says that E-O-S is a subclass of
  ;; OUTPUT-STREAM, but it does not says what is it.
  ()
  )

;;; Stream text cursor protocol
(defgeneric stream-text-cursor (stream))
(defgeneric (setf stream-text-cursor) (cursor stream))

(defgeneric stream-cursor-position (stream))
(defgeneric* (setf stream-cursor-position) (x y stream))

(defgeneric stream-increment-cursor-position (stream dx dy))

;;; Text protocol
(defgeneric stream-character-width (stream character &key text-style))

(defgeneric stream-string-width (stream character &key start end text-style))

(defgeneric stream-text-margin (stream))
(defgeneric (setf stream-text-margin) (margin stream))

(defgeneric stream-line-height (stream &key text-style))

(defgeneric stream-vertical-spacing (stream))

(defgeneric stream-baseline (stream))

(defgeneric stream-end-of-line-action (stream))
(defgeneric (setf stream-end-of-line-action) (action stream))

(defgeneric stream-end-of-page-action (stream))
(defgeneric (setf stream-end-of-page-action) (action stream))

;;; Standard-Extended-Output-Stream class

(defclass standard-extended-output-stream (extended-output-stream
                                           standard-output-stream)
  ((cursor :accessor stream-text-cursor)
   (foreground :initarg :foreground
	       :initform +black+
	       :reader stream-foreground)
   (background :initarg :background
	       :initform +white+
	       :reader stream-background)
   (text-style :initarg :text-style
	       :initform *default-text-style*
	       :reader stream-text-style)
   (vspace :initarg :vertical-spacing
	   :initform 2
	   :reader stream-vertical-spacing)
   (margin :initarg :text-margin
	   :initform nil
	   :writer (setf stream-text-margin))
   (eol :initarg :end-of-line-action
	:initform :wrap
	:accessor stream-end-of-line-action)
   (eop :initarg :end-of-page-action
	:initform :scroll
	:accessor stream-end-of-page-action)
   (view :initarg :default-view
	 :initform +textual-view+
	 :accessor stream-default-view)
   (baseline :initform 0
	     :reader stream-baseline)
   ;; What is this? --GB
   (height :initform 0)

   ;; When the stream takes part in the space alloction protocol, this
   ;; remembers our demand:
   (seos-current-width  :initform 0)
   (seos-current-height :initform 0) ))

(defmethod stream-force-output :after ((stream
					standard-extended-output-stream))
  (with-sheet-medium (medium stream)
    (medium-force-output medium)))

(defmethod compose-space ((pane standard-extended-output-stream) &key width height)
  (declare (ignorable width height))
  
  (with-slots (seos-current-width seos-current-height) pane
    (make-space-requirement :width seos-current-width
                            :height seos-current-height)))

(defmethod initialize-instance :after ((stream standard-extended-output-stream) &rest args)
  (declare (ignore args))
  (setf (stream-text-cursor stream) (make-instance 'standard-text-cursor :sheet stream)))

(defmethod stream-cursor-position ((stream standard-extended-output-stream))
  (cursor-position (stream-text-cursor stream)))

(defmethod* (setf stream-cursor-position) (x y (stream standard-extended-output-stream))
  (setf (cursor-position (stream-text-cursor stream)) (values x y)))

(defun stream-set-cursor-position (stream x y)
  (setf (stream-cursor-position stream) (values x y)))

(defmethod stream-increment-cursor-position ((stream standard-extended-output-stream) dx dy)
  (multiple-value-bind (x y) (cursor-position (stream-text-cursor stream))
    (let ((dx (or dx 0))
	  (dy (or dy 0)))
    (setf (cursor-position (stream-text-cursor stream)) (values (+ x dx) (+ y dy))))))



;;;

(defmethod handle-repaint :around ((stream standard-extended-output-stream)
                                   region)
  (declare (ignorable region))
  (let ((cursor (stream-text-cursor stream)))
    (if (cursor-state cursor)
	;; Erase the cursor so that the subsequent flip operation will make a
	;; cursor, whether or not the next-method erases the location of the
	;; cursor.
	;; XXX clip to region?  No one else seems to...
	;; Sure clip to region! --GB
	(letf (((cursor-state cursor) nil))
	  (call-next-method))
	(call-next-method))))

(defmethod scroll-vertical ((stream standard-extended-output-stream) dy)
  (multiple-value-bind (tx ty) (bounding-rectangle-position (sheet-region stream))
    (scroll-extent stream tx (+ ty dy))))

(defmethod scroll-horizontal ((stream standard-extended-output-stream) dx)
  (multiple-value-bind (tx ty) (bounding-rectangle-position (sheet-region stream))
    (scroll-extent stream (+ tx dx) ty)))

(defmacro with-cursor-off (stream &body body)
  `(letf (((cursor-visibility (stream-text-cursor ,stream)) nil))
     ,@body))

(defmethod stream-wrap-line ((stream standard-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))



(defun seos-write-string (stream string &optional (start 0) end)
  (let* ((medium       (sheet-medium stream))
	 (text-style   (medium-text-style medium))
	 (new-baseline (text-style-ascent text-style medium))
	 (new-height   (text-style-height text-style medium))
	 (margin       (stream-text-margin stream))
	 (end          (or end (length string))))
    (flet ((find-split (delta)  ;; FIXME: This can be done smarter.
	     (loop for i from (1+ start) upto end
	       as sub-width = (stream-string-width stream string
						   :start start :end i
						   :text-style text-style)
	       while (<= sub-width delta)
	       finally (return (1- i)))))
  
      (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))
	    ;;  ) ; the beginning of the line should be moved down, but not the whole stream -- APD, 2002-06-18
	    (setq baseline new-baseline))
	  (if (> new-height height)
	      (setq height new-height))
	  (let ((width (stream-string-width stream string
					    :start start :end end
					    :text-style text-style))
		(split end))
	    (when (>= (+ cx width) margin)
	      (ecase (stream-end-of-line-action stream)
		(:wrap
		 (setq split (find-split (- margin cx))))
		(:scroll
		 (scroll-horizontal stream width))
		(:allow)))
	    (unless (= start split)
	      (stream-write-output stream string start split)
	      (setq cx (+ cx width))	      
          (with-slots (x y) (stream-text-cursor stream)
                (setf x cx y cy)))
	    (when (/= split end)
	      (let ((current-baseline baseline))
		(setf baseline current-baseline))		
;		(stream-wrap-line stream)
;		(multiple-value-bind (new-cx new-cy) (stream-cursor-position stream)
;		  (setf cx new-cx
;			cy new-cy			
;			baseline current-baseline)
;		  (setf (stream-cursor-position stream) (values cx cy))))
	      (stream-wrap-line stream)
	      (seos-write-string stream string split end))
	    ))))))

(defun seos-write-newline (stream)
  (let ((medium       (sheet-medium stream))
	(%view-height (bounding-rectangle-height
		       (or (pane-viewport stream)
			   stream)))
	(view-height  (bounding-rectangle-height stream)))    
    (with-slots (baseline height vspace) stream
      (multiple-value-bind (cx cy) (stream-cursor-position stream)
	(setf height (max height (text-style-height (medium-text-style medium) medium)))
	(setf cx 0
	      cy (+ cy height vspace))
	(when (> (+ cy height) view-height)
	  (ecase (stream-end-of-page-action stream)
	    ((:scroll :allow)
             (change-space-requirements stream
                                        :width  (bounding-rectangle-width stream)
                                        :height (+ cy height))
	     ;;(scroll-vertical stream (+ height vspace))
	     )
	    (:wrap
	     (setq cy 0))))
	(unless (eq :allow (stream-end-of-page-action stream))
	  (scroll-extent stream 0 (max 0 (- (+ cy height) %view-height))))
	
	;; mikemac says that this "erase the new line" behavior is
	;; required by the stream text protocol, but I don't see
	;; it.  I'm happy to put this back in again, but in the
	;; meantime it makes debugging of updating-output a bit easier
	;; not to have "extra" records laying around.  If/When it goes
	;; back in... the draw-rectangle has to happen on the stream,
	;; not the medium. -- moore
	#+nil(draw-rectangle* medium cx cy (+ margin 4) (+ cy height)
			      :ink +background-ink+
			      :filled t)
	(setq baseline 0
	      height   0)
	(setf (stream-cursor-position stream) (values cx cy))))))




(defgeneric stream-write-output (stream line &optional start end)
  (:documentation
   "Writes the character or string LINE to STREAM. This function produces no
more than one line of output i.e., doesn't wrap."))
(defmethod stream-write-output (stream line &optional (start 0) end)
  (with-slots (baseline vspace) stream
     (multiple-value-bind (cx cy) (stream-cursor-position stream)
       (draw-text* (sheet-medium stream) line
                   cx (+ cy baseline)
		   :start start :end end))))

(defmethod stream-write-char ((stream standard-extended-output-stream) char)
  (with-cursor-off stream  
   (if (char= #\Newline char)
       (seos-write-newline stream)
     (seos-write-string stream (string char)))))

(defmethod stream-write-string ((stream standard-extended-output-stream) string
				&optional (start 0) end)
  (let ((seg-start start)
	(end (or end (length string))))
    (with-cursor-off stream
     (loop for i from start below end do
       (when (char= #\Newline
		    (char string i))
	 (seos-write-string stream string seg-start i)
	 (seos-write-newline stream)
	 (setq seg-start (1+ i))))
     (seos-write-string stream string seg-start end))))
<commit_msg>kludge to work around long standing ACL output corruption<commit_after>;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-

;;;  (c) copyright 1998,1999,2000,2001 by <NAME> (<EMAIL>)
;;;  (c) copyright 2000 by
;;;           Robert Strandh (<EMAIL>)

;;; 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.

(in-package :clim-internals)

;;; Note: in the methods defined on output streams, I often use
;;;	  the sheet's medium as the argument to the draw-* routines.
;;;	  This is so that they don't get recorded if the stream also
;;;	  happens to be an output-recording-stream. - MikeMac 1/7/99

;;; Standard-Output-Stream class

(defclass standard-output-stream (fundamental-character-output-stream)
  ()
  )

(defmethod stream-recording-p ((stream t)) nil)

(defmethod stream-drawing-p ((stream t)) t)

#+ignore(defmethod stream-write-char ((stream standard-output-stream) char)
  (multiple-value-bind (cx cy) (stream-cursor-position stream)
    (cond
     ((eq char #\Newline)
      (setf (stream-cursor-position stream)
            (value 0
                   (+ cy
                      (stream-line-height stream)
                      (stream-vertical-spacing stream)))))
     (t
      (draw-text* (sheet-medium stream) char cx (+ cy (stream-baseline stream)))
      (setf (stream-cursor-position stream)
            (values (+ cx (stream-character-width stream char)) cy))))))



;;; Cursor class
(define-protocol-class cursor ())

(defgeneric cursor-sheet (cursor))

(defgeneric cursor-position (cursor))

(defgeneric* (setf cursor-position) (x y cursor))

(defgeneric cursor-active (cursor))
(defgeneric (setf cursor-active) (value cursor))

(defgeneric cursor-state (cursor))
(defgeneric (setf cursor-state) (value cursor))

(defgeneric cursor-focus (cursor))

(defgeneric cursor-visibility (cursor))
(defgeneric (setf cursor-visibility) (visibility cursor))

;;; Cursor-Mixin class
(defclass cursor-mixin ()
  ((sheet :initarg :sheet
	  :reader cursor-sheet)
   (x :initform 0 :initarg :x-position)
   (y :initform 0 :initarg :y-position)
   (width :initform 8)
   (cursor-active :initform T  ;; XXX what does "cursor is active" mean?                  
                  :accessor cursor-active)
   (cursor-state :initform nil
                 :accessor cursor-state)))

(defgeneric cursor-height (cursor))

(defmethod print-object ((cursor cursor-mixin) stream)
  (with-slots (x y) cursor
    (print-unreadable-object (cursor stream :type t :identity t)
      (format stream "~D ~D " x y))))

(defmethod (setf cursor-state) :around (state (cursor cursor-mixin))
  (unless (eq state (slot-value cursor 'cursor-state))
    (flip-screen-cursor cursor))
  (call-next-method))

(defun decode-cursor-visibility (visibility)
  "Given :on, :off, or nil, returns the needed active and state attributes for the cursor."
  (ecase visibility
    ((:on T) (values T T))
    (:off    (values T nil))
    ((nil)   (values nil nil))))

(defmethod cursor-visibility ((cursor cursor-mixin))
  (let ((a (cursor-active cursor))
        (s (cursor-state cursor)))
    (cond ((and a s) :on)
          ((and a (not s)) :off)
          (T nil))))

(defmethod (setf cursor-visibility) (nv (cursor cursor-mixin))
  (multiple-value-bind (active state)
      (decode-cursor-visibility nv)
    (setf (cursor-state cursor)  state
          (cursor-active cursor) active)))

(defmethod cursor-position ((cursor cursor-mixin))
  (with-slots (x y) cursor
    (values x y)))

(defmethod* (setf cursor-position) (nx ny (cursor cursor-mixin))
  (with-slots (x y) cursor
    (letf (((cursor-state cursor) nil))
      (multiple-value-prog1
	  (setf (values x y) (values nx ny))))
    (when (output-recording-stream-p (cursor-sheet cursor))
    (stream-close-text-output-record (cursor-sheet cursor)))))

(defmethod flip-screen-cursor ((cursor cursor-mixin))
  (with-slots (x y sheet width) cursor
    (let ((height (cursor-height cursor)))
      (draw-rectangle* (sheet-medium (cursor-sheet cursor))
                       x y
                       (+ x width) (+ y height)
                       :filled t
                       :ink +flipping-ink+))))


(defmethod display-cursor ((cursor cursor-mixin) state)
  (with-slots (x y sheet width) cursor
    (let ((height (cursor-height cursor)))
      (case state
	(:draw (draw-rectangle* (sheet-medium (cursor-sheet cursor))
				x y
				(+ x width) (+ y height)
				:filled t
				:ink +foreground-ink+
				))       
        (:erase
               ;; This is how I'd like this to work, as painting over with the background
               ;; ink is repugnant. I leave this disabled because I'm concerned about
               ;; infinite recursion if replay-output-record calls here (which Goatee
               ;; does currently).  --Hefner
                #+nil (repaint-sheet (cursor-sheet cursor)
                                     (make-bounding-rectangle x y (+ 1 x width)
                                                              (+ 1 y height)))
                (draw-rectangle* (sheet-medium (cursor-sheet cursor))
                                 x y
                                 (+ x width) (+ y height)
                                 :filled t
                                 :ink +background-ink+))))))

;;; Standard-Text-Cursor class

(defclass standard-text-cursor (cursor-mixin cursor)
  ())

(defmethod cursor-height ((cursor standard-text-cursor))
  (slot-value (cursor-sheet cursor) 'height))



;;; Extended-Output-Stream class

(define-protocol-class extended-output-stream
    (fundamental-character-output-stream)
  ;; CLIM Specification says that E-O-S is a subclass of
  ;; OUTPUT-STREAM, but it does not says what is it.
  ()
  )

;;; Stream text cursor protocol
(defgeneric stream-text-cursor (stream))
(defgeneric (setf stream-text-cursor) (cursor stream))

(defgeneric stream-cursor-position (stream))
(defgeneric* (setf stream-cursor-position) (x y stream))

(defgeneric stream-increment-cursor-position (stream dx dy))

;;; Text protocol
(defgeneric stream-character-width (stream character &key text-style))

(defgeneric stream-string-width (stream character &key start end text-style))

(defgeneric stream-text-margin (stream))
(defgeneric (setf stream-text-margin) (margin stream))

(defgeneric stream-line-height (stream &key text-style))

(defgeneric stream-vertical-spacing (stream))

(defgeneric stream-baseline (stream))

(defgeneric stream-end-of-line-action (stream))
(defgeneric (setf stream-end-of-line-action) (action stream))

(defgeneric stream-end-of-page-action (stream))
(defgeneric (setf stream-end-of-page-action) (action stream))

;;; Standard-Extended-Output-Stream class

(defclass standard-extended-output-stream (extended-output-stream
                                           standard-output-stream)
  ((cursor :accessor stream-text-cursor)
   (foreground :initarg :foreground
	       :initform +black+
	       :reader stream-foreground)
   (background :initarg :background
	       :initform +white+
	       :reader stream-background)
   (text-style :initarg :text-style
	       :initform *default-text-style*
	       :reader stream-text-style)
   (vspace :initarg :vertical-spacing
	   :initform 2
	   :reader stream-vertical-spacing)
   (margin :initarg :text-margin
	   :initform nil
	   :writer (setf stream-text-margin))
   (eol :initarg :end-of-line-action
	:initform :wrap
	:accessor stream-end-of-line-action)
   (eop :initarg :end-of-page-action
	:initform :scroll
	:accessor stream-end-of-page-action)
   (view :initarg :default-view
	 :initform +textual-view+
	 :accessor stream-default-view)
   (baseline :initform 0
	     :reader stream-baseline)
   ;; What is this? --GB
   (height :initform 0)

   ;; When the stream takes part in the space alloction protocol, this
   ;; remembers our demand:
   (seos-current-width  :initform 0)
   (seos-current-height :initform 0) ))

(defmethod stream-force-output :after ((stream
					standard-extended-output-stream))
  (with-sheet-medium (medium stream)
    (medium-force-output medium)))

(defmethod compose-space ((pane standard-extended-output-stream) &key width height)
  (declare (ignorable width height))
  
  (with-slots (seos-current-width seos-current-height) pane
    (make-space-requirement :width seos-current-width
                            :height seos-current-height)))

(defmethod initialize-instance :after ((stream standard-extended-output-stream) &rest args)
  (declare (ignore args))
  (setf (stream-text-cursor stream) (make-instance 'standard-text-cursor :sheet stream)))

(defmethod stream-cursor-position ((stream standard-extended-output-stream))
  (cursor-position (stream-text-cursor stream)))

(defmethod* (setf stream-cursor-position) (x y (stream standard-extended-output-stream))
  (setf (cursor-position (stream-text-cursor stream)) (values x y)))

(defun stream-set-cursor-position (stream x y)
  (setf (stream-cursor-position stream) (values x y)))

(defmethod stream-increment-cursor-position ((stream standard-extended-output-stream) dx dy)
  (multiple-value-bind (x y) (cursor-position (stream-text-cursor stream))
    (let ((dx (or dx 0))
	  (dy (or dy 0)))
    (setf (cursor-position (stream-text-cursor stream)) (values (+ x dx) (+ y dy))))))



;;;

(defmethod handle-repaint :around ((stream standard-extended-output-stream)
                                   region)
  (declare (ignorable region))
  (let ((cursor (stream-text-cursor stream)))
    (if (cursor-state cursor)
	;; Erase the cursor so that the subsequent flip operation will make a
	;; cursor, whether or not the next-method erases the location of the
	;; cursor.
	;; XXX clip to region?  No one else seems to...
	;; Sure clip to region! --GB
	(letf (((cursor-state cursor) nil))
	  (call-next-method))
	(call-next-method))))

(defmethod scroll-vertical ((stream standard-extended-output-stream) dy)
  (multiple-value-bind (tx ty) (bounding-rectangle-position (sheet-region stream))
    (scroll-extent stream tx (+ ty dy))))

(defmethod scroll-horizontal ((stream standard-extended-output-stream) dx)
  (multiple-value-bind (tx ty) (bounding-rectangle-position (sheet-region stream))
    (scroll-extent stream (+ tx dx) ty)))

(defmacro with-cursor-off (stream &body body)
  `(letf (((cursor-visibility (stream-text-cursor ,stream)) nil))
     ,@body))

(defmethod stream-wrap-line ((stream standard-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))



(defun seos-write-string (stream string &optional (start 0) end)
  (let* ((medium       (sheet-medium stream))
	 (text-style   (medium-text-style medium))
	 (new-baseline (text-style-ascent text-style medium))
	 (new-height   (text-style-height text-style medium))
	 (margin       (stream-text-margin stream))
	 (end          (or end (length string))))
    (flet ((find-split (delta)  ;; FIXME: This can be done smarter.
	     (loop for i from (1+ start) upto end
	       as sub-width = (stream-string-width stream string
						   :start start :end i
						   :text-style text-style)
	       while (<= sub-width delta)
	       finally (return (1- i)))))
  
      (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))
	    ;;  ) ; the beginning of the line should be moved down, but not the whole stream -- APD, 2002-06-18
	    (setq baseline new-baseline))
	  (if (> new-height height)
	      (setq height new-height))
	  (let ((width (stream-string-width stream string
					    :start start :end end
					    :text-style text-style))
		(split end))
	    (when (>= (+ cx width) margin)
	      (ecase (stream-end-of-line-action stream)
		(:wrap
		 (setq split (find-split (- margin cx))))
		(:scroll
		 (scroll-horizontal stream width))
		(:allow)))
	    (unless (= start split)
	      (stream-write-output stream string start split)
	      (setq cx (+ cx width))	      
          (with-slots (x y) (stream-text-cursor stream)
                (setf x cx y cy)))
	    (when (/= split end)
	      (let ((current-baseline baseline))
		(setf baseline current-baseline))		
;		(stream-wrap-line stream)
;		(multiple-value-bind (new-cx new-cy) (stream-cursor-position stream)
;		  (setf cx new-cx
;			cy new-cy			
;			baseline current-baseline)
;		  (setf (stream-cursor-position stream) (values cx cy))))
	      (stream-wrap-line stream)
	      (seos-write-string stream string split end))
	    ))))))

(defun seos-write-newline (stream)
  (let ((medium       (sheet-medium stream))
	(%view-height (bounding-rectangle-height
		       (or (pane-viewport stream)
			   stream)))
	(view-height  (bounding-rectangle-height stream)))    
    (with-slots (baseline height vspace) stream
      (multiple-value-bind (cx cy) (stream-cursor-position stream)
	(setf height (max height (text-style-height (medium-text-style medium) medium)))
	(setf cx 0
	      cy (+ cy height vspace))
	(when (> (+ cy height) view-height)
	  (ecase (stream-end-of-page-action stream)
	    ((:scroll :allow)
             (change-space-requirements stream
                                        :width  (bounding-rectangle-width stream)
                                        :height (+ cy height))
	     ;;(scroll-vertical stream (+ height vspace))
	     )
	    (:wrap
	     (setq cy 0))))
	(unless (eq :allow (stream-end-of-page-action stream))
	  (scroll-extent stream 0 (max 0 (- (+ cy height) %view-height))))
	
	;; mikemac says that this "erase the new line" behavior is
	;; required by the stream text protocol, but I don't see
	;; it.  I'm happy to put this back in again, but in the
	;; meantime it makes debugging of updating-output a bit easier
	;; not to have "extra" records laying around.  If/When it goes
	;; back in... the draw-rectangle has to happen on the stream,
	;; not the medium. -- moore
	#+nil(draw-rectangle* medium cx cy (+ margin 4) (+ cy height)
			      :ink +background-ink+
			      :filled t)
	(setq baseline 0
	      height   0)
	(setf (stream-cursor-position stream) (values cx cy))))))




(defgeneric stream-write-output (stream line &optional start end)
  (:documentation
   "Writes the character or string LINE to STREAM. This function produces no
more than one line of output i.e., doesn't wrap."))
(defmethod stream-write-output (stream line &optional (start 0) end)
  (with-slots (baseline vspace) stream
     (multiple-value-bind (cx cy) (stream-cursor-position stream)
       (draw-text* (sheet-medium stream) line
                   cx (+ cy baseline)
		   :start start :end end))))

(defmethod stream-write-char ((stream standard-extended-output-stream) char)
  (with-cursor-off stream  
   (if (char= #\Newline char)
       (seos-write-newline stream)
     (seos-write-string stream (string char)))))

;;; I added the (subseq string seg-start ...) forms. Under ACL, there is some
;;; wierd interaction with FORMAT. This shows up as overwritten text in the
;;; pointer documentation and in menus. It acts like a shared buffer is being corrupted
;;; but I can't narrow it down. Using SUBSEQ does fix this interaction that's been
;;; here since 4/16/03 - Mikemac 12/6/2003
(defmethod stream-write-string ((stream standard-extended-output-stream) string
				&optional (start 0) end)
  (let ((seg-start start)
	(end (or end (length string))))
    (with-cursor-off stream
     (loop for i from start below end do
       (when (char= #\Newline
		    (char string i))
	 (seos-write-string stream (subseq string seg-start i))
	 (seos-write-newline stream)
	 (setq seg-start (1+ i))))
     (seos-write-string stream (subseq string seg-start end)))))

{'fraction_non_alphanumeric': 0.13070287345847761, 'fraction_numerical': 0.005042221007229208, 'mean_word_length': 2.942402107532032, 'pattern_counts': {'":': 0, '<': 12, '<?xml version=': 0, '>': 22, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 26, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1956443', 'n_tokens_mistral': 10442, 'n_tokens_neox': 9769, 'n_words': 3158}