;;; d-key-nav.el --- Keyboard navigation code

;; Copyright (C) 2006-2011 Davin Pearson

;; Author/Maintainer: m4_davin_pearson
;; Keywords: keyboard navigation
;; Version: 1.0

;;; Commentary:

;; This file is not part of GNU Emacs.

;; This code provides some useful keyboard navigation functions.

;;; m4_limitation_of_warranty

;;; m4_install_instructions(d-key-nav)

;;; Known Bugs:

;; None so far!

;;; Code:

;;(global-set-key [delete] 'd-delete-key)

(defun d-delete-key ()
  (interactive)
  (save-match-data
    (condition-case nil
        (cond
         ((eobp)
          (beep))
         ((looking-at "[ \t]*$")
          (progn
            ;;(d-foo)
            (delete-region (point) (save-excursion (end-of-line)
                                                   (if (= (point) (point-max))
                                                       (progn
                                                         (beep)
                                                         (point))
                                                     (1+ (point)))))))
         (t
          (delete-char 1)))
      ((error nil)
       (beep)))))

(global-set-key [backspace] 'd-backspace-key)

(defun d-backspace-key ()
  (interactive)
  (save-match-data
    (cond
     ((bobp)
      (beep)
      ;;(message "Beginning of buffer")
      )
     ((= (current-column) 0)
      (progn
        (backward-delete-char 1)
        (delete-region (point)
                       (save-excursion
                         (skip-chars-backward " \t")
                         (point)))))
     (t
      (backward-delete-char 1)))))



;; defun navigation (defun meaning open brace in column zero)

(defun d-beginning-of-defun ()
  (interactive)
  (save-match-data
    (push-mark (point) 'no-msg)
    (beginning-of-defun)))

(defun d-end-of-defun ()
  (interactive)
  (save-match-data
    (push-mark (point) 'no-msg)
    (end-of-defun)))

(if (and (boundp 'emacs-dialect--xemacs-p) emacs-dialect--xemacs-p)
    (progn
      (global-set-key [(control meta up)]
                      (function
                       (lambda () (interactive)
                         (d-scroll-up (- (window-height) 2)))))
      (global-set-key [(control meta down)]
                      (function
                       (lambda () (interactive)
                         (d-scroll-down (- (window-height) 2)))))
      )
  (global-set-key [(meta up)] 'backward-page)
  (global-set-key [(meta down)] 'forward-page)
  ;;(global-set-key [(control up)] 'd-beginning-of-defun)
  ;;(global-set-key [(control down)] 'd-end-of-defun)
  )

;;;
;;; NOTE: Why this?
;;;
(global-set-key [(control meta backspace)] 'nil)
(global-set-key [(control meta delete)]    'nil)


;; extremely cool paragraph-filling!!!
;; patch to ensure closing comment appears in the correct place...
;;
(defadvice fill-paragraph (after d-key-nav activate)
  (save-match-data
    (save-excursion
      (beginning-of-line)
      (if (and (or (eq major-mode 'java-mode)
                   (eq major-mode 'c++-mode)
                   (eq major-mode 'c-mode))
               (memq 'font-lock-comment-face (text-properties-at (point)))
               (not (save-excursion
                      (beginning-of-line)
                      (looking-at ".*//"))))
          (if (not (save-excursion
                     (search-forward "*/")
                     (beginning-of-line)
                     (looking-at "\\s-*\\*/")))
              (save-excursion
                (search-forward "*/")
                (forward-char -2)
                (insert "\n")
                (execute-kbd-macro "\t")
                ;;          (execute-kbd-macro "/")
                ;;          (insert "CAT")
                ))
        ))))



;;;
;;; NAVIGATION: These functions are for navigating blank spaces, where they occur.
;;;
;;; NOTE: obsolete
;;;
;;(defun d-backward-hungry-delete ()
;;  (interactive)
;;  (let ((here (point)))
;;    (skip-chars-backward " \t")
;;    (if (/= (point) here)
;;        (delete-region (point) here)
;;      (backward-delete-char 1)
;;      )
;;    ))
;;
;;(defun d-hungry-delete ()
;;  (interactive)
;;  (let ((here (point)))
;;    (skip-chars-forward " \t")
;;    (if (= ?\n (char-after (point)))
;;        (forward-char))
;;    (if (/= (point) here)
;;        (delete-region (point) here)
;;      (delete-char 1)
;;      )
;;    ))
;;
(defun d-set-regexps ()
  (setq knav--letter-regexp "[^ \t\n]");;"[0-9A-Za-z]")
  (setq knav--spacer-regexp "[ \t._-]")
  (setq knav--nonspacer-regexp "[^ \t._-]")
  (setq knav--nonspacer-spacer-regexp (concat knav--nonspacer-regexp knav--spacer-regexp))
  (setq knav--spacer-nonspacer-regexp (concat knav--spacer-regexp knav--nonspacer-regexp))
  (setq knav--white-regexp "[ \t]")
  (setq knav--alphanumeric-regexp "[a-zA-Z0-9]")
  (setq knav--init-regexp "[^a-zA-Z0-9\n \t]") ;; all but ALPHA and WHITE and LF
  )

;; C-backspace/delete kills sexp's
(global-set-key [(control delete)]    'd-shift-delete)
(global-set-key [(meta    delete)]    'd-shift-delete)
(global-set-key [(shift   delete)]    'd-shift-delete)

(defvar d-delete-backspace-list nil
  "Used to store dabbrevs of deleted or backspaced text"
  )

(defun d-shift-delete ()
  (interactive)
  (save-match-data
    (d-set-regexps)
    (let ((min               (point))
          (reverse-was-clear nil))
      (setq reverse-was-clear (or (bolp) (delta-looking-at knav--spacer-regexp -1)))

      (if (and (not reverse-was-clear) (looking-at knav--spacer-nonspacer-regexp))
          (forward-char 1))

      (cond
       ((looking-at knav--init-regexp)
        (while (looking-at knav--init-regexp)
          (forward-char 1)))

       ((looking-at knav--alphanumeric-regexp)
        (while (looking-at knav--alphanumeric-regexp)
          (forward-char 1))
        ;; HACK!
        (if (and reverse-was-clear
                 (looking-at knav--spacer-nonspacer-regexp))
            (forward-char 1)))

       ;;   ((and (string-match knav--letter-regexp (knav--get-char-prior-as-string))
       ;;         (looking-at "[ \t][a-zA-Z]"))
       ;;    (forward-char 1)
       ;;    (while (looking-at "[a-zA-Z]")
       ;;      (forward-char 1))
       ;;      )
       ;;   ((looking-at nonjoiner-regexp)
       ;;    (while (looking-at nonjoiner-regexp)
       ;;      (forward-char 1))
       ;;    (while (looking-at "[ \t/_-]")
       ;;      (forward-char 1)))
       ((looking-at knav--white-regexp)
        (while (looking-at knav--white-regexp)
          (forward-char 1))
        (if (looking-at "\n")
            (forward-char 1))
        )
       ((not (eq (point) (point-max)))
        (forward-char 1))
       )
      (let ((s (buffer-substring-no-properties min (point)))
            (x nil)
            (n nil))
        (when (not (member s d-delete-backspace-list))
          (setq d-delete-backspace-list (cons s d-delete-backspace-list))
          (setq n (nthcdr 10 d-delete-backspace-list))
          (if n (setcar n nil))))
      (delete-region min (point)))))

(defun knav--get-char-prior-as-string ()
  (if (eq (point) (point-min))
      ""
    (make-string 1 (char-after (1- (point))))))

(defun knav--was-looking-at (regexp)
  (save-match-data
    (if (eq (point) (point-min))
        nil
      (string-match regexp (knav--get-char-prior-as-string)))))

(defun delta-looking-at (regexp delta)
  (save-match-data
    (let ((new-point (+ (point) delta)))
      (if (and (< new-point (point-max)) (> new-point (point-min)))
          (save-excursion
            (goto-char new-point)
            (looking-at regexp))))))

;; C-backspace/delete kills sexp's
(global-set-key [(control backspace)] 'd-shift-backspace)
(global-set-key [(meta backspace)]    'd-shift-backspace)
(global-set-key [(shift backspace)]   'd-shift-backspace)

(defun d-shift-backspace ()
  (interactive)
  (save-match-data
    (d-set-regexps)
    (let ((max               (point))
          (reverse-was-clear nil))
      (setq reverse-was-clear (or (eolp) (looking-at knav--spacer-regexp)))

      ;; HACK!
      (if (knav--was-looking-at "/")
          (forward-char -1))

      (if (and (not reverse-was-clear)
               (delta-looking-at knav--nonspacer-spacer-regexp -2))
          (forward-char -1))

      (cond
       ((knav--was-looking-at knav--init-regexp)
        (while (knav--was-looking-at knav--init-regexp)
          (forward-char -1))
        )
       ((knav--was-looking-at knav--alphanumeric-regexp)
        (while (knav--was-looking-at knav--alphanumeric-regexp)
          (forward-char -1))
        ;; HACK!
        (if (and reverse-was-clear
                 (delta-looking-at knav--nonspacer-spacer-regexp -2))
            (forward-char -1))

        )
       ;;   ((knav--was-looking-at nonjoiner-regexp)
       ;;    (while (knav--was-looking-at nonjoiner-regexp)
       ;;      (forward-char -1))
       ;;    (while (knav--was-looking-at "[ \t/_-]")
       ;;      (forward-char -1)))
       ((knav--was-looking-at knav--white-regexp)
        (while (knav--was-looking-at knav--white-regexp)
          (forward-char -1)))
       ((knav--was-looking-at "\n")
        (forward-char -1)
        (while (knav--was-looking-at knav--white-regexp)
          (forward-char -1)))
       ((not (eq (point) (point-min)))
        (forward-char -1))
       )
      (let ((s (buffer-substring-no-properties (point) max))
            (x nil)
            (n nil))
        (when (not (member s d-delete-backspace-list))
          (setq d-delete-backspace-list (cons s d-delete-backspace-list))
          (setq n (nthcdr 10 d-delete-backspace-list))
          (if n (setcar n nil))))
      (delete-region (point) max))))

;;(defun d-shift-backspace ()
;;  (interactive)
;;  (setq max (point))
;;  (if (eq (char-after (1- (point))) ?\n)
;;      (progn
;;        (forward-char -1)
;;        (while (eq (char-syntax (char-after (1- (point)))) ?\ )
;;          (forward-char -1)))
;;    (if (and (eq (char-after (1- (point))) ?\ )
;;             (eq (char-after (- (point) 2)) ?\ ))
;;        (progn
;;          (while (eq (char-after (1- (point))) ?\ )
;;            (forward-char -1)))
;;      (let ((table (syntax-table)))
;;        ;;      (d-foo)
;;        (unwind-protect
;;            (progn
;;              (set-syntax-table (or c-mode-syntax-table
;;                                    (syntax-table)))
;;              (goto-char (max
;;                          (save-excursion
;;                            (forward-word -1)
;;                            (point))
;;                          (save-excursion
;;                            (beginning-of-line)
;;                            (point))))
;;              (set-syntax-table table)))
;;        )))
;;  (delete-region max (point))
;;  )
;;

;;; lazy cursor movement that skips over whitespace...
;;;
;;(defun d-left-over-whitespace ()
;;  (interactive)
;;  (if (> (point) (point-min))
;;      (if (or (= (char-after (- (point) 1)) ? )
;;              (= (char-after (- (point) 1)) ?\t))
;;          (while (and (> (point) (point-min))
;;                      (or (= (char-after (- (point) 1)) ? )
;;                          (= (char-after (- (point) 1)) ?\t)))
;;            (backward-char))
;;        (backward-char)
;;        ))
;;  )
;;(defun d-right-over-whitespace ()
;;  (interactive)
;;  (if (< (point) (point-max))
;;      (if (or (= (char-after (point)) ? ) (= (char-after (point)) ?\t))
;;          (while (and (< (point) (point-max))
;;                      (or (= (char-after (point)) ? )
;;                          (= (char-after (point)) ?\t)))
;;            (forward-char))
;;        (forward-char))
;;    ))
;;
(global-set-key [(control left)]  'd-backward-sexp)
(global-set-key [(meta left)]     'd-backward-sexp)
(global-set-key [(shift left)]    'd-backward-sexp)

(defun d-backward-sexp ()
  (interactive)
  (save-match-data
    (if (> (point) (point-min))
        (if (and (eq (char-after (1- (point))) ?\ )
                 (eq (char-after (- (point) 2)) ?\ ))
            (skip-chars-backward " ")
          (condition-case err
              (forward-sexp -1)
            (error (beep)))
          ))))

(global-set-key [(control right)] 'd-forward-sexp)
(global-set-key [(meta right)]    'd-forward-sexp)
(global-set-key [(shift right)]   'd-forward-sexp)

(defun d-forward-sexp ()
  (interactive)
  (save-match-data
    (if (looking-at "[ \t]*$")
        (progn
          (setq p (point))
          (skip-chars-forward " \t\r\n")
          ;;(kill-region p (point))
          )
      (if (< (point) (point-max))
          (if (and (eq (char-after (point)) ?\ )
                   (eq (char-after (1+ (point))) ?\ ))
              (skip-chars-forward " ")
            (condition-case err
                (forward-sexp 1)
              (error (beep)))
            )))))

;;;
;;; easy-scrolling...
;;;

(defun d-smooth-up ()
  (interactive)
  (d-deposit-mark-if-small-movement)
  (if (boundp 'rsi-keystroke-count)
      (setq rsi-keystroke-count (1- rsi-keystroke-count)))
  (if (eq (frame-height (car (frame-list))) 43)
      (d-scroll-up 2)
    (d-scroll-up 1))
)
(defun d-smooth-down ()
  (interactive)
  (d-deposit-mark-if-small-movement)
  (if (boundp 'rsi-keystroke-count)
      (setq rsi-keystroke-count (1- rsi-keystroke-count)))
  (if (eq (frame-height (car (frame-list))) 43)
      (d-scroll-down 2)
    (d-scroll-down 1))
  )

(global-set-key "\C-xns"
                (function
                 (lambda () (interactive)
                   (let (p q)
                     (setq p (point))
                     (forward-sexp 1)
                     (setq q (point))
                     (backward-sexp 1)
                     (narrow-to-region p q)))))

;;(message "Provided feature d-key-nav.el")
(provide 'd-key-nav)
;;; d-key-nav.el ends here
