;;; lisp file for xyzzy ver0.2.2.234
;;; hmark.l ver.0.1.6.4 // crayonzen [2024-12-26]16:07:37(+0900)キーバインド変更
;;; hmark.l ver.0.1.6.3 // crayonzen [2023-03-13]09:27:45(+0900)キーバインド変更追加
;;; hmark.l ver.0.1.6.2 // crayonzen [2007-09-19]04:11:58(+0900)

;; ヒストリの保存最大値
;; メニュー：：ツール：共通設定：いろいろ：ヒストリの個数：

(provide "hmark")

(in-package "editor")

(export '(set-hmark-add
	  hmark-add

	  hmark-dialog-box
	  hmark-save ;all buffer
	  hmark-read ;all buffer

	  cmark-save
	  cmark-read
	  cmark-dialog-box

	  cmark-goto-mark-and-return
	  cmark-goto-mark
	  cmark-goto-return

	  save-mark-history-file
	  save-mark-history-file-deal
	  save-mark-history-file-common
	  ;save-hmark-file-dialog
	  read-mark-history-file-dialog
	  read-mark-history-file-add-dialog

	  cmark-goto-popup
	  ))

(export '(*hmark-max*
	  *hmark-history*
	  *cmark-history*
	  *cmark-history-save*

	  *hmarkfilename*
	  ))

(defvar *hmark-list* nil)
(defvar *hmark-last* nil)
(define-history-variable *hmark-max* 100)
(define-history-variable *hmark-history* nil)
(defvar *hmarkfilename* "history.mark")
(defvar *hmarksavefolder* "mark")
(defvar *hmarkfe* ".mark")
(defvar *quit-xyzzy* nil)
(defvar *load-hmark-buffer-read* nil)

(define-history-variable *cmark-history* nil)
;;(defvar *cmark-history-max* 200)
(defvar *cmark-last* nil)
(define-history-variable *cmark-history-save* t)

