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

(in-package :clim-tty)

(defvar *the-port* nil)

(defvar *tty* nil)

(defclass tty-port (basic-port)
  ((frame-manager)
   (grafts
    :initarg :grafts
    :reader climi::port-grafts)
   (mirror-hash
    :initform (make-hash-table :test #'eq))
   (input-focus
    :initform nil
    :accessor climi::port-keyboard-input-focus)
   (event-process
    :accessor port-event-process)
   ))

(defclass tty-graft (graft)
  ((port :reader port :initarg :port)
   (climi::mirror :initform nil)))

(defmethod graft-orientation ((graft tty-graft))
  :default)

(defmethod graft-units ((graft tty-graft))
  :device)

(defmethod graft-width ((graft tty-graft) &key (units :device))
  (* +cell-width+ 96))

(defmethod graft-height ((graft tty-graft) &key (units :device))
  (* +cell-height+ 65))

(defun find-port (&key server-path)
  (or *the-port*
      (setf *the-port*
            (let ((r (make-instance 'tty-port)))
              (setf (slot-value r 'grafts)
                    (list (make-instance 'tty-graft :port r)))
              (let ((g (first (slot-value r 'grafts))))
                (realize-mirror r g)
                (setf (slot-value g 'climi::mirror) (climi::port-lookup-mirror r g))
                (print (slot-value g 'climi::mirror))
                (setf (sheet-region g) (make-rectangle* 0 0 1000 1000)))
              (setf (slot-value r 'frame-manager)
                    (make-instance 'tty-frame-manager :port r))
              (setf (port-event-process r)
                    (clim-sys:make-process
                     (lambda ()
                       (loop
                           (with-simple-restart
                               (restart-event-loop
                                "Restart CLIM's event loop.")
                             (loop
                                 (climi::process-next-event r)))))
                     :name (format nil "~S's event process." r)))
              r))))

;;; Frame Manager

(defclass tty-frame-manager (frame-manager)
  ((port :reader port :initarg :port)))

(defmethod climi::frame-managers ((port tty-port))
  (list (slot-value port 'frame-manager)))

(defmethod make-pane-1 ((fm tty-frame-manager) (frame application-frame) type &rest args)
  (apply #'make-instance
	 (or (find-symbol (concatenate 'string "TTY-" (symbol-name type)) :climi)
	     (find-symbol (concatenate 'string "TTY-" (symbol-name type) "-PANE") :climi)
	     (find-symbol (concatenate 'string (symbol-name type) "-PANE") :climi)
	     type)
	 :frame frame
	 :manager fm
	 :port (port frame)
	 args))

;;; Media

(defconstant +cell-height+ 13)
(defconstant +cell-width+ 6)

(defclass tty-medium (basic-medium)
  ())

(defmethod make-medium ((port tty-port) sheet)
  (make-instance 'tty-medium
                 :sheet sheet))

(defmethod text-style-ascent (text-style (medium tty-medium))
  +cell-height+)

(defmethod text-style-height (text-style (medium tty-medium))
  +cell-height+)

(defmethod text-style-descent (text-style (medium tty-medium))
  0)


#|
the total width of the string in device units, 
the total height of the string in device units, 
the final x cursor position
the final y cursor position
and the string's baseline.
|#

(defmethod text-size ((medium tty-medium) string &key text-style start end)
  (when (characterp string)
    (setf string (string string)))
  (setf start (or start 0))
  (setf end (or end (length string)))
  (values (* +cell-width+ (- end start)) +cell-height+
          (* +cell-width+ (- end start)) 0
          0))

;;;

(defmethod medium-draw-rectangle* ((medium tty-medium) x1 y1 x2 y2 filledp)
  )

(defmethod medium-draw-polygon* ((medium tty-medium) coord-seq closed filledp)
  )

(defmethod medium-draw-text* ((medium tty-medium) string x y start end align-x align-y toward-x
                              toward-y transform-glyphs)
  (setf string (subseq string start end))
  (let* ((sheet (medium-sheet medium))
         (mirror (sheet-mirror sheet)))
    (multiple-value-bind (x y) (transform-position (mirror-device-transformation mirror)
                                                   x y)
      '(print (list :draw-text x y
                   '=
                   (floor x +cell-width+) (floor y +cell-height+)
                   string
                   (mirror-device-region mirror)
                   (mirror-device-transformation mirror)
                   (tty-mirror-region mirror)
                   (sheet-enabled-p sheet)
                   (region-contains-position-p (mirror-device-region mirror) x y)
                   )
             *trace-output*)
      (finish-output *trace-output*)
      (when (region-contains-position-p (mirror-device-region mirror) x y)
        (princ #\escape *tty*)
        (princ #\[ *tty*)
        (prin1 (floor y +cell-height+) *tty*)
        (princ #\; *tty*)
        (prin1 (floor x +cell-width+) *tty*)
        (princ #\H *tty*)
        (princ string *tty*)
        (finish-output *tty*)
        '(sleep 1))
      (finish-output *tty*)
      )))

(defun clear ()
  (format *tty* "~A[H~A[J" #\escape #\escape)
  (finish-output *tty*))

;;;

(defmethod climi::port-lookup-mirror ((port tty-port) sheet)
  (gethash sheet (slot-value port 'mirror-hash)))

(defmethod climi::port-register-mirror ((port tty-port) sheet mirror)
  )

(defclass tty-mirror ()
  ((sheet :initarg :sheet)
   ))

(defun tty-mirror-transformation (mirror)
  (with-slots (sheet) mirror
    (sheet-transformation sheet)))

(defun tty-mirror-region (mirror)
  (with-slots (sheet) mirror
    (sheet-region sheet)))

(defun tty-mirror-parent (mirror)
  (with-slots (sheet) mirror
    (climi::port-lookup-mirror (port sheet) (sheet-parent sheet))))

(defun tty-mirror-children (mirror)
  (with-slots (sheet) mirror
    (mapcar (lambda (child)
              (climi::port-lookup-mirror (port child) child))
            (sheet-children sheet))))

(defun tty-mirror-enablep (mirror)
  (with-slots (sheet) mirror
    (sheet-enabled-p sheet)))

(defun mirror-occluded-mirrors (mirror)
  (and 
   (tty-mirror-parent mirror)
   (cdr (member mirror (tty-mirror-children (tty-mirror-parent mirror))))))

(defun mirror-occluding-mirrors (mirror)
  (and 
   (tty-mirror-parent mirror)
   (loop for x in (tty-mirror-children (tty-mirror-parent mirror))
         until (eq x mirror)
         collect x)))

(defun mirror-compute-device-region (mirror)
  (if (tty-mirror-enablep mirror)
      (let ((r (region-intersection (transform-region (mirror-device-transformation mirror)
                                                      (tty-mirror-region mirror))
                                    (if (tty-mirror-parent mirror)
                                        (mirror-device-region (tty-mirror-parent mirror))
                                        +everywhere+))))
        (when (tty-mirror-parent mirror)
          (dolist (k (mirror-occluding-mirrors mirror))
            (setf r (region-difference r (mirror-device-region k)))))
        r)
      +nowhere+))

(defun mirror-device-region (mirror)
  (mirror-compute-device-region mirror))

(defun mirror-device-transformation (mirror)
  (mirror-compute-device-transformation mirror))

(defun mirror-compute-device-transformation (mirror)
  (let ((parent (tty-mirror-parent mirror)))
    (if parent
        (compose-transformations
         (mirror-device-transformation parent)
         (tty-mirror-transformation mirror))
        +identity-transformation+)))

(defmethod realize-mirror ((port tty-port) sheet)
  ;; -> mirror
  (prog1
      (setf (gethash sheet (slot-value port 'mirror-hash))
            (make-instance 'tty-mirror
                           :sheet sheet
                           ;;:device-transformation nil
                           ;;:device-region nil
                           ))
    '(handle-repaint sheet +everywhere+)))

(defmethod climi::port-set-mirror-region ((port tty-port) sheet region)
  '(when (tty-mirror-enablep sheet)
    (handle-repaint (slot-value sheet 'sheet) +everywhere+))
  )

(defmethod climi::port-set-mirror-transformation ((port tty-port) sheet transformation)
  (when (tty-mirror-enablep sheet)
    '(clear)
    (queue-repaint (slot-value sheet 'sheet)
                   (make-instance 'WINDOW-REPAINT-EVENT
                                  :sheet (slot-value sheet 'sheet)
                                  :region +everywhere+))
    (finish-output *tty*)) )

(defmethod climi::port-enable-sheet ((port tty-port) sheet)
  )

(defmethod climi::port-disable-sheet ((port tty-port) sheet)
  )

(defmethod climi::destroy-mirror ((port tty-port) sheet)
  (remhash sheet (slot-value port 'mirror-hash)))

(defmethod climi::get-next-event ((port tty-port) &key wait-function timeout)
  (let ((c (read-char *tty*)))
    (let (s)
      (labels ((walk (x)
                 (print x *trace-output*)
                 (cond ((typep x 'CLIM:INTERACTOR-PANE)
                        (setf s x)
                        x)
                       (t
                        (some #'walk (sheet-children x))))))
        (walk (first  (climi::port-grafts port)))
        (print s *trace-output*)
        (finish-output *trace-output*))
      (make-instance 'key-press-event
                     :key-name c
                     :key-character c
                     :sheet s
                     :modifier-state 0
                     :x 0 :y 0 :graft-x 0 :graft-y 0))))

(defun x ()
  (setf *the-port* nil)
  (unless *tty*
    (setf *tty* (xterm:open-terminal :title "CLIM")))
  (clim-user::fold))

(defmethod climi::MEDIUM-COPY-AREA ((x BASIC-MEDIUM) X1 X2 X3 X4 X5 X6 X7)
  (warn "lost"))