;;; free-fold.el --- fold region interface

;; Copyright (C) 2004  Taiki SUGAWARA <taiki.s@cityfujisawa.ne.jp>

;; Author: Taiki SUGAWARA <taiki.s@cityfujisawa.ne.jp>
;; Keywords: 

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; Install:
;; Write following code into your .emacs
;;	(autoload 'free-fold-mode "free-fold" nil t)

;; This is a fold region mode.
;; I know folding by keyword mode, but I don't know folding region
;; mode, so I wrote this.

;; If you use this mode, open a file and type M-x free-fold-mode.
;; After you type "C-c f f", it means hide region. You type "C-c f u", it
;; means restore hide region.

;; Install:
;; 以下を .emacs に書く。
;;	(autoload 'free-fold-mode "free-fold" nil t)

;; region を隠す mode。
;; キーワードで隠すのはあるけど、region を隠すのがないんで作ってみた。
;; 切り取りとかができたほうがうれしいので、overay ではなく text property を使っ
;; てる。

;; 使うには適当なファイルで M-x free-fold-mode で、この mode に入る。
;; 後は "C-c f f" で region を隠す。"C-c f u" で region を元に戻す。

;;; Code:

(require 'rect)

(defvar free-fold-mode-prefix-map
  (let ((map (make-sparse-keymap)))
    (define-key map "f" 'free-fold-region)
    (define-key map "u" 'free-fold-unfold-region)
    (define-key map "rf" 'free-fold-rectangle)
    (define-key map "ru" 'free-fold-unfold-rectangle)
    (define-key map "U" 'free-fold-unfold-buffer)
    (define-key map "n" 'free-fold-next-fold)
    (define-key map "p" 'free-fold-previous-fold)
    map))
(defvar free-fold-mode-map-prefix "\C-cf")
(defvar free-fold-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map free-fold-mode-map-prefix free-fold-mode-prefix-map)
    map))

(defvar free-fold-whole-line-p t
  "*If non-nil, `free-fold-region' is fold whole line.")
(defvar free-fold-show-first-line-p t
  "*If non-nil, `free-fold-region' is show first line.
This variable is available when `free-fold-whole-line-p' is non-nil.")

(defun free-fold-point-fold-p (point)
  (eq (plist-get (text-properties-at point)
		 'invisible)
      'free-fold))

(defun free-fold-point-entered (old new)
  (when (free-fold-point-fold-p new)
    (let (pos)
      (cond
       ((< old new)
	(setq pos (next-single-property-change new 'invisible)))
       ((> old new)
	(setq pos (previous-single-property-change new 'invisible))
	(and pos (setq pos (1- pos)))))
      (when pos
	(goto-char pos)))))

(defun free-fold-region (beg end)
  (interactive "r")
  (let ((modified-p (buffer-modified-p)))
    (when free-fold-whole-line-p
      (save-excursion
	(goto-char beg)
	(setq beg (if free-fold-show-first-line-p
		      (line-end-position)
		    (line-beginning-position)))
	(goto-char end)
	(setq end (if (= (point) (line-beginning-position))
		      (line-end-position 0)
		    (line-end-position)))))
    (unwind-protect
	(add-text-properties
	 beg end
	 (list
	  'invisible 'free-fold
	  'point-entered 'free-fold-point-entered))
      (set-buffer-modified-p modified-p)))
  (message "Fold"))

(defun free-fold-unfold-region (beg end)
  (interactive "r")
  (let ((modified-p (buffer-modified-p)))
    (unwind-protect
	(progn
	  (remove-text-properties
	   beg end
	   (list
	    'invisible nil
	    'point-entered nil)))
      (set-buffer-modified-p modified-p)))
  (message "Unfold"))

(defun free-fold-unfold-buffer ()
  (interactive)
  (free-fold-unfold-region (point-min) (point-max)))
  
(defun free-fold-apply-rectangle (func beg end)
  (apply-on-rectangle
   (lambda (beg-col end-col)
     (save-excursion
       (funcall
	func
	(progn (move-to-column beg-col) (point))
	(progn (move-to-column end-col) (point)))))
   beg end))

(defun free-fold-rectangle (beg end)
  (interactive "r")
  (let ((free-fold-whole-line-p nil))
    (free-fold-apply-rectangle 'free-fold-region beg end)))

(defun free-fold-unfold-rectangle (beg end)
  (interactive "r")
  (free-fold-apply-rectangle 'free-fold-unfold-region beg end))

(defun free-fold-next-previous-fold (func error-message)
  (let ((pos (point))
	found)
    (when (free-fold-point-fold-p pos)
      (setq pos (funcall func pos 'invisible)))
    (while (not found)
      (when (null pos)
	(error error-message))
      (when (free-fold-point-fold-p pos)
	(goto-char pos)
	(setq found t))
      (setq pos (funcall func pos 'invisible)))))

(defun free-fold-next-fold ()
  (interactive)
  (free-fold-next-previous-fold
   'next-single-property-change "Not found next fold"))

(defun free-fold-previous-fold ()
  (interactive)
  (free-fold-next-previous-fold
   'previous-single-property-change "Not found previous fold"))

(define-minor-mode free-fold-mode
  "Fold region mode.

Key bindings:
\\{free-fold-mode-map}"
  nil
  " Free-Fold"
  free-fold-mode-map
  (if free-fold-mode
      (add-to-invisibility-spec '(free-fold . t))
    (remove-from-invisibility-spec '(free-fold . t))))

(provide 'free-fold)
;;; free-fold.el ends here