(defpackage :foo
  (:use :clim-lisp :clim-sys))

(in-package :foo)

(defclass stream-pane (fundamental-character-output-stream)
  ((output-history
    :initform nil)
   
   ;; The extent
   (x1 :initform 0)
   (y1 :initform 0)
   (x2 :initform 0)
   (y2 :initform 0)

   ;; It's scroll position
   (sx :initform 0)
   (sy :initform 0)

   ;; Cursor
   (cx :initform 0)
   (cy :initform 0)

   (dx1 :initform nil)
   (dy1 :initform nil)
   (dx2 :initform nil)
   (dy2 :initform nil)

   ;;
   (line :initform (make-array 100 :element-type 'character :adjustable t :fill-pointer 0))

   (lock :initform (make-lock "stream lock"))
   (cache :initform 0) ))

;;;;

(defclass line-output-record ()
  ((cx :initarg :cx)
   (cy :initarg :cy)
   (string :initarg :string)))

;;;; Stream Interface

(defvar *pane*)

(defmethod stream-newline ((stream stream-pane))
  (with-lock-held ((slot-value stream 'lock))
    (with-slots (line output-history cx cy dx1 dy1 dx2 dy2) stream
      (push (make-instance 'line-output-record
                           :cx cx
                           :cy cy
                           :string (copy-seq line))
            output-history)
      (setf (fill-pointer line) 0)
      (setf cx 0
            dx1 (min 0 (or dx1 0))
            dx2 (max 800 (or dx2 800))
            dy1 (min cy (or dy1 cy))
            dy2 (max (+ cy 13) (or dy2 (+ cy 13)))
            cy (+ cy 13)
            )
      (incf (slot-value stream 'cache)) ))
  #+CMU
  (mp:process-yield) )

(defmethod stream-write-char ((stream stream-pane) char)
  (with-slots (line) stream
    (cond ((eql char #\newline)
           (stream-newline stream))
          (t
           (vector-push-extend char line)))))

(defmethod stream-write-string ((stream stream-pane) string &optional start end)
  (setf start (or start 0))
  (setf end (or end (length string)))
  (let ((line (slot-value stream 'line)))
    (let ((m (array-dimension line 0))
          (n (length line)))
      (when (< m (+ n (- end start)))
        (setf line
              (setf (slot-value stream 'line)
                    (adjust-array line (+ n (- end start) 100)
                                  :element-type 'character))))
      (loop for i of-type fixnum from n
            for j of-type fixnum from start below end
            do
            (setf (aref line i) (aref string j)))
      (setf (fill-pointer line) (+ n (- end start))))))

(defmethod stream-line-column ((stream stream-pane))
  (length (slot-value stream 'line)))

;;;;

(defun clear ()
  (with-lock-held ((slot-value *pane* 'lock))
    (with-slots (dx1 dy1 dx2 dy2 cx cy output-history cache) *pane*
      (setf dx1 0 dx2 8000 dy1 0 dy2 #x7fff
            cx 0 cy 0
            output-history nil)
      (incf cache))))

(defun updater ()
  (let ((dpy (xlib:open-display "")))
    (unwind-protect
         (let* ((screen (first (xlib:display-roots dpy)))
                (root   (xlib:screen-root screen))
                (viewport (xlib:create-window :parent root :x 0 :y 0 :width 800 :height 600))
                (canvas   (xlib:create-window :parent viewport :x 0 :y 0 :width 800 :height #x7FFF
                                              :background (xlib:screen-white-pixel screen)
                                              :bit-gravity :north-west))
                (font     (xlib:open-font dpy "fixed"))
                (foo      (xlib:text-width font "foo"))
                (gc       (xlib:create-gcontext :drawable canvas
                                                :font font
                                                :foreground (xlib:screen-black-pixel screen)
                                                :background (xlib:screen-white-pixel screen)))
                (stream *pane*)
                )
           ;;
           (xlib:map-window canvas)
           (xlib:map-window viewport)
           (xlib:display-finish-output dpy)
           (sleep 2)
           ;;
           (let ((old-cache nil))
             (loop
                 (process-wait "waiting for something to happen"
                               (lambda ()
                                 (not (eq old-cache (slot-value stream 'cache)))))
                 ;;
                 (with-lock-held ((slot-value stream 'lock))
                   (update stream
                           canvas gc)
                   (setf old-cache (slot-value stream 'cache)))
               (xlib:display-finish-output dpy)
               ))
                 
           )
      (xlib:close-display dpy))))

(defun update (stream window gc)
  (with-slots (cx cy dx1 dx2 dy1 dy2 output-history) stream
    (setf (xlib:drawable-x window) 10)
    (setf (xlib:drawable-y window) (- (max 0 (- cy 580))))
    (when dx1
      (xlib:clear-area window :x dx1 :y dy1 :width (- dx2 dx1) :height (- dy2 dy1))
      (let ((ccy cy))
        (loop for h in output-history do
              (with-slots (cx cy string) h
                (when (>= cy (- ccy 600)) (<= dy1 cy dy2)
                      (xlib:draw-glyphs window gc cx (+ cy 11) string)))))
      (setf dy1 nil dy2 nil dx1 nil dx2 nil)) ) )

;; Use this to set up things.

(defun dodo ()
  (setf *pane* (make-instance 'stream-pane))
  (make-process (lambda ()
                  (updater)))
  (sleep 2)
  (format *pane* "hi!~%"))

;; Use this for demo:

(defun do-output (s)
  (dotimes (i 1000)
    (format s "~R~%" i)))

(defun bench-1 ()
  (do-output *pane*))

;; silly tests:

(defun ctest ()
  (clear)
  (let ((*error-output* *pane*))
    (compile-file "/home/gilbert/work/clim/McCLIM.table-formatting/panes.lisp" )))

(defun ctest-2 ()
  (with-open-file (*error-output* "/dev/pts/40" :direction :io :if-exists :overwrite)
    (compile-file "/home/gilbert/work/clim/McCLIM.table-formatting/panes.lisp" )) )