;;; Time-stamp: <2007-08-23 11:16:43 jcgs>

;; Copyright (C) 2007, John C. G. Sturdy

;; Author: John C. G. Sturdy <john@cb1.com>
;; Maintainer: John C. G. Sturdy <john@cb1.com>
;; Created: long ago
;; Keywords: convenience

;; This file is NOT part of GNU Emacs.

(provide 'keys)
(require 'cl)
(require 'shell)			; to get inferior-lisp-mode-map

(require 'structure-edit)

(defun alias-key (key-map given-key meaning-key)
  "Define, in KEY-MAP, GIVEN-KEY to be equivalent to MEANING-KEY."
  (define-key key-map given-key (lookup-key key-map meaning-key)))

(defun define-lisp-key (key command)
  "Define KEY to run COMMAND in all lisp modes."
  ;; todo: put the definitions in lisp-mode-hook, and that will get called in all these modes
  (setq maps '(lisp-mode-map
	       emacs-lisp-mode-map
	       lisp-interaction-mode-map
	       inferior-lisp-mode-map))
  (while maps
    (let ((map (car maps)))
      (if (boundp map)
	  (define-key (eval map) key command))
      (setq maps (cdr maps)))))

(defun self-insert-or-move (char move prefix)
  "Either insert CHAR, if in a string or comment, or do MOVE passing PREFIX otherwise."
  (let* ((bod (save-excursion (beginning-of-defun 1) (point)))
	 (pps (parse-partial-sexp bod (point))))
    (if (or (nth 3 pps) (nth 4 pps))
	(insert char)
      (funcall move prefix))))

(defun lisp-curly-bra (n)
  "Insert curly bra if in string or comment, or do backward-sexp."
  (interactive "p")
  (self-insert-or-move ?{ 'backward-up-list n))

(defun lisp-curly-ket (n)
  "Insert curly ket if in string or comment, or do forward-sexp."
  (interactive "p")
  (self-insert-or-move ?} 'down-list n))

(defun lisp-square-bra (n)
  "Insert square bra if in string or comment, or do backward-sexp."
  (interactive "p")
  (self-insert-or-move ?[ 'backward-sexp n))

(defun lisp-square-ket (n)
  "Insert square ket if in string or comment, or do forward-sexp."
  (interactive "p")
  (self-insert-or-move ?] 'forward-sexp n))

(define-lisp-key "]" 'lisp-square-ket)
(define-lisp-key "[" 'lisp-square-bra)
(define-lisp-key "}" 'lisp-curly-ket)
(define-lisp-key "{" 'lisp-curly-bra)
(global-set-key "\e:" 'electric-command-history)
(setq enable-recursive-minibuffers t)

(define-lisp-key "\C-c\C-s" 'compile-system)
(define-lisp-key "\C-c\C-l" 'load-system)

(defun comment-or-otherwise-indent-new-line ()
  "If in a comment, continue it to a new line; otherwise new line and indent."
  (interactive)
  (let* ((bod (save-excursion (beginning-of-defun 1) (point)))
	 (pps (parse-partial-sexp bod (point))))
    (if (nth 4 pps)
	(comment-indent-new-line)
      (newline-and-indent))))

(define-lisp-key "\C-j" 'comment-or-otherwise-indent-new-line)
(define-key lisp-interaction-mode-map "\C-j" 'eval-print-last-sexp)

;; (global-set-key "\e\C-y" 'browse-yank)
(global-set-key "\e\C-y" 'electric-yank-menu)

(defun define-inf-lisp-plus-keys ()
  "Define keys for these inferior lisp extensions."
  (define-key lisp-mode-map "\C-c\C-x" 'send-defun-in-package)
  (define-key lisp-mode-map "\e\C-x" 'send-defun-in-package)
  (define-key lisp-mode-map "\C-c\C-s" 'compile-system)
  (define-key lisp-mode-map "\C-c\C-l" 'load-system)
  (define-key lisp-mode-map "\C-c\C-p" 'load-patches)
  (define-key lisp-mode-map "\C-c\C-a" 'load-all)
  (define-key lisp-mode-map "\C-c\C-f" 'lisp-compile-file)
  (define-key lisp-mode-map "\C-c\C-r" 'ensure-lisp-process))

(global-set-key "\C-\\" 'recursive-edit)
(global-set-key "\C-x\C-b" 'electric-buffer-list)
(global-set-key "\C-x\C-k" 'super-kill)
(global-set-key "\C-x\C-y" 'browse-yank)
;; (global-set-key "\C-xc" 'wander-safe)

(let ((env-term (getenv "TERM")))
  (if (and env-term (string-match "vt" env-term))
      (load-library "vt220-keys")))

(define-lisp-key "\C-cf" 'insert-function-name)
(define-lisp-key "\C-cv" 'insert-variable-name)
(define-key lisp-mode-map "\e\C-x" 'send-defun-in-package)
(define-inf-lisp-plus-keys)

(require 'ctl-x-7)

(global-set-key "\C-x\C-c" 'exit-saving-buffers)
(global-set-key "\C-x\C-b" 'electric-buffer-list)
(global-set-key "\^x4\^r" 'find-file-read-only-other-window)

(defun jcgs-keys:function-key-help ()
  "Display the function key settings"
  (interactive)
  (with-output-to-temp-buffer "*Help*"
    (mapcar (lambda (modifier)
	      (let ((keynum 1))
		(while (<= keynum 12)
		  (let* ((keyname (format "%sf%d" modifier keynum))
			 (keysym (intern keyname))
			 (key-binding (key-binding (vector keysym))))
		    (if (symbolp key-binding)
			(princ (format "%s %s\n"  keyname
				       (symbol-name key-binding)))
		      (princ (format "%s: prefix\n" keyname))))
		  (setq keynum (1+ keynum))))
	      (princ "\n"))
	    '("" "C-" "M-"))))

(defun jcgs-keys:function-key-table ()
  "Make a table of the function key settings"
  (mapcar (lambda (modifier)
	    (let ((bindings nil)
		  (keynum 12))
	      (while (>= keynum 1)
		(let* ((keyname (format "%sf%d" modifier keynum))
		       (keysym (intern keyname))
		       (key-binding (key-binding (vector keysym))))
		  (push 
		   (if (symbolp key-binding)
		       (symbol-name key-binding)
		     "prefix")
		   bindings))
		(setq keynum (1- keynum)))
	      bindings))
	  '("" "C-" "M-")))

(defun longest-lengths (list-of-lists)
  "Return a list of the longest entries in LIST-OF-LISTS."
  (mapcar (lambda (list)
	    (apply 'max (mapcar 'length list)))
	  list-of-lists))

(defun save-all-buffers-no-ask ()
  "Save all buffers, without prompting for each one."
  (interactive)
  (save-some-buffers t)
  (message "Saved all buffers"))

(defvar other-window-or-buffer-consecutive-count 0
  "How many consecutive commands have been other-window-or-buffer")

(defvar other-window-or-buffer-previous-used-buffer nil
  "The buffer from which we most recently started a series of other-window-or-buffer commands.")

(defvar other-window-or-buffer-previous-previous-used-buffer nil
  "The buffer from which we next-most recently started a series of other-window-or-buffer commands.")

(defun other-window-or-buffer ()
  (interactive)
  "Switch to the next window, or, if there is only one window, the next buffer."
  (setq other-window-or-buffer-consecutive-count
	(if (eq last-command 'other-window-or-buffer)
	    (1+ other-window-or-buffer-consecutive-count)
	  1))
  (if (= other-window-or-buffer-consecutive-count 1)
      (setq other-window-or-buffer-previous-previous-used-buffer
	    other-window-or-buffer-previous-used-buffer
	    other-window-or-buffer-previous-used-buffer (current-buffer)))
  (if (one-window-p)
      (cond
       ((<= other-window-or-buffer-consecutive-count 2)
	(switch-to-buffer other-window-or-buffer-previous-previous-used-buffer))
       ((<= other-window-or-buffer-consecutive-count 3)
	(switch-to-buffer (other-buffer)))
       (t
	(switch-to-buffer (nth other-window-or-buffer-consecutive-count
			       (buffer-list)))
	(message "Next one will be %s"
		 (buffer-name (nth (1+ other-window-or-buffer-consecutive-count)
				   (buffer-list))))))
    
    (if (<= other-window-or-buffer-consecutive-count 2)
	(other-window 1)
      (delete-other-windows))))

(defun other-window-backwards (n)
  "Select the -Nth window -- see other-window, this just negates the argument."
  (interactive "p")
  (other-window (- n)))

(defun warn-moved ()
  (interactive)
;;  (switch-to-buffer (get-buffer-create "*Moved*"))
;;  (erase-buffer)
;;  (insert "That key has moved -- try a function key!\n")
  (message "That key has moved -- try a function key!")
  (ding))

(defun keypad-separate ()
  "Remove mappings of keypad keys."
  (interactive)
  (let* ((holder (cons nil (cdr function-key-map)))
	 (pairs holder)
	 (nextpairs (cdr pairs)))
    (while pairs
      (let* ((pair (car nextpairs))
	     (name (car pair)))
	(if (and (symbolp name)
		 (string-match "kp-" (symbol-name name)))
	    (progn
	      (message "Unmapping %S from function-key-map" name)
	      (rplacd pairs (cdr nextpairs))
	      (setq nextpairs (cdr pairs)))
	  (progn
	    (setq pairs (cdr pairs)
		  nextpairs (cdr pairs))))))
    (rplacd function-key-map (cdr holder))))

(defun show-keypad-bindings (buffer-name)
  "Display the current keypad bindings.
Originally for debugging, but might be useful elsewhere."
  (interactive (list "*Keypad*"))
  (let (
	(width 16))
    (with-output-to-temp-buffer buffer-name
      (let* ((hsepseg (make-string (+ width 2) ?-))
	     (hsep (concat "+"
			   (mapconcat 'identity (list hsepseg hsepseg hsepseg hsepseg) "+")
			   "+\n"))
	     (vformseg (format " %% %ds " width))
	     (vform (concat "|"
			    (mapconcat 'identity (list vformseg vformseg vformseg vformseg) "|")
			    "|\n"))
	     )
	(mapcar
	 (function
	  (lambda (keymap-name)
	    (princ (format "%s:\n" keymap-name))
	    (let ((keymap (eval keymap-name)))
	      (mapcar
	       (function
		(lambda (row)
		  (princ hsep)
		  (princ (apply 'format vform
				(mapcar
				 (function
				  (lambda (key)
				    (if key
					(let* ((keysym (lookup-key keymap (vector key)))
					       (keyname (symbol-name keysym)))
					  (if (<= (length keyname) width)
					      keyname
					    (substring keyname 0 width))
					  )
				      "")))
				 row)))))
	       '((kp-home kp-up kp-prior kp-+)
		 (kp-left kp-home kp-right nil)
		 (kp-end kp-down kp-next kp-enter)
		 (kp-insert nil kp-delete nil)
		 ))
	      (princ hsep))
	    (princ "\n")))
	 '(minibuffer-local-map 
	   minibuffer-local-ns-map
	   minibuffer-local-completion-map
	   minibuffer-local-must-match-map
	   read-expression-map))))))

(defvar use-lisp-kp-arrow-keys nil
  "*Whether to set up the arrow keys to suit Lisp.")

(defvar jcgs-planner-map (make-sparse-keymap)
  "Map for JCGS' planner actions.")

(fset 'jcgs-planner-map jcgs-planner-map)

(defun jcgs-keys:jcgs-function-keys ()
  "Set up John's function keys."
  (interactive)

  (define-key jcgs-planner-map "h" 'jcgs-planner-key-help)
  (define-key jcgs-planner-map "t" 'planner-create-task-from-buffer)
  (define-key jcgs-planner-map "T" 'planner-create-task)
  (define-key jcgs-planner-map "p" 'plan)
  (define-key jcgs-planner-map "g" 'planner-goto-today-and-current-task)
  (define-key jcgs-planner-map "u" 'planner-update-task)
  (define-key jcgs-planner-map "U" 'planner-id-update-tasks-on-page)
  (define-key jcgs-planner-map "d" 'planner-task-done)
  (define-key jcgs-planner-map [ up ] 'planner-raise-task-priority)
  (define-key jcgs-planner-map [ down ] 'planner-lower-task-priority)
  (define-key jcgs-planner-map "m" 'planner-replan-task)
  (define-key jcgs-planner-map "r" 'planner-copy-or-move-task)
  (define-key jcgs-planner-map "?" 'planner-show-current-task)
  (define-key jcgs-planner-map [ f4] 'planner-dwim)

  (global-set-key [   C-f1  ] 'delete-other-windows)
  (global-set-key [ C-M-f1  ] 'delete-window)

  (global-set-key [   C-f2  ] 'split-window-horizontally)

  (global-set-key [     f3  ] 'kill-ring-save)
  (global-set-key [   C-f3  ] 'kill-region)
  (global-set-key [   M-f3  ] 'yank)
  (global-set-key [ C-M-f3  ] 'delete-region)

  (global-set-key [     f4  ] 'jcgs-planner-map)

  (global-set-key [     f5  ] 'find-file)
  (global-set-key [   C-f5  ] 'find-file-at-point)
  (global-set-key [ M-C-f5  ] 'find-file-at-point-other-window)
  (global-set-key [   M-f5  ] 'find-file-other-window)

  (global-set-key [     f6  ] 'switch-to-buffer)
  (global-set-key [   C-f6  ] 'electric-buffer-list)
  (global-set-key [   M-f6  ] 'switch-to-buffer-other-window-beside)

  (global-set-key [     f7  ] ctl-x-7-map)
  (global-set-key [   C-f7  ] 'bury-this-buffer)
  (global-set-key [   M-f7  ] ctl-x-7-3-map)
  (global-set-key [ C-M-f7  ] ctl-x-7-4-map)

  (global-set-key [     f8  ] 'other-window-or-buffer)
  (global-set-key [   C-f8  ] 'other-window-backwards)

  (global-set-key [     f9  ] ctl-x-map)
  (global-set-key [   C-f9  ] ctl-x-4-map)

  (global-set-key [     f10 ] 'execute-extended-command)
  (global-set-key [   M-f10 ] 'eval-defun)

  (global-set-key [     f11 ] 'save-all-buffers-no-ask)
  (global-set-key [   C-f11 ] 'js-vm-get-mail)
  (global-set-key [   M-f11 ] 'type-break)
  (global-set-key [ M-C-f11 ] 'vm-continue-composing-message)

  (global-set-key [     f12 ] 'smart-repeat-complex-command)
  (define-key minibuffer-local-map [ f12 ] 'previous-history-element)
  (define-key minibuffer-local-map [ C-f12 ] 'next-history-element)
  (global-set-key [   C-f12 ] 'repeat-matching-complex-command)

  ;; (keypad-separate)
  (if use-lisp-kp-arrow-keys
      (progn
	(global-set-key [ kp-up ] 'backward-up-list)
	(global-set-key [ kp-down ] 'down-list)
	(global-set-key [ kp-left ] 'backward-sexp)
	(global-set-key [ kp-right ] 'forward-sexp)
	(global-set-key [ kp-prior ] 'beginning-of-defun)
	(global-set-key [ kp-next ] 'end-of-defun)))

  (show-keypad-bindings "*Before versor*")

  (message "Setting up versor")
  (require 'versor)
  (versor-setup
   'arrows
   'arrows-misc
   ;; 'keypad
   ;; 'keypad-misc

   ;; the pedals setup for versor is done in the pedals setup code,
   ;; rather than in versor, as versor is more general than just for
   ;; pedal use
   'research
   'modal
   'quiet-underlying
   'text-in-code
   'mouse
   'tlc)

  (global-set-key [ C-y ] 'versor-yank)

  (require 'versor-menu)
  (require 'versor-local)
  (message "Initializing versor-mode-current-levels, was %S" versor-mode-current-levels)
  
  (message "Initialized versor-mode-current-levels to %S" versor-mode-current-levels)
  (require 'versor-modal)
  (add-hook 'kill-emacs-hook 'versor-save-research-data)

  ;; (require 'intensive-edit)

  (show-keypad-bindings "*After versor but before pedals*")

  (message "Setting up pedals")
  (setq pedal:versor-change-dimension-ctrl t
	pedals-hosts-preferring-num-lock '("hosea"))
  (require 'keypad)
  (keypad-setup)
  (require 'handsfree)
  (pedals-setup)
  (if (or (string= (downcase (system-short-name)) "joel")
	  (string= (downcase (system-short-name)) "glg"))
      ;; only joel/glg has such a key
      (add-lispdir "$COMMON/my-extensions-to-packages/voice")
      (require 'voice-assist-key))		; re-assigns one of the pedals, so do after versor etc

  (show-keypad-bindings "*After pedals*")

  (message "Keyboard and pedals setup complete")
  )

(jcgs-keys:jcgs-function-keys)

;; (global-set-key [ M-C-z ] 'lower-frame)

(defvar frame-is-down nil
  "Whether we think the default frame is lowered.")

(defun frame-toggle-updown ()
  "Raise or lower the frame -- whichever we didn't do last time."
  (interactive)
  (if frame-is-down
      (raise-frame)
    (lower-frame))
  (setq frame-is-down (not frame-is-down)))
  
(global-set-key "\e\C-z" 'frame-toggle-updown)

(defun smart-repeat-complex-command ()
  (interactive)
  "Like repeat-complex-command, but may skip the first one if it would do nothing."
  (let* ((rest command-history)
	 (from 1))
    (while (and rest
		(let* ((last-command (car rest))
		       (last-command-function (car last-command))
		       (last-command-first-arg (cadr last-command)))
		  (or (and (eq last-command-function 'switch-to-buffer)
			   (string= last-command-first-arg
				    (buffer-name)))
		      (and (memq last-command-function '(find-file find-file-other-window))
			   (string= last-command-first-arg
				    (buffer-file-name)))) ))
      (setq from (1+ from)
	    rest (cdr rest)))
    (repeat-complex-command from)))

;;; end of keys.el