(defvar-local *save-current-point* nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;マーク追加
(defun set-hmark-add ()
  (interactive)
  (if (hmark-add)
      (message "mark add")
    (message "* marked point already"))
  )

(defun hmark-add ()
  (let ((buffer (selected-buffer))
	(point (point)))
    (if (null (hmark-list-exist *hmark-list* buffer point))
	(progn
	  (push (set-marker (make-marker (selected-buffer)) (point)) *hmark-list*)
	  (setq exceed (- (length *hmark-list*) *hmark-max*))
	  (if (> exceed 0)
	      (setq *hmark-list* (nbutlast *hmark-list* exceed)))
	  t)))
  )

(defun hmark-list-exist (markerlist &optional (buffer (selected-buffer)) (point (point)))
  (let ((exist nil))
    (dolist (maker markerlist)
      (let ((b (marker-buffer maker))
	    (p (marker-point maker)))
	(if (equalp b buffer)
	    (if (equalp p point)
		(return (setq exist t))
	      (setq exist nil))
	  (setq exist nil))))
    exist)
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ダイアログ *hmark-list*

;;;移動
(defun hmark-goto (marker)
  (set-buffer (marker-buffer marker))
  (goto-char (marker-point marker))
  (reverse-region-mark-line)
  ;(recenter)
  t)

(defun reverse-region-mark-line ()
  (let ((curpoint (point)))
    (setq from (progn (goto-eol) (point)))
    (setq to (progn (goto-bol) (point)))
    (reverse-region from to t)
    (goto-char curpoint))
  )

;;;削除項目*hmark-list*
(defun hmark-delete (marker)
  (setq *hmark-list* (delete marker *hmark-list* :test #'eq))
  (delete-marker marker)
  t)

;;;削除項目*hmark-history*
(defun hmark-history-delete (&optional filename markerpoint)
  (let (pointlist)
    (setq target (format nil "~A~D" filename markerpoint))
    (setq pointlist (mapcar #'(lambda (item)
				(setq itemlist (split-string item #\: t))
				(setq buffer (car itemlist))
				(setq markerpoint (nth 1 itemlist))
				(list (concat buffer markerpoint) item))
			    *hmark-history*))

    (setq item2 (find target pointlist :test #'equalp :key #'car))

    (if item2
	(progn
	  (setq item3 (nth 1 item2))
	  (setq *hmark-history* (delete item3 *hmark-history* :test #'eq))
	  )))
  t)

;;;削除全て：リスト＆ヒストリー
(defun hmark-clear ()
  (if (no-or-yes-p "全ての「マーク」を削除しますか？")
      (progn
	(hmark-list-clear)
	(hmark-history-clear)))
  t)

;;;削除*hmark-list*
(defun hmark-list-clear ()
  (dolist (marker *hmark-list*)
    (delete-marker marker))
  (setq *hmark-list* nil)
  t)

;;;削除*hmark-history*
(defun hmark-history-clear ()
  (setq *hmark-history* nil)
  t)

;;;リスト作成*hmark-list*
(defun hmark-make-list (&optional (sorttype nil))
  (let (result
	bufferlist)
    (save-excursion
      (save-window-excursion
	(dolist (maker *hmark-list*)
	  (let ((markerpoint (marker-point maker))
		(buffer (marker-buffer maker)))
	    (when (and markerpoint buffer)
	      (set-buffer buffer)
	      (save-excursion
		(goto-char markerpoint)
		(push (list maker
			    (buffer-name buffer)
			    (current-line-number)
			    markerpoint
			    (get-marker-string markerpoint 128))
		      result)))))))

    (setq bufferlist (mapcar #'(lambda (marker)
				 (buffer-name (marker-buffer marker)))
			     *hmark-list*))

    (dolist (item *hmark-history*)
      (setq itemlist (split-string item #\: t))
      (setq buffer (car itemlist))
      (setq markerpoint (parse-integer (nth 1 itemlist) :junk-allowed t))
      (setq str (get-hmark-history-string item))
      ;(setq str (nth 2 itemlist))
      (if (null str)
	  (setq str ""))
      (unless (find buffer bufferlist :test #'equalp)
	(push (list ""
		    buffer
		    ""
		    markerpoint
		    str
		    )
	      result)))

    (if sorttype
	(case sorttype
	  (1 (setq result (stable-sort result #'< :key #'(lambda (x) (cadddr x))))
	     (setq result (stable-sort result #'string< :key #'(lambda (x) (cadr x))))
	     (setq result (stable-sort result #'< :key #'(lambda (x)
							   (if (equal "" (caddr x))
							       1
							     0)))))
	  (t result))
      (reverse result) ;(nreverse result)
      ))
  )

(defun get-hmark-history-string (item)
  (if item
      (let ()
	(setq end (length item))
	(string-match ":" item)
	(setq start (match-end 0))
	(setq start (string-match ":" item start end))
	(if (and (null (null start))
		 (< (+ start 1) end))
	    (substring item (+ start 1) nil))))
  )

(defvar *hmark-dialog-template*
  '(dialog 0 0 360 212
    (:caption "ﾏｰｸ")
    (:font 9 "ＭＳ Ｐゴシック")
    (:control
     (:listbox list nil #x50b10111 4 16 292 192)
     (:button go "移動(&G)" #x50030001 305 5 52 14)
     (:button add "追加(&A)" #x50030000 305 22 52 14)
     (:button delete "削除(&D)" #x50030000 305 39 52 14)
     (:button clear "全削除(&C)" #x50030000 305 56 52 14)
     ;(:button view "表示(&V)" #x50030000 305 73 52 14)
     (:button save "ﾌｧｲﾙ保存(&F)" #x50030000 305 90 52 14)
     (:button read "読み込み(&R)" #x50030000 305 107 52 14)
     (:button readadd "読み込み追加(&I)" #x50030000 305 124 52 14)
     ;(:button IDCANCEL "ｷｬﾝｾﾙ" #x50030000 305 141 52 14)
     (:button IDOK "OK" #x50030000 305 158 52 14)
     (:static nil "max(&M):" #x50020000 305 178 22 10)
     (:edit markmax nil #x50810086 330 175 30 14)
     (:spin markmaxspin nil #x500000b6 357 175 9 14)
     (:static hmlen nil #x50020000 305 192 52 10)
     (:static hhlen nil #x50020000 305 202 52 10)

     (:button sort "ｿｰﾄ(&S)" #x50030000 4 5 52 10)
     (:button line "Line(&L)" #x50030000 80 5 26 10)
     (:static nil "Point" #x50020000 108 5 26 10)
     ))
  )

(defun hmark-dialog-box (&optional (sorttype nil))
  (interactive)
  (let ((marklist (hmark-make-list sorttype)))
    (multiple-value-bind (result data)
	(dialog-box *hmark-dialog-template*
		    (list (cons 'list marklist)
			  (cons 'list (or (if (and (markerp *hmark-last*)
						   (marker-buffer *hmark-last*))
					      (find *hmark-last* marklist :key #'car))
					  (if (null (markerp *hmark-last*))
					      (find (nth 3 *hmark-last*) (member (nth 1 *hmark-last*) marklist :key #'cadr :test #'equal) :test #'equal :key #'(lambda (x) (nth 3 x))))
					  ))
			  (cons 'markmaxspin *hmark-max*)
			  (cons 'hmlen (format nil "Max     ~D/~D" (length *hmark-list*) *hmark-max*))
			  (cons 'hhlen (format nil "History ~D/~D" (length *hmark-history*) *minibuffer-maximum-history-count*))
			  )
		    '((list :column (0 24 -8 -8 128) :must-match nil :enable (go delete))
		      (add :no-result t)
		      (sort :no-result t)
		      (line :no-result t)
		      (clear :no-result t)
		      ;(view :no-result t)
		      (save :no-result t)
		      (read :no-result t)
		      (readadd :no-result t)
		      (markmaxspin :min 0 :max 10000)
		      (markmax :min 0 :range-error "0以上を指定してください"
			       :type integer :type-error "数値を入力してください")
		      ))
      (cond ((eq result 'go)
	     (if (null (null (assoc 'list data)))
		 (progn
		   (if (equal "" (cadr (assoc 'list data)))
		       (progn
			 (setq *hmark-last* (car (member (cdr (assoc 'list data)) marklist)))
			 (hmark-history-read-file
			  (caddr (assoc 'list data))
			  (car (cdr (cdr (cdr (cdr (assoc 'list data))))))))
		     (progn
		       (setq *hmark-last* (cadr (assoc 'list data)))
		       (hmark-goto *hmark-last*))))))
	    ((eq result 'add)
	     (set-hmark-add))
	    ((eq result 'delete)
	     ;;(setq *hmark-last* (car (car (cdr (member (cdr (assoc 'list data)) marklist)))));;next marker
	     (setq *hmark-last* (car (cdr (member (cdr (assoc 'list data)) marklist))));;next list item
	     (if (null (null (assoc 'list data)))
		 (progn
		   (if (null (equal "" (cadr (assoc 'list data))))
		       (hmark-delete (cadr (assoc 'list data)))
		     (hmark-history-delete
		      (caddr (assoc 'list data))
		      (car (cdr (cdr (cdr (cdr (assoc 'list data))))))))))
	     (hmark-dialog-box sorttype))
	    ((eq result 'clear)
	     (hmark-clear)
	     (hmark-dialog-box))

	    ((eq result 'save)
	     (save-mark-history-file)
	     (hmark-dialog-box))
	    ((eq result 'read)
	     (read-mark-history-file-dialog)
	     (hmark-dialog-box))
	    ((eq result 'readadd)
	     (read-mark-history-file-add-dialog)
	     (hmark-dialog-box))

	    ((eq result 'sort)
	     (hmark-dialog-box 1))
	    ((eq result 'line)
	     (delete-same-line-mark-list)
	     (hmark-dialog-box sorttype))
	    ((eq result 'IDOK)
	     (setq *hmark-max* (cdr (assoc 'markmax data))))
	    (t
	     nil)
	    )))
  )

;;１ 開いているバッファのディレクトリと同じにあれば開く。
;;２ ヒストリにあれば選択して開く。それ以外は手動
(defun hmark-history-read-file (&optional filename markerpoint)
  (let ((readfile (get-aim-readfile-exist filename)))
    (if readfile
	(progn
	  (find-file readfile)
	  (if markerpoint
	      (progn
		(goto-char markerpoint)
		(reverse-region-mark-line)
		;(recenter) ;(recenter 0)
		(hmark-last-select filename markerpoint)
		)))
      (progn
	(let ((aimfilelist (get-aim-historylist-exist filename)))
	  (if aimfilelist
	      (progn
		(if (aimfile-historylist-dialog aimfilelist)
		    (if markerpoint
			(progn
			  (goto-char markerpoint)
			  (reverse-region-mark-line)
			  (hmark-last-select filename markerpoint)))
		  (hmark-dialog-box))
		)
	    (progn
	      (if (open-marked-file-dialog filename)
		  (if markerpoint
		      (progn
			(goto-char markerpoint)
			(reverse-region-mark-line)
			(hmark-last-select filename markerpoint)))
		(hmark-dialog-box))
	      ))))))
  )

(defun get-aim-readfile-exist (filename)
  (let ((readfile nil))
    (if (and (setq path (default-directory))
	     (setq readfile (merge-pathnames filename path))
	     (file-exist-p readfile))
	(progn
	  readfile)
      (save-excursion
	(save-window-excursion
	  (dolist (buffer (buffer-list))
	    (set-buffer buffer)
	    (if (and (get-buffer-file-name)
		     (setq path (directory-namestring (get-buffer-file-name)))
		     (setq readfile (merge-pathnames filename path))
		     (file-exist-p readfile))
		(progn
		  (return-from nil readfile))
	      nil
	      ))))))
  )

(defun get-aim-historylist-exist (filename)
  (let ((aimfilelist nil)
	(aimfilename filename))
    (mapcar #'(lambda (pathname)
		(setq filename (file-namestring pathname))
		(if (and (equalp aimfilename filename)
			 (null (find pathname aimfilelist :test #'equalp)))
		    (setq aimfilelist (append (list pathname) aimfilelist)))
		)
	    *minibuffer-file-name-history*)
    (mapcar #'(lambda (pathname)
		(setq filename (file-namestring pathname))
		(if (and (equalp aimfilename filename)
			 (null (find pathname aimfilelist :test #'equalp)))
		    (setq aimfilelist (append (list pathname) aimfilelist)))
		)
	    *delete-file-name-history*)
    aimfilelist)
  )

(defvar drivecharacterlist (list "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z"))

(defun aimfile-historylist-dialog (aimfilelist)
  (let ((aimfilelist aimfilelist)
	dialoglist)
    (if aimfilelist
	(progn
	  (dolist (pathname aimfilelist)
	    (setq filename (file-namestring pathname))
	    (if (file-exist-p pathname)
		(push (list filename "○" pathname) dialoglist)
	      (progn
		(push (list filename "×" pathname) dialoglist)
		;;他のドライブ文字でも検索する
		(let* ((strnum (length pathname))
		       (str1 (substring pathname 1 strnum))
		       dialoglist)
		  ;;(dolist (item drivecharacterlist)
		  (mapcar #'(lambda (item)
			      (setq aimpathname (concat item str1))
			      (if (and (file-exist-p aimpathname)
				       (null (find aimpathname aimfilelist :test #'equalp)))
				  (push (list filename "△" aimpathname) dialoglist)))
			  drivecharacterlist)
		  )))
	    (setq dialoglist (stable-sort dialoglist #'string< :key #'(lambda (x) (caddr x)))))
	  ;;(reverse result)
	  (multiple-value-bind (result data)
	      (dialog-box `(dialog 0 0 360 173
				   (:caption "ヒストリからファイルを開く（○△開けます：×ありません）")
				   (:font 9 "ＭＳ Ｐゴシック")
				   (:control
				    (:listbox list nil #x50b10111 4 16 292 153)
				    (:button openfile "開く(&O)" #x50030001 305 5 52 14)
				    (:button IDCANCEL "ｷｬﾝｾﾙ" #x50030000 305 22 52 14)))
			  (list (cons 'list dialoglist)
				(cons 'list (nth 0 dialoglist)))
			  '((list :column (32 -4 256) :must-match t :enable (openfile))))
	    (cond ((eq result 'openfile)
		   (let ((readfile (assoc 'list data)))
		     (setq filename (cadr readfile))
		     (setq pathname (cadddr readfile))
		     (if (file-exist-p pathname)
			 (progn
			   (find-file-internal pathname)
			   (set-buffer (find-buffer-string-equal filename))
			   (add-history pathname '*minibuffer-file-name-history*)
			   (message "pathname: ~S" pathname))
		       (progn
			 (message "pathname: ~S" pathname)
			 (if (open-recent-file-dialog (concat "開く■ " filename " ■" pathname ) filename t (get-exist-directory pathname))
			     (progn
			       (setq openfile (file-namestring (car *minibuffer-file-name-history*)))
			       (if (null (equalp filename openfile))
				   (message "違ってませんか？ marked: ~S  open: ~S" filename openfile))
			       t)
			   )))))
		  (t nil))))
      (progn
	nil)))
  )

(defun hmark-last-select (&optional filename markerpoint)
  (when (and filename markerpoint)
    (dolist (marker *hmark-list*)
      (setq buffer (buffer-name (marker-buffer marker)))
      (setq mpoint (marker-point marker))
      (if (and (equal filename buffer)
	       (equal markerpoint mpoint))
	  (progn
	    (setq *hmark-last* marker)
	    (return t)))))
  )

(defun open-marked-file-dialog (&optional filename)
  (interactive)
  (multiple-value-bind (file index encoding eol-code)
      (file-name-dialog :title (concat "開く:　" filename)
			:default filename
			:filter *file-dialog-filter*
			:filter-index *file-dialog-filter-index*
			:char-encoding (or *expected-fileio-encoding* t)
			:eol-code *expected-eol-code*)
    (when file
      (setq *file-dialog-filter-index* index)
      (let ((*expected-fileio-encoding* encoding)
	    (*expected-eol-code* eol-code))
	(declare (special *expected-fileio-encoding* *expected-eol-code*))
	(find-file file))
      (add-history file '*minibuffer-file-name-history*)
      (setq openfile (file-namestring file))
      (if (null (equalp filename openfile))
	  (message "違ってませんか？ marked: ~S  open: ~S" filename openfile))
      t))
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;; 1 buffer save only ver8
(defun hmark-buffer-save (filename)
  (if (null *quit-xyzzy*)
      (if (get-buffer-file-name filename)
	  (if (setq curbuffername (buffer-name filename))
	      (let ((1bufferlist (reverse (get-1buffer-hmark-list curbuffername))))
		(delete-history-1buffer curbuffername)
		(save-window-excursion
		  (save-excursion
		    (dolist (marker 1bufferlist)
		      (let ((buffername (buffer-name (marker-buffer marker)))
			    (markerpoint (marker-point marker)))
			(if (null (null markerpoint))
			    (progn
			      (setq str (get-marker-string markerpoint))
			      (setq item (format nil"~A:~D:~A" buffername markerpoint str))
			      (add-history item '*hmark-history*)
			      )))
		      )))))))
  t)

(defun get-1buffer-hmark-list (name)
  (let (1bufferlist)
    (mapcar #'(lambda (marker)
		(setq buffername (buffer-name (marker-buffer marker)))
		(if (equalp buffername name)
		    (setq 1bufferlist (append (list marker) 1bufferlist)))
		)
	    *hmark-list*)
    1bufferlist)
  )

(defun delete-history-1buffer (filename)
  (block deletehistory1buffer
    (let* ((bufferlist (mapcar #'(lambda (item)
				   (setq itemlist (split-string item #\: t))
				   (setq buffer (car itemlist))
				   (list buffer item))
			       *hmark-history*)))
      (tagbody
	repeat
	(if (null (setq item2 (find filename bufferlist :test #'equalp :key #'car)))
	    (return-from deletehistory1buffer t))

	(setq item3 (nth 1 item2))
	(setq *hmark-history* (delete item3 *hmark-history* :test #'eq))
	(setq bufferlist (delete item2 bufferlist :test #'eq))

	(go repeat))))
  )

;;;;;;;;;;;;;;;;all buffer save ver2
(defun hmark-save ()
  (interactive)
  (let ((bufferlist nil)
	(newlist nil))

    (setq bufferlist (mapcar #'(lambda (marker)
				 (buffer-name (marker-buffer marker)))
			     *hmark-list*))
    (mapcar #'(lambda (item)
		(setq buffer (nth 0 (split-string item #\: t)))
		(unless (find buffer bufferlist :test #'equalp)
		  (push item newlist))
		)
	    *hmark-history*)
    (hmark-history-clear)
    (setq *hmark-history* (reverse newlist))

    (save-window-excursion
      (save-excursion
	(let ((hmarklist (reverse *hmark-list*)))
	  (dolist (marker hmarklist)
	    (when (and
		   (setq buffer (buffer-name (marker-buffer marker)))
		   (setq markerpoint (marker-point marker)))
	      (if (stringp markerpoint)
		  (setq markerpoint (parse-integer markerpoint :junk-allowed t)))
	      (set-buffer (marker-buffer marker))

	      (setq str (get-marker-string markerpoint))
	      (setq item (format nil "~A:~D:~A" buffer markerpoint str))
	      (add-history item '*hmark-history*)
	      )))))

    (delete-same-mark-history) ;同じマークは削除。
    (delete-scratch-files-mark-history) ;*scratch*などの*〜のファイルは削除
    )
  )

;;;;;;;;;;;;;;;; 1 buffer read ver3
(defun hmark-buffer-read ()
  (let ((curbuffer (selected-buffer)))
    (if (setq curbuffername (buffer-name curbuffer))
	(progn
	  (setq historylist (reverse (get-1buffer-hmark-history-list curbuffername)))
	  (function-hmark-read historylist)

	  (setq exceed (- (length *hmark-list*) *hmark-max*))
	  (if (> exceed 0)
	      (setq *hmark-list* (nbutlast *hmark-list* exceed)))))
    t)
  )

(defun get-1buffer-hmark-history-list (name)
  (let (1bufferlist)
    (mapcar #'(lambda (item)
		(setq itemlist (split-string item #\: t))
		(setq buffername (car itemlist))
		(if (equalp buffername name)
		    (setq 1bufferlist (append (list item) 1bufferlist)))
		)
	    *hmark-history*)
    1bufferlist)
  )

;;;;;;;;;;;;;;;;all buffer read ver2
(defun hmark-read ()
  (interactive)
  (let ((historylist (reverse *hmark-history*)))
    (function-hmark-read historylist))
  )

(defun function-hmark-read (historylist)
  (save-excursion
    (save-window-excursion
      (mapcar #'(lambda (item)
		  (let* ((itemlist (split-string item #\: t))
			 (buffer (nth 0 itemlist))
			 (markerpoint (nth 1 itemlist)))
		    (if (and (null (null buffer))
			     (null (null markerpoint)))
			(progn
			  (if (stringp markerpoint)
			      (setq markerpoint (parse-integer markerpoint :junk-allowed t)))
			  (if (and (numberp markerpoint)
				   (setq buffer (find-buffer-string-equal buffer)))
			      (progn
				(set-buffer buffer)
				(push (set-marker (make-marker) markerpoint) *hmark-list*))
			    )))))
	      historylist)
      ))
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; for *hmark-history*
(defun get-marker-string (markerpoint &optional (maxlength 32))
  (let ((str))
    (save-excursion
      (goto-char markerpoint)
      (if (eolp)
	  (setq str (buffer-substring (progn (goto-bol) (max (point) (- markerpoint maxlength)))
				      markerpoint))
	(setq str
	      (buffer-substring markerpoint
				(progn (goto-eol) (min (point) (+ markerpoint maxlength))))))
      (if (null str)
	  (setq str "")))
    str)
  )

;;(reverse 古い順にヒストリに格納する。ので新しい方が失われるがポイントは同じ。
(defun delete-same-mark-history ()
  (let (pointlist
	newlist)
    (setq pointlist (reverse
		     (mapcar #'(lambda (item)
				 (let ((itemlist (split-string item #\: t)))
				   (setq buffer (car itemlist))
				   (setq markerpoint (nth 1 itemlist))
				   (list (concat buffer markerpoint) item)))
			     *hmark-history*)))
    (hmark-history-clear)
    (mapcar #'(lambda (item2)
		(let ((bufferpoint (nth 0 item2))
		      (item (nth 1 item2)))
		  (if (null (find bufferpoint newlist :test #'equalp :key #'car))
		      (progn
			(push (list bufferpoint item) newlist)
			(add-history item '*hmark-history*))))
		)
	    pointlist)
    )
  )

;;未処理
(defun delete-same-mark-list ()
  )

(defun delete-same-line-mark-list ()
  (when (no-or-yes-p "同じライン上のマークを削除します")
    (let (linelist
	  checklist)
      (save-excursion
	(save-window-excursion
	  (setq hmarklist (reverse *hmark-list*))
	  (mapcar #'(lambda (marker)
		      (let ((markerpoint (marker-point marker))
			    (buffer (marker-buffer marker)))
			(when (and markerpoint buffer)
			  (set-buffer buffer)
			  (goto-char markerpoint)
			  (push (list (concat (buffer-name buffer) (format nil "~D" (current-line-number)))
				      marker)
				linelist))))
		  hmarklist)
	  ))

      ;チェック＆削除
      (mapcar #'(lambda (item)
		  (let ((bufferline (nth 0 item))
			(marker (nth 1 item)))
		    (if (null (find bufferline checklist :test #'equalp :key  #'car))
			(push (list bufferline marker) checklist)
		      (progn
			(setq *hmark-list* (delete marker *hmark-list* :test #'eq))
			(delete-marker marker)
			))))
	      linelist)
      ))
  )

(defun delete-scratch-files-mark-history ()
  (let (newlist)
    (mapcar #'(lambda (item)
		(unless (equal #\* (char item 0))
		  (setq newlist (append (list item) newlist))))
	    *hmark-history*)

    (hmark-history-clear)
    (setq *hmark-history* (reverse newlist))
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; cmark
(defun cmark-save ()
  (interactive)
  (cmark-history-clear)
  (when *cmark-history-save*
    (save-excursion
      (save-window-excursion
	(dolist (buffer (buffer-list))
	  (set-buffer buffer)
	  (when (and (null (equal #\* (char (buffer-name buffer) 0)));or not
		     (mark t))
	    (setq item (format nil "~A:~D" (buffer-name buffer) (mark t)))
	    (add-history item '*cmark-history*)
	    )))))
  )

;;;;;;;;;;;;;;;; 1 buffer read
(defun cmark-buffer-read ()
  (interactive)
  (save-excursion
    (save-window-excursion
      (setq curbuffer (buffer-name (selected-buffer)))
      (dolist (item *cmark-history*)
	(setq itemlist
	      (multiple-value-bind (b1 p2)
		  (split-string item #\:)
		(list b1 p2)))
	(setq buffer (car (car itemlist)))
	(setq point (cadr (car itemlist)))
	(if (stringp point)
	    (setq point (parse-integer point :junk-allowed t)))
	(if (numberp point)
	    (if (equalp curbuffer buffer)
		(progn
		  (set-mark point)
		  (return t)))
	  ))))
  )

(defun cmark-read ()
  (interactive)
  (setq curbuffer (selected-buffer))
  (setq curbufferwindow (get-buffer-window curbuffer))
  (setq curpoint (point))
  ;(save-excursion
  ;(save-window-excursion
  (mapcar #'(lambda (item)
	      (setq itemlist (split-string item #\:))

	      (setq buffer (car itemlist))
	      (setq markerpoint (nth 1 itemlist))

	      (if (stringp markerpoint)
		  (setq markerpoint (parse-integer markerpoint :junk-allowed t)))
	      (if (numberp markerpoint)
		  (if (setq buffer (find-buffer-string-equal buffer))
		      (progn
			;(setq savepoint (point))
			(set-buffer buffer)
			(set-mark markerpoint)
			;(goto-char savepoint)
			)
		    ))
	      )
	  *cmark-history*)
  ;))
  (set-window curbufferwindow)
  (set-buffer curbuffer)
  (goto-char curpoint)
  )

(defun cmark-goto (cmarklast)
  ;;(when (setq buffer (find-buffer-string-equal (cadr cmarklast)))
  (when (setq buffer (find-buffer (cadr cmarklast)))
    (set-buffer buffer)
    (if (/= (point) (mark t))
	(progn
	  (setq *save-current-point* (point))
	  (goto-char (mark t)))
      (goto-char (mark t))
      )
    (reverse-region-mark-line)
    ;(recenter)
    )
  t)

(defun cmark-history-clear ()
  (interactive)
  (setq *cmark-history* (nbutlast *cmark-history* (length *cmark-history*)))
  (setq *cmark-history* nil)
  )

(defun cmark-make-list ()
  (let (result)
    (save-excursion
      (save-window-excursion
	(dolist (buffer (buffer-list))
	  (set-buffer buffer)
	  (when (mark t)
	    (save-excursion
	      (goto-char (mark t))
	      (goto-bol)
	      (setq point (point))
	      (push (list (buffer-name buffer)
			  (current-line-number)
			  (buffer-substring point
					    (progn
					      (goto-eol)
					      (min (point)
						   (+ point 128)))))
		    result))))))
    ;(nreverse result)
    (setq result (sort result #'string< :key #'car)))
  )

(defvar *cmark-dialog-template*
  '(dialog 0 0 360 123
    (:caption "■ﾏｰｸ")
    (:font 9 "ＭＳ Ｐゴシック")
    (:control
     (:listbox list nil #x50b10111 4 5 292 114)
     (:button go "移動(&G)" #x50030001 305 5 52 14)
     (:button mark "マーク(&M)" #x50030000 305 22 52 14)
     (:button savecmark "保存(&C)" #x50010003 305 56 52 10)
     (:button IDOK "OK" #x50030000 305 73 52 14)
     (:button IDCANCEL "ｷｬﾝｾﾙ" #x50030000 305 90 52 14)
     )))

(defun cmark-dialog-box ()
  (interactive)
  (let ((list (cmark-make-list)))
    (multiple-value-bind (result data)
	(dialog-box *cmark-dialog-template*
		    (list (cons 'list list)
			  (cons 'list (find (buffer-name (selected-buffer)) list :key #'car))
			  ;;(cons 'list (find *cmark-last* list :key #'car))
			  (cons 'savecmark *cmark-history-save*)
			  )
		    '((list :column (24 -8 128) :must-match nil :enable (go IDOK))
		      ))
      (cond ((eq result 'go)
	     (setq *cmark-last* (assoc 'list data))
	     (cmark-goto *cmark-last*))
	    ((eq result 'mark)
	     (set-mark-command))
	    ((eq result 'IDOK)
	     (setq *cmark-history-save* (car (assoc 'savecmark data))))
	    (t nil))))
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun cmark-goto-mark-and-return ()
  (interactive)
  (if (/= (point) (mark t))
      (progn
	(setq *save-current-point* (point))
	(goto-char (mark t))
	(reverse-region-mark-line))
    (if *save-current-point*
	(goto-char *save-current-point*)))
  )

(defun cmark-goto-mark ()
  (interactive)
  (when (/= (point) (mark t))
    (setq *save-current-point* (point))
    (goto-char (mark t))
    (reverse-region-mark-line))
  )

(defun cmark-goto-return ()
  (interactive)
  (when *save-current-point*
    (goto-char *save-current-point*))
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;ソート：ヒストリ *hmark-history*
(defun hmark-history-sort-list ()
  (let (sortlist
	historylist)
    (mapcar #'(lambda (item)
		(setq itemlist (split-string item #\:))
		(setq buffer (car itemlist))
		(setq markerpoint (car (cdr itemlist)))
		(if (and (null (null buffer))
			 (null (null markerpoint)))
		    (if (parse-integer markerpoint :junk-allowed t)
			(setq sortlist (append (list (list buffer markerpoint item)) sortlist))
		      ;(push (list buffer markerpoint item) sortlist)
		      )))
	    *hmark-history*)

    (setq sortlist (stable-sort sortlist #'< :key #'(lambda (x) (parse-integer (cadr x) :junk-allowed t))))
    (setq sortlist (stable-sort sortlist #'string< :key #'car))

    (setq historylist (mapcar #'(lambda (item)
				  (nth 2 item))
			      sortlist))
    historylist)
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;「ﾏｰｸﾌｧｲﾙを作成・保存」：[ﾏｰｸのﾋｽﾄﾘ項目]
;;default"mark.history" *hmarkfilename*
;;ユーザー指定名

(defun save-mark-history-file ()
  (interactive)
  (let (savedirectory)
    ;(setq path (directory-namestring (merge-pathnames "xyzzy.exe" (user-config-path))))
    (setq path (directory-namestring (merge-pathnames "xyzzy.exe" (si:system-root))))
    (setq savedirectory (merge-pathnames *hmarksavefolder* path))
    (case (message-box
	   (format nil "~A~%~A~%~A" "保存： は通常。" "てきとーに保存： は以下のﾃﾞｨﾚｸﾄﾘで、ﾌｧｲﾙ名別＆上書き。" savedirectory)
	   "ﾏｰｸﾌｧｲﾙ：保存"
	   '(:ok-cancel nil :button1)
	   :button1 "保存(&Y)"
	   :button2 "キャンセル(&N)"
	   :button3 "てきとーに保存(&S)"
	   )
      (:ok (save-mark-history-file-common))
      (:cancel nil)
      (:button3 (create-directory savedirectory :if-exists :skip)
       (save-mark-history-file-deal savedirectory))
      (t nil)
      ))
  )

(defun save-mark-history-file-deal (&optional savedirectory)
  (interactive)
  (long-operation
    (let ((savedirectory savedirectory))
      (save-excursion
	(save-window-excursion
	  ;(unwind-protect
	  (if (null savedirectory)
	      (progn
		(setq path (directory-namestring (merge-pathnames "xyzzy.exe" (si:system-root))))
		(setq savedirectory (merge-pathnames *hmarksavefolder* path))
		(create-directory savedirectory :if-exists :skip)))
	  (if (file-exist-p savedirectory)
	      (let (newbuffer
		    deallist)
		(hmark-save)
		(setq deallist (hmark-history-sort-list))

		(setq newbuffer (create-new-buffer *hmarkfilename*))
		(set-buffer newbuffer)
		(with-output-to-buffer (newbuffer)

		  (dolist (item deallist)
		    (format t "~A~%" item)))

		(setq time (format-date-string "[%Y-%m-%d]%H%M%S" (get-universal-time)))
		(setq filename (format nil "~A~A" time *hmarkfe*))
		(setq savefile (merge-pathnames filename savedirectory))
		(write-file savefile)

		;;deal
		(let (buffer)
		  (delete-region (point-min) (point-max))
		  (setq buffer (car (split-string (car deallist) #\:)))
		  (with-output-to-buffer (newbuffer)
		    ;(save-excursion
		    ;(save-window-excursion
		    (dolist (item deallist)
		      (setq buffer2 (car (split-string item #\:)))
		      (if (equal buffer buffer2)
			  (format t "~A~%" item)
			(progn
			  (setq filename (format nil "~A~A" buffer *hmarkfe*))
			  (setq savefile (merge-pathnames filename savedirectory))
			  (write-file savefile)
			  (delete-region (point-min) (point-max))
			  (format t "~A~%" item)))
		      (setq buffer buffer2)))

		  (setq filename (format nil "~A~A" buffer *hmarkfe*))
		  (setq savefile (merge-pathnames filename savedirectory))
		  (write-file savefile))

		(when newbuffer
		  (delete-buffer newbuffer))
		(message "save mark history files deal")
		))))))
  )

(defun save-mark-history-file-common ()
  (interactive)
  (hmark-save)
  (let (newbuffer)
    (save-excursion
      (save-window-excursion
	(setq newbuffer (create-new-buffer *hmarkfilename*))
	(set-buffer newbuffer)
	(with-output-to-buffer (newbuffer)
	  (dolist (item *hmark-history*)
	    (format t "~A~%" item)))

	(if (null (save-hmark-file-dialog))
	    (if newbuffer
		(delete-buffer newbuffer))
	  (message "save mark history file"))
	)))
  )

(defun save-hmark-file-dialog (&optional (filename (buffer-name (selected-buffer))))
  (interactive)
  (multiple-value-bind (file)
      (file-name-dialog :title "ﾏｰｸﾌｧｲﾙ保存"
			:save t
			:default filename
			:filter '(("マークファイル(*.mark)" . "*.mark")
				  ("すべてのファイル(*.*)" . "*.*")))
    (if file
	(when (or (not (file-exist-p file))
		  (no-or-yes-p "~aは既に存在します。上書きしますか?" file))
	  (set-buffer-file-name file)
	  (rename-buffer (file-namestring file))
	  (save-buffer)
	  (delete-buffer (get-file-buffer file))
	  (add-history file '*minibuffer-file-name-history*)
	  t)))
  )

;;;;;;;;;;;;;;;;「ﾏｰｸﾌｧｲﾙ：読み込み」「ﾏｰｸﾌｧｲﾙ：読み込み追加」
(defun read-mark-history-file-dialog (&optional (multiple t))
  (interactive)
  (multiple-value-bind (files)
      (file-name-dialog :title "ﾏｰｸﾌｧｲﾙの読み込み（現在のﾏｰｸは削除されます）"
			:filter '(("マークファイル(*.mark)" . "*.mark")
				  ("すべてのファイル(*.*)" . "*.*"))
			:initial-directory (merge-pathnames *hmarksavefolder* (directory-namestring (merge-pathnames "xyzzy.exe" (si:system-root))))
			:multiple multiple
			)
    (when files
      (hmark-list-clear)
      (hmark-history-clear)
      (if multiple
	  (dolist (f files t)
	    (read-mark-file f))
	(progn
	  (read-mark-file files)
	  ))
      (message "read mark history files")
      t))
  )

(defun read-mark-history-file-add-dialog (&optional (multiple t))
  (interactive)
  (multiple-value-bind (files)
      (file-name-dialog :title "ﾏｰｸﾌｧｲﾙの読み込み（現在のﾏｰｸに追加します）"
			:filter '(("マークファイル(*.mark)" . "*.mark")
				  ("すべてのファイル(*.*)" . "*.*"))
			:initial-directory (merge-pathnames *hmarksavefolder* (directory-namestring (merge-pathnames "xyzzy.exe" (si:system-root))))
			:multiple multiple
			)
    (when files
      (if multiple
	  (dolist (f files t)
	    (read-mark-file f))
	(progn
	  (read-mark-file files)
	  ))
      (message "read mark history files add")
      t))
  )

(defun read-mark-file (readfile)
  (interactive)
  (long-operation
    (if (file-exist-p readfile)
	(let ((temp-buffer (create-new-buffer "*temp-read*")))
	  (setq curbuffer (selected-buffer))
	  (setq curpoint (point))
	  (save-excursion
	    (save-window-excursion
	      (unwind-protect
		  (progn
		    (set-buffer temp-buffer)
		    (insert-file-contents readfile t)
		    (goto-char (point-max))
		    (while t
		      (setq item (buffer-substring (point)
						   (progn
						     (goto-eol)
						     (point))))
		      (when item
			(add-history item '*hmark-history*))
		      (unless (forward-line -1)
			(return))))
		(when temp-buffer
		  (delete-buffer temp-buffer)))))

	  (hmark-read)
	  (delete-same-mark-history)
	  ;;(delete-same-mark-list) ;未処理

	  (set-buffer curbuffer)
	  (goto-char curpoint)
	  t)))
  )

;;;;;;;;;;;;;;;; フック： must always be executed add-hook for the mark
;;;add-hook *delete-buffer-hook*
;;;add-hook *kill-xyzzy-hook*
;;;add-hook *find-file-hooks*
;;;add-hook *post-startup-hook*
;;;add-hook *load-history-hook*

;;;;;;;;;;;;;;;; フック hmark hook
;４
(add-hook '*kill-xyzzy-hook*
	  #'(lambda ()
	      (setq *quit-xyzzy* t)
	      (hmark-save)))

;３b
(add-hook '*delete-buffer-hook* 'hmark-buffer-save)

;３a
(add-hook '*find-file-hooks*
	  #'(lambda () (if *load-hmark-buffer-read*
			   (hmark-buffer-read))))

;２
(add-hook '*post-startup-hook*
	  #'(lambda ()
	      (setq *quit-xyzzy* nil) ;for hmark-buffer-save or else
	      (hmark-read)
	      (setq *load-hmark-buffer-read* t) ;for hmark-buffer-read
	      ))

;１
(add-hook '*load-history-hook*
	  #'(lambda ()
	      (setq *load-hmark-buffer-read* nil)))

;;;;;;;;;;;;;;;; フック cmark hook
(add-hook '*kill-xyzzy-hook*
	  #'(lambda () (cmark-save)))

(add-hook '*post-startup-hook*
	  #'(lambda () (cmark-read)))

;;;;;;;;;;;;;;;;
(defun about-hmark ()
  (interactive)
  (case (message-box
	 "ﾏｰｸについて：ﾏｰｸはﾊﾞｯﾌｧ名（≒ﾌｧｲﾙ名）の記録となっています。ﾊﾟｽ名ではありません。
　同じﾌｧｲﾙ名で内容の違うﾌｧｲﾙを開いた時には
　ﾏｰｸ位置の内容は意図したﾏｰｸと違うものとなります。

　閉じているﾌｧｲﾙ（ﾗｲﾝ数なし）であっても現在開いている全てのﾌｧｲﾙ（ﾊﾞｯﾌｧ）と
　どれか同じﾃﾞｨﾚｸﾄﾘ（ﾌｫﾙﾀﾞｰ）にある場合は自動的に開いてﾏｰｸ位置に移動します。

ﾏｰｸﾌｧｲﾙ：保存：読み込み：
　ﾏｰｸをﾌｧｲﾙに保存または読み込みます。
　拡張子は一応「****.mark」のように設定してます。

Historyの数：（ﾐﾆﾊﾞｯﾌｧの）ヒストリの個数に依存しています。
　変更はﾒﾆｭｰ「ツール→共通設定→いろいろ→ヒストリの個数」になります。"

	 "マークについて"
	 '(:ok nil :button1)
	 :button1 "OK(&Y)"
	 :NO-WRAP t
	 )
    (:ok t)
    (t nil)
    )
  )

(defun cmark-goto-popup ()
  (interactive)
  (track-popup-menu
   (define-popup-menu
     (:item nil "goto-mark(&M)"
      'cmark-goto-mark
      #'(lambda () (unless (mark t) :disable)))
     (:item nil "goto-return(&R)"
      'cmark-goto-return
      #'(lambda () (unless *save-current-point* :disable)))
     (:item nil "view-mark(&V)..."
      'cmark-dialog-box
      #'(lambda () (when *cmark-history-save* :check)))
     )))

;;;;;;;;;;;;;;;; command key
(global-set-key #\S-F5 'set-hmark-add)
(global-set-key #\C-F5 'hmark-dialog-box)

;;仮想ファンクションキー（F13〜)日本語入力だとIMEのキー割り当てで動かない
;(set-extended-key-translate-table exkey-S-C-space #\C-F22)
;(global-set-key #\C-F22 'set-hmark-add) ;Shft+Ctrl+Space

;;マーク位置と現在位置のトグル切り替え
(global-set-key #\F2 'cmark-goto-mark-and-return)
;(global-set-key #\F2 'cmark-goto-mark) ＞■マーク位置へ
;(global-set-key #\S-F2 'cmark-goto-return) ＞□戻る

(global-set-key #\M-m 'cmark-goto-popup)
