;;; lisp file for xyzzy ver0.2.2.234
;;; selection-leave.l ver.0.0.2.6 // crayonzen [2007-01-26]14:24:53(+0900)

;;マウスで選択した範囲を残しておく
;;背景色＞ツール：共通設定：フォント（タグ）：表示色：背景１５
;;未処理： 矩形
;;(provide "mouse")
;;(provide "paragrph")
;;(provide "select")

(provide "selection-leave")

(in-package "editor")

(export '(selection-leave
	  goto-selection-leave
	  back-selection-leave
	  selection-leave-exchange
	  selection-leave-popup
	  goto-selection-leave-or-back
	  *selection-leave*
	  *selection-leave-background-color*
	  set-selection-leave-text-attributes
	  *always-copy-selection*
	  *always-copy-region-to-clipboard*
	  ))

(defvar-local markermp nil)
(defvar-local exmarkpoint nil)
(defvar-local currentp nil)
(define-history-variable *selection-leave* t)
(defvar *selection-leave* t)
(defvar *selection-leave-background-color* 15)
(defvar *always-copy-selection* nil)
(defvar *always-copy-region-to-clipboard* nil)

;;leave
(defun selection-leave (&optional markp pointp)
  (interactive)
  (make-selection-leave-marker)
  (if (pre-selection-p)
      (save-leave-mark-point (selection-mark) (selection-point))
    (if (and markp pointp)
	(save-leave-mark-point markp pointp)))
  )

(defun save-leave-mark-point (&optional markp pointp)
  (if (and markp pointp)
      (progn
	(set-marker (car markermp) markp)
	(set-marker (cdr markermp) pointp)
	(if (null exmarkpoint)
	    (setq exmarkpoint (cons markp pointp))
	  (progn
	    (setf (car exmarkpoint) markp)
	    (setf (cdr exmarkpoint) pointp)
	    ))
	(if *selection-leave*
	    (set-selection-leave-text-attributes))
	(if *always-copy-selection*
	    (copy-selection-leave markp pointp))
	(if *always-copy-region-to-clipboard*
	    (copy-selection-to-clipboard-leave  markp pointp))
	))
  )

(defun make-selection-leave-marker ()
  (if (null markermp)
      (progn
	(setq markp (set-marker (make-marker (selected-buffer))))
	(setq pointp (set-marker (make-marker (selected-buffer))))
	(setq markermp (cons markp pointp))
	))
  )

(defun set-selection-leave-text-attributes ()
  (if markermp
      (progn
	(delete-text-attributes 'selectionleave)
	(set-text-attribute (car markermp) (cdr markermp) 'selectionleave :background *selection-leave-background-color*)))
  )

(defun copy-selection-leave (markp pointp)
  (let ((type (get-selection-type)))
    (if (eql type 3)
	(copy-rectangle markp pointp)
      (progn
	(setq *selection-ring* (push-kill-ring (cons type (buffer-substring markp pointp))
					       *selection-ring*
					       *selection-ring-max*))
	(setq *selection-ring-yank-pointer* *selection-ring*))
      ))
  t)

(defun copy-selection-to-clipboard-leave (markp pointp)
  (let ((type (get-selection-type)))
    (if (eql type 3)
	(let ((*dont-clear-selection* t))
	  (rectangle-selection-to-clipboard #'copy-rectangle-selection))
	(copy-to-clipboard (buffer-substring markp pointp))
      )
    )
  t)

(defun goto-selection-leave ()
  (interactive)
  (if (pre-selection-p)
      ;(continue-pre-selection)
      (back-selection-leave)
    (progn
      (setq currentp (cons (point) (current-line-number)))
      (if (equal (marker-point (car markermp)) (marker-point (cdr markermp)))
	  (progn
	    (set-marker (car markermp) (car exmarkpoint))
	    (set-marker (cdr markermp) (cdr exmarkpoint))
	    ))
      (goto-char (marker-point (car markermp)))
      (start-selection 2 t)
      (goto-char (marker-point (cdr markermp)))

      (if *selection-leave*
	  (set-selection-leave-text-attributes))
      (message "ex-line: ~S" (cdr currentp))
      ))
  )

(defun back-selection-leave ()
  (interactive)
  (if currentp
      (progn
	(stop-selection)
	(goto-char (car currentp))))
  )

;;clear
(defun clear-selection-leave ()
  (interactive)
  (delete-text-attributes 'selectionleave)
  ;(clear-all-text-attributes)
  )

(defun clear-all-selection-leave ()
  (interactive)
  (save-excursion
    (save-window-excursion
      (dolist (buffer (buffer-list))
	(set-buffer buffer)
	(clear-selection-leave))))
  )

;;again
(defun again-all-selection-leave ()
  (interactive)
  (save-excursion
    (save-window-excursion
      (dolist (buffer (buffer-list))
	(set-buffer buffer)
	(set-selection-leave-text-attributes))))
  )

;;leave-exchange
(defun selection-leave-exchange ()
  (interactive)
  (if *selection-leave*
      (progn
	(setq *selection-leave* nil)
	(clear-all-selection-leave))
    (progn
      (setq *selection-leave* t)
      (again-all-selection-leave)))
  )

;;popup
(defun selection-leave-popup ()
  (interactive)
  (track-popup-menu
   (define-popup-menu
     ;;     (:item nil "goto-selection-leave(&L)"
     ;;     (:item nil (format nil "~A~A~A" "goto-selection-leave or back ex-line: "
     ;;			(if (and currentp (pre-selection-p)) (cdr currentp) "") "(&L)")
     (:item nil "goto-selection-leave or back(&L)"
      'goto-selection-leave
      #'(lambda () (unless markermp :disable)))
     ;;     (:item nil (format nil "~A~A~A" "back ex-line: " (if currentp (cdr currentp) "") "(&B)")
     ;;      'back-selection-leave
     ;;      #'(lambda () (unless currentp :disable)))
     (:item nil "view-leave(&V)"
      'selection-leave-exchange
      #'(lambda () (when *selection-leave* :check)))
     )))

;;for key bind
(defun goto-selection-leave-or-back ()
  (interactive)
  (if markermp
      (goto-selection-leave)
    (message "選択されていません"))
  )

;;(global-set-key #\M-e 'selection-leave-popup)
(global-set-key #\M-e 'goto-selection-leave-or-back)
