(in-package :climi)

(defclass cut-and-paste-mixin ()
  ((marks :initform nil
          :documentation "A list of marked stuff. Currently a list of (x y string ts substring-output-record).")))

(defclass standard-output-recording-stream (output-recording-stream
                                            cut-and-paste-mixin)
  ((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.")
   ))

(in-package :clim-clx)

(defclass clx-port (basic-port)
  ((display :initform nil
	    :accessor clx-port-display)
   (screen :initform nil
	   :accessor clx-port-screen)
   (window :initform nil
	   :accessor clx-port-window)
   (color-table :initform (make-hash-table :test #'eq))
   (modifier-cache :initform nil
		   :accessor clx-port-modifier-cache)
   (design-cache :initform (make-hash-table :test #'eq))
   (pointer :reader port-pointer)
   ;;; New:
   (climi::selection-owner :initform nil)
   ))

(in-package :climi)

(defvar *drag-start-x* nil)
(defvar *drag-start-y* nil)
(defvar *old-x1* nil)
(defvar *old-y1* nil)

(defun blah ()
  (clim:destroy-port (clim:find-port))
  (setf *drag-start-x* nil
        *drag-start-y* nil)
  (cl-user::ab))

(defmethod clim:dispatch-event ((pane extended-output-stream)
                                (event pointer-button-press-event))
  (if (eql (event-modifier-state event) +shift-key+)
      (eos/shift-click pane event)
      (call-next-method)))

(defmethod clim:dispatch-event ((pane extended-output-stream)
                                (event pointer-button-release-event))
  (if (eql (event-modifier-state event) +shift-key+)
      (eos/shift-release pane event)
      (call-next-method)))

(defmethod clim:dispatch-event ((pane extended-output-stream)
                                (event pointer-motion-event))
  (if (and (eql (event-modifier-state event) +shift-key+))
      (when *drag-start-x*
        (eos/shift-drag pane event))
      (call-next-method)))

(defmethod eos/shift-click ((pane extended-output-stream) event)
  event
  (cond ((eql 1 (pointer-event-button event))
         ;; start dragging
         (setf *old-x1* (setf *drag-start-x* (pointer-event-x event)))
         (setf *old-y1* (setf *drag-start-y* (pointer-event-y event))))
        ((eql 2 (pointer-event-button event))
         (xlib:convert-selection :primary :UTF8_STRING (sheet-direct-mirror pane) :bounce (event-timestamp event)))
        )
  )

(defmethod eos/shift-release ((pane extended-output-stream) event)
  event
  (when *DRAG-START-X*
    (setf *drag-start-x* nil)
    ;;
    (let ((owner (slot-value (port pane) 'selection-owner)))
      (when (and owner (not (eq owner pane)))
        (distribute-event (port pane)
                          (make-instance 'selection-clear-event
                                         :sheet owner
                                         :selection :primary))))
    (xlib:set-selection-owner
     (xlib:window-display (sheet-direct-mirror pane))
     :primary
     (sheet-direct-mirror pane))
    ;; ### check that we get it ...
    ;; ### timestamp
    (setf (slot-value (port pane) 'selection-owner) pane)
    ;;
    ))

(defvar *marks* nil)

(defmethod eos/shift-drag ((pane extended-output-stream) event)
  (let ((r (make-rectangle* *drag-start-x* *drag-start-y*
                            (pointer-event-x event)
                            (pointer-event-y event))))
    (setup-marked-extents pane (stream-output-history pane) r
                   *drag-start-x* *drag-start-y*
                   (pointer-event-x event)
                   (pointer-event-y event)       )
    (let ((ro (make-rectangle*
               *drag-start-x* *drag-start-y*
               *old-x1* *old-y1*)))
      #+NIL
      (draw-rectangle*
       (sheet-medium pane)
       *drag-start-x* *drag-start-y*
       *old-x1* *old-y1*
       :ink +red+)
      (unless (eq r +nowhere+)
        (handle-repaint pane
                        (make-rectangle* 0 0 1000 2000)
                        #+NIL +everywhere+
                        #+NIL (region-union r ro)))))
  (setf *old-x1* (pointer-event-x event))
  (setf *old-y1* (pointer-event-y event))
  '(draw-rectangle* (sheet-medium pane)
                   *drag-start-x* *drag-start-y*
                   (setf *old-x1* (pointer-event-x event))
                   (setf *old-y1* (pointer-event-y event))
                   :ink +flipping-ink+))

;;;;;;;

(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)
   (marked-extent
    :initform nil
    :accessor styled-string-marked-extent
    :documentation "Either NIL or a pair (START . END) of the part of the styled string that is currently marked."
    )))

(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 x1 y1) 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)
		 (stream-write-output stream string)))
      ;; First paint the possible markings
      (loop for substring in strings do
            (with-slots (start-x string marked-extent text-style) substring
              (when marked-extent
                (draw-rectangle* medium
                                 (+ start-x (stream-string-width stream string
                                                                 :start 0 :end (car marked-extent)
                                                                 :text-style text-style))
                                 (+ start-y baseline
                                    (- (text-style-ascent text-style medium))
                                    (- 1))
                                 (+ start-x (stream-string-width stream string
                                                                 ;;:start (car marked-extent)
                                                                 :end (cdr marked-extent)
                                                                 :text-style text-style))
                                 (+ start-y baseline
                                    (text-style-descent text-style medium)
                                    1)
                                 :ink +flipping-ink+ #+NIL(make-rgb-color .5 .5 1)))))
      ;;
      (when wrapped			; FIXME
	(draw-rectangle* medium
			 (+ wrapped 0) start-y
			 (+ wrapped 4) (+ start-y max-height)
			 :ink +foreground-ink+
			 :filled t)))))

;; A completely different approach ...

(defun map-over-text (record function)
  (cond ((typep record 'standard-text-displayed-output-record)
         (with-slots (strings baseline max-height start-y wrapped x1 y1) record
           (loop for substring in strings do
                 (with-slots (start-x string marked-extent text-style) substring
                   (funcall function start-x (+ start-y baseline) string text-style
                            substring)))))
        (t
         (map-over-output-records-overlapping-region
          #'(lambda (x)
              (map-over-text x function))
          record +everywhere+))))

(defun setup-marked-extents (stream record region bx1 by1 bx2 by2)
  (cond ((> by1 by2)
         (rotatef by1 by2)
         (rotatef bx1 bx2))
        (t
         nil))
  #+NIL
  (psetf bx1 (min bx1 bx2) bx2 (max bx1 bx2)
         by1 (min by1 by2) by2 (max by1 by2))
  (let ((*lines* nil)
        (*all-lines* nil))
    (map-over-text (stream-output-history stream)
                   (lambda (x y string ts record)
                     (let ((q (assoc y *lines*)))
                       (unless q
                         (push (setf q (cons y nil)) *lines*))
                       (push (list x y string ts record)
                             (cdr q)))
                     (finish-output *trace-output*)))
    (setf *lines*
          (sort (mapcar (lambda (line)
                          (cons (car line)
                                (sort (cdr line) #'< :key #'first)))
                        *lines*)
                #'< :key #'car))
    (setf *all-lines* *lines*)
    ;; Nuke every line that is above by1
    (setf *lines* (remove-if (lambda (line) (< (+ (car line) 3) by1)) *lines*))
    ;; Also nuke all that are below by2
    (setf *lines* (remove-if (lambda (line) (> (- (car line) 10) by2)) *lines*))
    ;; Special case:
    (when (= 1 (length *lines*))
      (psetf bx1 (min bx1 bx2)
             bx2 (max bx1 bx2)))
    ;; Then, in the first line find the index farthest to the right
    ;; which is still less than bx1.
    (let ((start-i 0)
          (start-record (fifth (cdar *lines*)))
          (end-i 0)
          end-record)

      ;; Then, in the first line find the index farthest to the right
      ;; which is still less than bx1.
      (loop for chunk in (cdr (first *lines*)) do
            (destructuring-bind (x y string ts record) chunk
              (loop for i to (length string) do
                    (when (< (+ x (stream-string-width stream string :start 0 :end i :text-style ts))
                             bx1)
                      (setf start-i i
                            start-record record)))))

      ;; Finally in the last line find  the index farthest to the left which still is greater than bx2.
      ;; Or put differently: Search from the left and while we are still in bounds maintain end-i and end-record.
      (loop for chunk in (cdr (car (last *lines*))) do
            (destructuring-bind (x y string ts record) chunk
              (loop for i to (length string) do
                    (when (< (+ x (stream-string-width stream string :start 0 :end i :text-style ts))
                             bx2)
                      (setf end-i i
                            end-record record)))))
      ;; Now, humble grovel over the records, in order ...
      (let ((in-p nil)
            (marks nil))
        (labels ((visit (chunk)
                   (destructuring-bind (x y string ts record) chunk
                     (cond ((eq record start-record)
                            (cond ((eq record end-record)
                                   (setf (slot-value record 'marked-extent)
                                         (cons start-i end-i)))
                                  (t
                                   (setf (slot-value record 'marked-extent)
                                         (cons start-i (length string)))
                                   (setf in-p t))))
                           ((eq record end-record)
                            (setf (slot-value record 'marked-extent)
                                  (cons 0 end-i))
                            (setf in-p nil))
                           (t
                            (setf (slot-value record 'marked-extent)
                                  (if in-p
                                      (cons 0 (length string))
                                      nil))) )
                     (when (slot-value record 'marked-extent)
                       (push chunk marks))
                     #+NIL
                     (when (slot-value record 'marked-extent)
                       (princ (subseq string
                                      (car (slot-value record 'marked-extent))
                                      (cdr (slot-value record 'marked-extent)))
                              *trace-output*))
                     )))
          (loop for line in *all-lines* do
                (loop for chunk in (cdr line) do
                      (visit chunk)) )
          (setf (slot-value stream 'marks) (reverse marks))
          )) )))


;;;; Selections Events

;; These events are probably very X11 specific.

(defclass selection-event (window-event)
  ((selection :initarg :selection
              :reader selection-event-selection) ))

(defclass selection-clear-event (selection-event)
  ())

(defclass selection-notify-event (selection-event)
  ((target   :initarg :target
             :reader selection-event-target)
   (property :initarg :property
             :reader selection-event-property)))

(defclass selection-request-event (selection-event)
  ((requestor :initarg :requestor
              :reader selection-event-requestor)
   (target    :initarg :target
              :reader selection-event-target)
   (property  :initarg :property
              :reader selection-event-property)))

(defmethod clim:dispatch-event ((pane extended-output-stream)
                                (event selection-clear-event))
  (with-slots (marks) pane
    (dolist (m marks)
      (setf (slot-value (fifth m) 'marked-extent) nil)))
  (handle-repaint pane (sheet-region pane))
  (setf (slot-value (port pane) 'selection-owner) nil) )

(defmethod clim:dispatch-event ((pane extended-output-stream)
                                (event selection-request-event))
  (warn "Selection request")
  (let ((requestor (selection-event-requestor event))
        (property  (selection-event-property event))
        (target    (selection-event-target event))
        (time      (event-timestamp event)))
    (xlib:change-property requestor property
                          (map 'list #'char-code (fetch-selection pane target))
                          target        ;###
                          8)            ;
    (xlib:send-event requestor
                     :selection-notify nil
                     :window requestor
                     :selection :primary
                     :target target
                     :property property
                     :time time)
    (xlib:display-force-output (xlib:window-display requestor))))

(defmethod clim:dispatch-event ((pane extended-output-stream)
                                (event selection-notify-event))
  (cond ((selection-event-property event)
         (let ((matter
                (map 'string #'code-char
                     (xlib:get-property (sheet-direct-mirror pane)
                                        (selection-event-property event)
                                        ;; :type :text
                                        :delete-p t
                                        :result-type 'vector))))
           (format *trace-output*
                   "Got ~S.~%"
                   matter)
           (loop for c across matter do
                 (dispatch-event pane
                                 (make-instance 'key-press-event
                                                :timestamp (event-timestamp event)
                                                :sheet pane
                                                :modifier-state 0
                                                :x 0 :y 0 :graft-x 0 :graft-y 0
                                                :key-name nil
                                                :key-character c)))
           ))
        (t
         (warn "Got nothing."))))

(defun fetch-selection (pane target)
  (let (old-y)
    (with-output-to-string (bag)
      (with-slots (marks) pane
        (dolist (m marks)
          (destructuring-bind (x y string ts record) m
            (when (and old-y (> y old-y))
              (warn "terpri")
              (terpri bag))
            (setf old-y y)
            (princ (subseq string
                           (car (slot-value record 'marked-extent))
                           (cdr (slot-value record 'marked-extent)))
                   bag)))))))

(in-package :clim-clx)

(defun event-handler (&rest event-slots
                      &key display window event-key code state mode time
		      width height x y root-x root-y
		      data override-redirect-p send-event-p
		      hint-p type
                      target property requestor selection
                      &allow-other-keys)
  ;; NOTE: Although it might be tempting to compress (consolidate)
  ;; events here, this is the wrong place. In our current architecture
  ;; the process calling this function (the port's event handler
  ;; process) just reads the events from the X server, and does it
  ;; with almost no lack behind the reality. While the application
  ;; frame's event top level loop does the actual processing of events
  ;; and thus may produce lack. So the events have to be compressed in
  ;; the frame's event queue.
  ;;
  ;; So event compression is implemented in EVENT-QUEUE-APPEND.
  ;;
  ;; This changes for possible _real_ immediate repainting sheets,
  ;; here a possible solution for the port's event handler loop can be
  ;; to read all available events off into a temponary queue (and
  ;; event compression for immediate events is done there) and then
  ;; dispatch all events from there as usual.
  ;;
  ;;--GB
  
  ;; XXX :button code -> :button (decode-x-button-code code)
  (declare (ignorable event-slots))
  (declare (special *clx-port*))
  (let ((sheet (and window
		    (port-lookup-sheet *clx-port* window))))
    (when sheet
      (case event-key
	((:key-press :key-release)
         (multiple-value-bind (keyname modifier-state)
	     (x-event-to-key-name-and-modifiers *clx-port* 
						event-key code state)
           (make-instance (if (eq event-key :key-press)
			      'key-press-event
			      'key-release-event)
             :key-name keyname
	     :key-character (and (characterp keyname) keyname)
	     :x x :y y
	     :graft-x root-x
	     :graft-y root-y
             :sheet sheet :modifier-state modifier-state :timestamp time)))
	((:button-press :button-release)
	 (let ((modifier-state (x-event-state-modifiers *clx-port* state)))
	   (make-instance (if (eq event-key :button-press)
			      'pointer-button-press-event
			      'pointer-button-release-event)
			  :pointer 0
			  :button (decode-x-button-code code) :x x :y y
			  :graft-x root-x
			  :graft-y root-y
			  :sheet sheet :modifier-state modifier-state
			  :timestamp time)))
	(:enter-notify
	 (make-instance 'pointer-enter-event :pointer 0 :button code :x x :y y
                        :graft-x root-x
                        :graft-y root-y
			:sheet sheet
			:modifier-state (x-event-state-modifiers *clx-port*
								 state)
			:timestamp time))
	(:leave-notify
	 (make-instance (if (eq mode :ungrab)
			    'pointer-ungrab-event
			    'pointer-exit-event)
			:pointer 0 :button code
			:x x :y y
			:graft-x root-x
			:graft-y root-y
			:sheet sheet
			:modifier-state (x-event-state-modifiers *clx-port*
								 state)
			:timestamp time))
        ;;
	(:configure-notify
         ;; it would be nice to consolidate these for resizes, but because of the
         ;; interleaving exposures it becomes a bit tricky to do at this point. - BTS
         (cond ((and (eq (sheet-parent sheet) (graft sheet))
                     (not override-redirect-p)
                     (not send-event-p))
                ;; this is genuine event for a top-level sheet (with
                ;; override-redirect off)
                ;;
                ;; Since the root window is not our real parent, but
                ;; there the window managers decoration in between,
                ;; only the size is correct, so we need to deduce the
                ;; position from our idea of it.
                (multiple-value-bind (x y) (transform-position
                                            (compose-transformations
                                             (sheet-transformation sheet)
                                             (sheet-native-transformation (graft sheet)))
                                            0 0)
                  (make-instance 'window-configuration-event
                                 :sheet sheet
                                 :x x
                                 :y y
                                 :width width :height height)))
               (t
                ;; nothing special here
                (make-instance 'window-configuration-event
                               :sheet sheet
                               :x x :y y :width width :height height))))
	(:destroy-notify
	 (make-instance 'window-destroy-event :sheet sheet))
	(:motion-notify
	 (let ((modifier-state (x-event-state-modifiers *clx-port*
							state)))
	   (if hint-p
	       (multiple-value-bind (x y same-screen-p child mask
				     root-x root-y)
		   (xlib:query-pointer window)
		 (declare (ignore mask))
		 ;; If not same-screen-p or the child is different
		 ;; from the original event, assume we're way out of date
		 ;; and don't return an event.
		 (when (and same-screen-p (not child))
		   (make-instance 'pointer-motion-hint-event
				  :pointer 0 :button code
				  :x x :y y
				  :graft-x root-x :graft-y root-y
				  :sheet sheet
				  :modifier-state modifier-state
				  :timestamp time)))
	       (progn
		 (make-instance 'pointer-motion-event
				:pointer 0 :button code
				:x x :y y
				:graft-x root-x
				:graft-y root-y
				:sheet sheet
				:modifier-state modifier-state
				:timestamp time)))))
        ;;
	((:exposure :display)
         ;; Notes:
         ;; . Do not compare count with 0 here, last rectangle in an
         ;;   :exposure event sequence does not cover the whole region. 
         ;;
         ;; . Do not transform the event region here, since
         ;;   WINDOW-EVENT-REGION does it already. And rightfully so. 
         ;;   (think about changing a sheet's native transformation).
         ;;--GB
         ;;
         ;; Mike says:
         ;;   One of the lisps is bogusly sending a :display event instead of an
         ;; :exposure event. I don't remember if it's CMUCL or SBCL. So the
         ;; :display event should be left in.
         ;;
         (make-instance 'window-repaint-event
           :timestamp time
           :sheet sheet
           :region (make-rectangle* x y (+ x width) (+ y height))) )
        ;;
        (:selection-notify
         (make-instance 'climi::selection-notify-event
          :sheet sheet
          :selection selection
          :target target
          :property property))
        (:selection-clear
         (make-instance 'climi::selection-clear-event
          :sheet sheet
          :selection selection))
        (:selection-request
         (make-instance 'climi::selection-request-event
          :sheet sheet
          :selection selection
          :requestor requestor
          :target target
          :property property
          :timestamp time))
	(:client-message
         (port-client-message sheet time type data))
	(t
	 nil)))))

(defmethod port-client-message (sheet time (type (eql :wm_protocols)) data)
  (port-wm-protocols-message sheet time
                             (xlib:atom-name (slot-value *clx-port* 'display) (aref data 0))
                             data))

(defmethod port-client-message (sheet time (type t) data)
  (warn "Unprocessed client message: ~:_type = ~S;~:_ data = ~S;~_ sheet = ~S."
        type data sheet))

(defmethod port-wm-protocols-message (sheet time (message (eql :wm_delete_window)) data)
  (declare (ignore data))
  (make-instance 'window-manager-delete-event
                 :sheet sheet
                 :timestamp time))

(defmethod port-wm-protocols-message (sheet time (message t) data)
  (warn "Unprocessed WM Protocols message: ~:_message = ~S;~:_ data = ~S;~_ sheet = ~S."
        message data sheet))