(in-package :climi)

(define-application-frame foo () ()
  (:panes
   (app :application
    :display-function 'foo-display
    :display-time :command-loop
    :incremental-redisplay t
    )
   (io :interactor))
  (:geometry :width 800 :height 400)
  (:layouts
   (default
       (vertically ()
         app
         (100 io)))))

;;;;;;;;;;;;;;

(defclass standard-output-recording-stream (output-recording-stream)
  ((recording-p :initform t :reader stream-recording-p)
   (drawing-p   :initform t :accessor stream-drawing-p)
   (output-history :initform (make-instance 'standard-tree-output-history)
                   :reader stream-output-history)
   (current-output-record :accessor stream-current-output-record)
   (current-text-output-record :initform nil
                               :accessor stream-current-text-output-record)
   (local-record-p :initform t
                   :documentation "This flag is used for dealing with streams outputting strings char-by-char.")
   (current-line :initform nil)
   ))

;;;;

(defclass stream-line ()
  ((children :initform nil :accessor stream-line-children)
   (baseline :initform 0 :accessor stream-line-baseline)
   (descend :initform 0 :accessor stream-line/descend)))

(defmethod stream-close-line ((stream standard-output-recording-stream))
  (with-slots (current-line) stream
    (setf current-line nil)))

(defmethod stream-current-line ((stream standard-output-recording-stream))
  (with-slots (current-line) stream
    (or current-line
        (setf current-line
              (make-instance 'stream-line)))) )

(defmethod stream-baseline ((stream standard-output-recording-stream))
  (stream-line-baseline (stream-current-line stream)))

(defmethod stream-line/height (line)
  (+ (stream-line-baseline line)
     (stream-line/descend line)))

;;;;;

(defmethod stream-write-char :around ((stream standard-output-recording-stream) char)
  (stream-write-string stream (string char)) )

(defmethod stream-write-string :around ((stream standard-output-recording-stream) string
                                        &optional (start 0) end)
  (setf start (or start 0))
  (setf end (or end (length string)))
  ;; Hmm
  (setf string (subseq string start end)) ;Hmm
  (setf start 0)
  (setf end (length string))
  (let ((p (position #\newline string :start start :end end)))
    (cond (p
           (stream-write-string stream string start p)
           ;;(stream-terpri stream)
           (stream-close-text-output-record stream)
           (let ((dy (+ (stream-line/height (stream-current-line stream))
                        (stream-vertical-spacing stream))))
             (warn "Doing newline DY: ~S." dy)
             ;; Better do newline on our own
             (stream-close-line stream)
             (setf (stream-cursor-position stream)
                   (values 0            ;###
                           (+ (nth-value 1 (stream-cursor-position stream))
                              dy))))
           ;;(seos-write-newline stream)
           (stream-write-string stream string (+ p 1) end)
           ;;(sleep 1)
           )
          ((stream-recording-p stream)
           (let ()
             (when (stream-recording-p stream)
               (let* ((ts (medium-text-style stream))
                      (or (stream-text-output-record stream (medium-text-style stream)))
                      (line (stream-current-line stream)))
                 (setf (slot-value or 'my-line) line)
                 (setf (stream-line-baseline line)
                       (max (stream-line-baseline line)
                            (text-style-ascent ts stream)))
                 (setf (stream-line/descend line)
                       (max (stream-line/descend line)
                            (text-style-descent ts stream)))
                 ;; Baseline might have moved ...
                 (loop for record in (stream-line-children line) do
                       (let ((old-bounds (multiple-value-list (bounding-rectangle* record)))
                             new-bounds)
                         (tree-recompute-extent record)
                         (setf new-bounds (multiple-value-list (bounding-rectangle* record)))
                         '(warn "Old: ~S, New: ~S." old-bounds new-bounds)
                         (let ((dirty (region-union (apply #'make-rectangle* old-bounds)
                                                    (apply #'make-rectangle* new-bounds))))
                           '(warn "Dirty: ~S." dirty)
                           '(draw-design (sheet-medium stream)
                                        dirty
                                        :ink +red+)
                           '(with-output-recording-options (stream :record nil :draw t)
                             (replay (stream-output-history stream) stream dirty)))
                         ))
                 (add-string-output-to-text-record or string (or start 0) (or end (length string))
                                                   ts
                                                   (stream-string-width stream string
                                                                        :start start :end end)
                                                   (text-style-height ts stream)
                                                   (stream-baseline stream)
                                                   )
                 (describe or *trace-output*)
                 (cond ((stream-drawing-p stream)
                        (call-next-method))
                       (t
                        ;; hmm, we'd need to emulate cursor movement
                        (stream-increment-cursor-position stream (stream-string-width stream string :start start :end end)
                                                          0) ;###
                        ))
                 
                 (pushnew or (stream-line-children line)) ))))
          ((stream-drawing-p stream)
           (call-next-method)) )) )

(defmethod stream-terpri ((stream output-recording-stream))
  (warn "terpri"))

(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)))
  (seos-write-newline stream)
  '(stream-write-char stream #\newline))

(defvar *foo-process* nil)

(defun foo ()
  (when *foo-process*
    (mp:destroy-process *foo-process*))
  (setf *foo-process*
        (mp:make-process (lambda ()
                           (run-frame-top-level
                            (make-application-frame 'foo))))))

(defun foo-display (*application-frame* *standard-output*)
  (write-string "foo ")
  (with-output-as-presentation (t '(com-foo) 'command)
    (with-text-size (t :huge)
      (write-string "Hit ge!")))
  (terpri))

(defun foo-display (*application-frame* *standard-output*)
  (write-string "Click here: ")
  (with-text-size (t :huge)
    (write-string "Hit ge!"))
  (terpri)
  (progn
    (write-string "Click here: ")
    (princ " ")
    (with-output-as-presentation (t '(com-foo) 'command)
      (write-string "or here"))
    (princ " ")
    (with-output-as-presentation (t '(com-foo) 'command)
      (with-text-size (t :huge)
        (write-string "Hit ge!")))
    (princ " ")
    (with-output-as-presentation (t '(com-foo) 'command)
      (write-string "or here"))
    (princ " ")
    (write-string " (NO, don't).")
    (terpri))
  (progn
    (write-string "Click here: ")
    (surrounding-output-with-border (t)
      (with-text-size (t :huge)
        (write-string "Hit me!")))
    (write-string " (NO, don't).")
    (terpri))
  )

(defclass styled-string (gs-text-style-mixin gs-clip-mixin gs-ink-mixin)
  ((start-x :initarg :start-x)
   (string :initarg :string :reader styled-string-string)))

(defmethod print-object ((object styled-string) stream)
  (print-unreadable-object (object stream :type t :identity nil)
    (format stream "~S ~S"
            (if (slot-boundp object 'string)
                (slot-value object 'string)
                "(unbound)")
            (slot-value object 'text-style))))

(defmethod stream-write-output :around ((stream standard-output-recording-stream)
                                        line string-width &optional (start 0) end)
  (call-next-method))

#+NIL
(define-foo-command (com-boo :name t) ()
  (clouseau:inspector (stream-output-history *standard-output*)))

(defmethod replay-output-record ((record standard-text-displayed-output-record)
				 stream
				 &optional region (x-offset 0) (y-offset 0))
  (declare (ignore region x-offset y-offset))
  (with-slots (strings baseline max-height start-y wrapped)
      record
    (with-sheet-medium (medium stream) ;is sheet a sheet-with-medium-mixin? --GB
      ;; FIXME:
      ;; 1. SLOT-VALUE...
      ;; 2. It should also save a "current line".
      (setf (slot-value stream 'baseline) baseline)
      (loop for substring in strings
	    do (with-slots (start-x string)
		   substring
		 (setf (stream-cursor-position stream)
		       (values start-x start-y))
		 (set-medium-graphics-state substring medium)
                 (setf (slot-value stream 'baseline)
                       (stream-line-baseline (slot-value record 'my-line)))
                 (with-output-recording-options (stream :record nil)
                   (stream-write-string stream string))))
      (when wrapped			; FIXME
	(draw-rectangle* medium
			 (+ wrapped 0) start-y
			 (+ wrapped 4) (+ start-y max-height)
			 :ink +foreground-ink+
			 :filled t)))))

(define-foo-command (com-puh :name t) ()
  (with-output-recording-options (t :record nil)
    (terpri)
    (write-string "foo")
    (warn "~S" (stream-baseline *standard-output*))
    (with-text-size (t :huge)
      (write-string "Buh!"))
    (warn "~S" (stream-baseline *standard-output*))
    (terpri)))

(defclass standard-text-displayed-output-record
    (text-displayed-output-record standard-displayed-output-record)
  ((initial-x1 :initarg :start-x)
   (initial-y1 :initarg :start-y)
   (strings :initform nil)
   (baseline :initform 0)
   (width :initform 0)
   (max-height :initform 0)
   (start-x :initarg :start-x)
   (start-y :initarg :start-y)
   (end-x :initarg :start-x)
   (end-y :initarg :start-y)
   (wrapped :initform nil
	    :accessor text-record-wrapped)
   (medium :initarg :medium :initform nil)
   (my-base-line :initform 0)
   (my-line :initform nil)
   ))


;;;;;;;;;;;;

(defmethod tree-recompute-extent ((text-record standard-text-displayed-output-record))
  (with-slots (medium baseline max-height start-x start-y end-x end-y strings) text-record
    (let ((as 0)
          (ds 0))
      (loop for string in strings do
            (with-slots (text-style) string
              (maxf as (text-style-ascent text-style medium))
              (maxf ds (text-style-descent text-style medium))))
      (warn "start-y: ~S AS: ~S, DS: ~S, BL: ~S  / ~S;" start-y as ds
            (stream-line-baseline (slot-value text-record 'my-line))
            strings)
      (let ((baseline (stream-line-baseline (slot-value text-record 'my-line))))
        (setf (rectangle-edges* text-record)
              (values start-x (+ start-y baseline (- as))
                      end-x   (+ start-y baseline ds)) )))))

(defmethod add-string-output-to-text-record ((text-record standard-text-displayed-output-record)
                                             string start end text-style string-width height new-baseline)
  (setf end (or end (length string)))  
  (let ((length (max 0 (- end start))))
    (cond
      ((eql length 1)
       (add-character-output-to-text-record text-record
                                            (aref string start)
                                            text-style
                                            string-width height new-baseline))
      (t (with-slots (strings baseline width max-height start-y end-x end-y
		      medium)
	     text-record
	   (let ((styled-string (make-instance 'styled-string
                                               :start-x end-x
                                               :text-style text-style
                                               :medium medium
                                               :string (make-array length
                                                                   :element-type 'character
                                                                   :adjustable t
                                                                   :fill-pointer t))))
	     (nconcf strings (list styled-string))
	     (replace (styled-string-string styled-string) string
		      :start2 start :end2 end))
	   (setq baseline (max baseline new-baseline)
		 end-x (+ end-x string-width)
		 max-height (max max-height height)
		 end-y (max end-y (+ start-y max-height))
		 width (+ width string-width)))
       (tree-recompute-extent text-record)))))