;;; -*- Mode: Emacs-Lisp -*-

;;; Version 2.0

;;; Place this file in your home directory with the name .emacs

;;; Emacs should find it at startup. Otherwise use M-x load-file RET .emacs to load it manually.

;;; One-line abcl.bat Windows batch file to run ABCL in a command shell which you should place in, e.g. "C:\Users\Elliott\ai\abcl.bat":
;;;
;;;   java -jar "C:\Users\Elliott\ai\abcl.jar"
;;;
;;; Adjust the batch file to point to where you have the ABCL.jar file.
;;; On Windows you need to adjust your System Environment variable for path to point to "C:\Users\Elliott\ai"

;;; On Mac or Linux: Create an abcl sh file:

;;;  #! /bin/sh
;;;  echo "Running LISP from a shell script"
;;;  java -jar /Users/elliott/ai/abcl.jar

;;; Use...
;;; chmod 755 abcl
;;; ...to make your shell script executable.

;;; On Mac/unix you may need to add this line to your /etc/paths file: /Users/YourAccountName/ai so that the system can find
;;; your shell script. Adapt the path as needed.

;;; On Mac, to edit your /etc/paths file, you can use:

;;; sudo nano /etc/paths

;;; Add two new lines:

;;; .  <-- one with just a period on it

;;; /Users/YOURACCOUNTNAME/ai   <-- one with the directory where you put your shell script.

;;; Note that the little hat means "control-key"


;;; Then, for either system set this variable to point to your script/batch file that runs LISP:

(setq inferior-lisp-program "c:/e/ai/abcl")

;;; Note that in THIS .emacs file all paths use the forward slash, including on Windows.

;;; Now, to run LISP in a shell window use:

;;; M-x run-lisp

;;; That's it!

;;; 2019-04-09, Elliott:
;;; This .emacs file is a thirty-year mess, but it should work as is for editing and running lisp.
;;; 
;;; See the documentation on the custom key-bindings in the Emacs Reference Card I have provided, which make working in emacs much easier.
;;;
;;; C- means Control-key then something following, M- means meta key then something following
;;; 
;;; C-g will "go back" to recover from errors.
;;; 
;;; C-x, C-c will kill emacs.
;;; 
;;; Following are some modifications.
;;; 
;;; The meta key, as in M-x, is set to Control-[ which is easier than ESC.
;;; 
;;; C-w, and C-q move the cursor forward and back one word. Much easier!
;;; 
;;; C-e and C-a take the cursor to the end of the line and beginning of the line respectively.
;;; 
;;; C-spacebar sets the mark. As you move the cursor, the region grows.
;;; 
;;; C-c, C-k kills the region, C-y puts it back. This results in the region now being in the clipboard.
;;;
;;; The above two lines are very powerful for moving text around within a file and between buffers.
;;;
;;; C-c, D enters the current date into the file.
;;; 
;;; C-k kills a line of text.
;;;
;;; Tab, or C-i, indents a line of code correctly.
;;; 
;;; M-s sends the current LISP DEFUN to the clipboard, after which C-y will insert it into LISP buffer.
;;; 
;;; C-c, C-e evaluates the current defun in the lisp buffer
;;; C-c, C-r evaluates the current region in the lisp buffer


;;; For major LISP development: Install and use SLIME to run in shell. See notes at the bottom.

;;; C-u, M-x, shell will ask for the name of multiple shells. Yay!

;;; Set the default font to Consolas--much easier to read!
;;; https://en.wikipedia.org/wiki/List_of_monospaced_typefaces

;;; Put this .emacs file in your C:\ directory on Windows. 
;;; You may need to set the HOME variable

;;; Or, put this .emacs file in your /Users/YourAccountName/ on the mac.

;;; Can also load with M-x Load-file RET then the name of this file for either system

;; 2008-08-17 added insert-date-string on C-c, d

;;; The emacs.ini file, which should reside in your Emacs home directory
;;; allows you to customize the behavior of Emacs.
;;;

;;; Also, sent the default font to Consolas--much easier to read!
;;; https://en.wikipedia.org/wiki/List_of_monospaced_typefaces

;;; This is a sample emacs.ini file.
;;;
;;; The emacs.ini file, which should reside in your Emacs home directory
;;; (defined by the EMACSHOME environment variable, which defaults to C:\),
;;; allows you to customize the behavior of Emacs.  In general, changes to
;;; your emacs.ini file will not take effect until the next time you start
;;; up Emacs.  You can load it explicitly with
;;; `M-x load-file RET c:\emacs.ini RET'. (You may have to correct the
;;; pathname.)
;;;
;;; There is a great deal of documentation on customization in the Emacs
;;; manual.  You can read this manual with the online Info browser: type
;;; `C-h i' or select "Emacs Info" from the "Help" menu.



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;			Basic Customization			    ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Older versions of emacs did not have these variables
;;; (emacs-major-version and emacs-minor-version.)
;;; Let's define them if they're not around, since they make
;;; it much easier to conditionalize on the emacs version.

;;; 2008-11-03:
(setq text-mode-hook 'turn-on-auto-fill)


(if (and (not (boundp 'emacs-major-version))
	 (string-match "^[0-9]+" emacs-version))
    (setq emacs-major-version
	  (string-to-int (substring emacs-version
				    (match-beginning 0) (match-end 0)))))
(if (and (not (boundp 'emacs-minor-version))
	 (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version))
    (setq emacs-minor-version
	  (string-to-int (substring emacs-version
				    (match-beginning 1) (match-end 1)))))

(setq running-xemacs (string-match "Lucid" emacs-version))
(setq running-emacs-19 (>= emacs-major-version 19))
(setq running-fsf-emacs-19 (and running-emacs-19 (not running-xemacs)))
(setq running-emacs-18 (< emacs-major-version 19))
(setq running-x (eq window-system 'x))

;; Enable the commands `narrow-to-region' ("C-x n n") and 
;; `eval-expression' ("M-ESC", or "ESC ESC").  Both are useful
;; commands, but they can be confusing for a new user, so they're
;; disabled by default.
(put 'narrow-to-region 'disabled nil)
(put 'eval-expression 'disabled nil)


;; Make the sequence "C-x C-j" execute the `goto-line' command, 
;; which prompts for a line number to jump to.
(global-set-key "\C-x\C-j" 'goto-line)



(cond (running-xemacs
       ;;
       ;; Code for any version of Lucid Emacs goes here
       ;;

       ;; Change the values of some variables.
       ;; (t means true; nil means false.)
       ;;
       ;; Use the "Describe Variable..." option on the "Help" menu
       ;; to find out what these variables mean.
       (setq find-file-use-truenames nil
	     find-file-compare-truenames t
	     minibuffer-confirm-incomplete t
	     complex-buffers-menu-p t
	     )

       (cond (running-x
	      ;;
	      ;; Code which applies only when running emacs under X goes here.
	      ;; (Currently, this is always the case in lemacs, but it will
	      ;; not be in the future.)
	      ;;

	      ;; Remove the binding of C-x C-c, which normally exits emacs.
	      ;; It's easy to hit this by mistake, and that can be annoying.
	      ;; Under X, you can always quit with the "Exit Emacs" option on
	      ;; the File menu.
	      ;; (global-set-key "\C-x\C-c" nil)

	      ;; This changes the variable which controls the text that goes
	      ;; in the top window title bar.  (However, it is not changed
	      ;; unless it currently has the default value, to avoid
	      ;; interfering with a -wn command line argument I may have
	      ;; started emacs with.)
	      (if (equal screen-title-format "%S: %b")
		  (setq screen-title-format
			(concat "%S [" emacs-version "]"
				(if nil ; (getenv "NCD")
				    ""
				  "   %b"))))))


       ;;
       ;; (The following code applies whether or not we're running X.)
       ;;

       ;; Change the binding of mouse button 2, so that it inserts the
       ;; selection at point (where the text cursor is), instead of at
       ;; the position clicked.
       ;;
       ;; Note that you can find out what a particular key sequence or
       ;; mouse button does by using the "Describe Key..." option on
       ;; the Help menu.
       (define-key global-map 'button2 'x-insert-selection)

       ;; LISPM bindings of Control-Shift-C and Control-Shift-E.
       ;; Note that "\C-C" means Control-C, not Control-Shift-C.
       ;; To specify shifted control characters, you must use the
       ;; more verbose syntax used here.
       (define-key emacs-lisp-mode-map '(control C) 'compile-defun)
       (define-key emacs-lisp-mode-map '(control E) 'eval-defun)

       ;; Make F5 be `undo'
       (global-set-key 'f5 'undo)

       ;; Make F6 be `save-file' followed by `delete-window'.
       (global-set-key 'f6 "\C-x\C-s\C-x0")

       ;; Make `C-x C-m' and `C-x RET' be different (since I tend to type
       ;; the latter by accident sometimes.)
       (define-key global-map [(control x) return] nil)

       ;; Add `dired' to the File menu
       (add-menu-item '("File") "Edit Directory" 'dired t)

       ))


(cond ((and running-xemacs
	    (>= emacs-major-version 19)
	    (>= emacs-minor-version 6))
       ;;
       ;; Code which requires Lucid Emacs version 19.6 or newer goes here
       ;;
       ))

(cond (running-emacs-19
       ;;
       ;; Code for any vintage-19 emacs goes here
       ;;
       ))

(cond (running-fsf-emacs-19
       ;;
       ;; Code specific to FSF Emacs 19 (not Lucid Emacs) goes here
       ;;
       ))

(cond (running-emacs-19
       ;;
       ;; Code specific to emacs 18 goes here
       ;;
       ))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;		Customization of Specific Packages		    ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; ********************
;;; Load a partial-completion mechanism, which makes minibuffer completion
;;; search multiple words instead of just prefixes; for example, the command
;;; `M-x byte-compile-and-load-file RET' can be abbreviated as `M-x b-c-a RET'
;;; because there are no other commands whose first three words begin with
;;; the letters `b', `c', and `a' respectively.
;;;


;;; ********************
;;; Edebug is a source-level debugger for emacs-lisp programs.
;;;
;;; CDE: Look into this:
(define-key emacs-lisp-mode-map "\C-xx" 'edebug-defun)


;;; ********************
;;; Font-Lock is a syntax-highlighting package.  When it is enabled and you
;;; are editing a program, different parts of your program will appear in
;;; different fonts or colors.  For example, with the code below, comments
;;; appear in red italics, function names in function definitions appear in
;;; blue bold, etc.  The code below will cause font-lock to automatically be
;;; enabled when you edit C, C++, Emacs-Lisp, and many other kinds of
;;; programs.

;; Definition stolen from later versions of font-lock.
(defun turn-on-font-lock ()
  (font-lock-mode 1))

(require 'font-lock)
(cond (running-xemacs
       ;; font-lock exists under FSF Emacs 19 but the faces
       ;; are handled differently, and I don't feel like
       ;; porting the code now.
       (set-face-foreground 'font-lock-function-name-face "blue")
       (set-face-foreground 'font-lock-comment-face "DarkMagenta") ; cde doesn't work
       (set-face-foreground 'font-lock-string-face "blue") ; cde
       (set-face-underline-p 'font-lock-string-face nil)
       (make-face-unitalic 'font-lock-string-face)
       (make-face-unitalic 'font-lock-function-name-face)
       (make-face-unitalic 'font-lock-comment-face)
       (copy-face 'font-lock-function-name-face 'font-lock-keyword-face)
       (copy-face 'font-lock-string-face 'font-lock-doc-string-face)
       (copy-face 'font-lock-string-face 'font-lock-type-face))
      (running-fsf-emacs-19
       (make-face 'my-red-face)
       (set-face-foreground 'my-red-face "DarkMagenta")
       (make-face 'my-green-face)
       (set-face-foreground 'my-green-face "blue") ; cde
       (make-face 'my-blue-face)
       (set-face-foreground 'my-blue-face "blue")
       (setq font-lock-function-name-face 'my-blue-face)
       (setq font-lock-comment-face 'my-red-face)
       (setq font-lock-string-face 'my-green-face)
       (setq font-lock-keyword-face 'my-blue-face)
       (setq font-lock-doc-string-face 'my-green-face)
       (setq font-lock-type-face 'my-green-face)))
(add-hook 'emacs-lisp-mode-hook	'turn-on-font-lock)
(add-hook 'lisp-mode-hook	'turn-on-font-lock)
(add-hook 'c-mode-hook		'turn-on-font-lock)
(add-hook 'c++-mode-hook	'turn-on-font-lock)
(add-hook 'perl-mode-hook	'turn-on-font-lock)
(add-hook 'tex-mode-hook	'turn-on-font-lock)
(add-hook 'texinfo-mode-hook	'turn-on-font-lock)

;;; ********************
;;; Automatically save and restore the "context" (i.e. files visited
;;; and window/file configuration) when Emacs exits and starts up
;;; again. (Bug in package: only the context of the screen that is
;;; current when you exit will be saved.)
;;;
; uncomment the following lines to enable the package.
;(require 'saveconf)
;(if (null (cdr command-line-args))
;    (setq inhibit-startup-message (recover-context)))
;;; If you leave the following line commented out but uncomment the
;;; previous ones, the context will not automatically be saved, but
;;; the last saved context will automatically be restored.  Then you
;;; save the context when you want, using `M-x save-context'.
;(setq auto-save-and-recover-context t)


;;; NOTE THAT YOU MUST HAVE VARIABLE HOME or EMACSHOME SET IN YOUR AUTOEXEC
;;; FILE to find this start up file. See the file winmacs/readme:
;Specifying the Location of Startup Files
;----------------------------------------
;
;   You can specify the directory where Win-Emacs looks for startup
;files by setting the environment variables `EMACSHOME' or `HOME'.  (If
;neither is set, Win-Emacs looks in `C:\'.) For more info, *Note
;Initialization Files::.
;;;; ====================================================================

;;; Hack emacs function put together by Clark Elliott to load LISP functions to
;;; the clipboard in LISP format. In PC EMACS save-excursion does not seem
;;; to be working right, so the cursor moves to the end of the function after
;;; the send. We can live with this.  12-18-93

;;; To use the lisp-send-defun... function, place the cursor over
;;; the function you want to put in LISP. Press Meta-s  (^[-s) to put
;;; into the clipboard, alt-tab over to LISP, insert.
;;; The issue here is that emacs uses different line-end characters.

;;; Warning: this function has oddly displaying characters in it,
;;; some editors, and file transfering programs change these and the
;;; fucntion will no longer work.


(global-set-key "\M-s" 'lisp-send-defun-to-clipboard)

;;; use quoted insert ^j => ^M^J:

(defun lisp-send-defun-to-clipboard ()
  "Send the current defun to clipboard and *lisp-clipboard*"
  (interactive)
  (save-excursion
    (end-of-defun)
    (let ((end (point)))
      (beginning-of-defun)
      (kill-ring-save (point) end)
      (yank))
    (end-of-defun)
    (let ((end (point)))
      (beginning-of-defun)
      (narrow-to-region (point) end)    
      (replace-string "
" "
"))
    (let ((end (point)))
      (beginning-of-defun)
      (kill-region (point) end))
    (widen)
    ))


;;;===========================================================
;;;===========================================================

(global-set-key "\C-x\C-j" 'goto-line)

(put 'eval-expression 'disabled nil)

;; don't wrap long lines on the screen
;;; (setq truncate-lines t)

;; define c-mode stuff
(setq c-indent-level 4)
(setq c-continued-statement-offset 4)
(setq c-label-offset -2)

;(global-set-key "\C-c\C-l" 'run-lisp)
(global-set-key "\C-c\C-l" 'fi:common-lisp)
(global-set-key "\C-c\C-m" 'set-mark-command)
;;(global-set-key "\C-c\C-p" 'lpr-buffer)
(global-set-key "\C-c\C-t" 'top-of-window)  ; macro
;;;(global-set-key "\C-c\C-v" 'set-variable)
(global-set-key "\^Xn" 'goto-next-window)
(global-set-key "\^Xf" 'find-file)
(global-set-key "\^Xp" 'goto-previous-window)
(global-set-key "\^\\" 'minimenu)
;;(global-set-key "\e$" 'ispell-word) ;; would love to have these working!
;;(global-set-key "\e#" 'ispell-region)
(global-set-key "\eh" 'help-for-help)	; ESC-h is help command

;(setq fill-column 76)
(setq fill-column 4000)

(setq completion-ignored-extensions
      (append completion-ignored-extensions
              '(".class"                       ; Java class binaries
		)))
;;; this is new as of 2008-08-17:
;; C-c d calls insert-date-string
(defun insert-date-string ()
  "Insert a nicely formated date string."
  (interactive)
  (insert (format-time-string "%Y-%m-%d")))
(global-set-key (kbd "C-c d") 'insert-date-string)
;;; ---------------------------------------

(global-set-key (kbd "C-c d") 'insert-date-string)
; Default modes for certain file types: additions -- trying this...
(setq auto-mode-alist 
      (append 
         '(
	   ("\\.html$"   . text-mode); try it anyway, did not test
	   ("\\.htm$"   . text-mode) ; try it anyway, did not test
	   ("\\.java$"   . c-mode)
	   ("\\.idl$"   . c-mode)
	   ("\\.clp$"   . lisp-mode)
	   ("\\.inc$"   . lisp-mode)
	   ("\\.asp$"   . lisp-mode))
	 auto-mode-alist		       ;; defaults
	      ))


(put 'upcase-region 'disabled nil)

(put 'set-goal-column 'disabled nil)


;;------------------------------------------------------------------

;;; ---------------------------------------
;;; cde 2009-11-17: function to format text for MS Word document:
(defun make-doc ()
  "Reformat for Microsoft Word "
  (interactive)
  (end-of-buffer)(beginning-of-buffer)
  (replace-string
"

"
"kkjj")
  (end-of-buffer)(beginning-of-buffer)
  (replace-string
"
" " ")
  (end-of-buffer)(beginning-of-buffer)
  (replace-string "kkjj"
"

"))

(put 'downcase-region 'disabled nil)
;;------------------------------------------------------------------
;; The ACL LISP stuff
;;------------------------------------------------------------------
;;(setq load-path (cons "c:/Program Files/acl50/eli/" load-path))

;;;(load "c:/Program Files/acl50/eli/fi-site-init")
;;;;(setq fi:common-lisp-image-name  "c:/Program Files/acl50/eli/lisp")

; oh well -- nice try, but does not work:
;;;(defun run-lisp (&rest args) (fi:common-lisp args))
; because: 
;(defun fi:common-lisp (&optional buffer-name directory executable-image-name
;				 image-args host image-file)

;;; does not work, locally, or globally. What a pain in the ass

;;; The following seems to have been working for two years. To start
;;; LISP, fi:common-lisp
;(load "c:/lisp-x.el") ; temporary, but working lisp mode

(add-to-list 'exec-path "C:/Program Files (x86)/Aspell/bin/")
(setq ispell-program-name "aspell")
(setq ispell-personal-dictionary "C:/Program Files (x86)/Aspell/dict/")

(require 'ispell)
; M-$ is ispell by default, also M-#?
;    (global-set-key (kbd "<f8>") 'ispell-word)
;    (global-set-key (kbd "C-<f8>") 'flyspell-mode)

;;http://www.gnu.org/software/emacs/emacs-lisp-intro/html_node/Whitespace-Bug.html#Whitespace-Bug:
;;; Final version: while
     (defun wc (beginning end)
       "Print number of words in the region."
       (interactive "r")
       (message "Counting words in region ... ")
     
     ;;; 1. Set up appropriate conditions.
       (save-excursion
         (let ((count 0))
           (goto-char beginning)
     
     ;;; 2. Run the while loop.
           (while (and (< (point) end)
                       (re-search-forward "\\w+\\W*" end t))
             (setq count (1+ count)))
     
     ;;; 3. Send a message to the user.
           (cond ((zerop count)
                  (message
                   "The region does NOT have any words."))
                 ((= 1 count)
                  (message
                   "The region has 1 word."))
                 (t
                  (message
                   "The region has %d words." count))))))
(custom-set-variables
  ;; custom-set-variables was added by Custom.
  ;; If you edit it by hand, you could mess it up, so be careful.
  ;; Your init file should contain only one such instance.
  ;; If there is more than one, they won't work right.
 )

;;; 2019-04-12: disabled so that Mac fonts display correctly:
;(custom-set-faces
  ;; custom-set-faces was added by Custom.
  ;; If you edit it by hand, you could mess it up, so be careful.
  ;; Your init file should contain only one such instance.
  ;; If there is more than one, they won't work right.
; '(default ((t (:inherit nil :stipple nil :background "SystemWindow" :foreground "SystemWindowText" :inverse-video nil :box nil :strike-through nil :overline nil :underline nil :slant normal :weight normal :height 113 :width normal :foundry "outline" :family "Consolas")))))
;; 2018-05-03:


;;;--------------- CDE SLIME: RESOURCES, NOTES:

;; This was great, so far:
;; https://www.common-lisp.net/project/slime/doc/html/Installation.html#Installing-from-Git

;; I did NOT do this, so am not getting all the updates.

;; meta-x describe-variable RET load-path gave the whole load path in emacs

;; The easiest way to install and keep SLIME up-to-date is using Emacs¡¯s built-in package manager.
;;; SLIME is available from the MELPA repository. After setting up the MELPA repository,
;;; SLIME can be installed via M-x package-install RET slime RET.
;;; You should then define your default Lisp in your .emacs as follows:

;; (setq inferior-lisp-program "/opt/sbcl/bin/sbcl")

;; Instead, I used the version to just load myself, which seems to be working:

;; I upgraded to Emacs 25.3.

;; Put the following in .emacs:

;; You may optionally byte-compile SLIME using make compile contrib-compile.

;; Here is how to set up custom keyboard keys:
;; https://www.common-lisp.net/project/slime/doc/html/Basic-customization.html#Basic-customization

;;;--------------- CDE SLIME: YOU'LL NEED THESE IF YOU LOAD SLIME:

;;;(add-to-list 'load-path "C:/e/abcl/bordeaux-threads-master/")
;;;(add-to-list 'load-path "C:/e/abcl/slime-master")
;;;(add-to-list 'load-path "C:/e/abcl/asdf-master/")
;;;(require 'slime-autoloads)
;;;(add-to-list 'slime-contribs 'slime-fancy)

;;;-------------- END CDE SLIME 


(global-set-key (kbd "<apps>") 'execute-extended-command) ; sets to M-x
(global-set-key (kbd "<C-apps>") 'slime-eval-defun)
;;; Cursor movement:
;;; Pairs with Control-B for scroll up:
(global-set-key "\C-t" 'scroll-down)

(global-set-key "\C-c\C-k" 'kill-region)  ;instead of \C-w
(global-set-key "\C-w" 'forward-word)
(global-set-key "\C-q" 'backward-word)  ; was quoted-insert by default
(global-set-key "\C-cb" 'end-of-buffer)  ;;; "bottom" of buffer
(global-set-key "\C-ct" 'beginning-of-buffer)  ;;; "top" of buffer



(global-set-key "\C-c\C-g" 'goto-line)
;;; works, but does not say "describe key: " for example when looking at keys.
(global-set-key "\eh" 'help-for-help)	; ESC-h is help command

;;;(global-set-key "\C-c\C-y" 'mail-yank-original) ; should be default
;;;(global-set-key "\C-t" 'insert-time)

(global-set-key "\C-cg" 'what-line)
(global-set-key "\^h" 'backward-delete-char-untabify)
(global-set-key "\C-c\C-b" 'bottom-of-window)  ; macro
(global-set-key "\C-c\C-d" 'delete-region)
(global-set-key "\C-c\C-g" 'goto-line)
(global-set-key "\C-c\C-i" 'indent-region)
;; https://emacs.stackexchange.com/questions/352/how-to-override-major-mode-bindings:
;; instead of \C-w which we need for forward word:
(global-set-key "\C-c\C-k" 'kill-region) ; ignored by lisp mode

;; This is all necessary because SLIME overwrites my absolutely necessary kill-region command.
;; Don't know how to require:
;; (require 'bindkey.el)

;;; (load "c:/.emacs.d/bindkey.el") ;; Just put here so I can find it

;;; BIND-KEY.EL STARTS HERE ----------------------------------------------------;;;

;;; https://github.com/jwiegley/use-package/blob/master/bind-key.el
;;; bind-key.el --- A simple way to manage personal keybindings

;; Copyright (c) 2012-2017 John Wiegley

;; Author: John Wiegley <johnw@newartisans.com>
;; Maintainer: John Wiegley <johnw@newartisans.com>
;; Created: 16 Jun 2012
;; Modified: 29 Nov 2017
;; Version: 2.4
;; Keywords: keys keybinding config dotemacs
;; URL: https://github.com/jwiegley/use-package

;; This program 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 3, or (at
;; your option) any later version.

;; This program 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:

;; If you have lots of keybindings set in your .emacs file, it can be hard to
;; know which ones you haven't set yet, and which may now be overriding some
;; new default in a new emacs version.  This module aims to solve that
;; problem.
;;
;; Bind keys as follows in your .emacs:
;;
;;   (require 'bind-key)
;;
;;   (bind-key "C-c x" 'my-ctrl-c-x-command)
;;
;; If you want the keybinding to override all minor modes that may also bind
;; the same key, use the `bind-key*' form:
;;
;;   (bind-key* "<C-return>" 'other-window)
;;
;; If you want to rebind a key only in a particular keymap, use:
;;
;;   (bind-key "C-c x" 'my-ctrl-c-x-command some-other-mode-map)
;;
;; To unbind a key within a keymap (for example, to stop your favorite major
;; mode from changing a binding that you don't want to override everywhere),
;; use `unbind-key':
;;
;;   (unbind-key "C-c x" some-other-mode-map)
;;
;; To bind multiple keys at once, or set up a prefix map, a `bind-keys' macro
;; is provided.  It accepts keyword arguments, please see its documentation
;; for a detailed description.
;;
;; To add keys into a specific map, use :map argument
;;
;;    (bind-keys :map dired-mode-map
;;               ("o" . dired-omit-mode)
;;               ("a" . some-custom-dired-function))
;;
;; To set up a prefix map, use `:prefix-map' and `:prefix' arguments (both are
;; required)
;;
;;    (bind-keys :prefix-map my-customize-prefix-map
;;               :prefix "C-c c"
;;               ("f" . customize-face)
;;               ("v" . customize-variable))
;;
;; You can combine all the keywords together.  Additionally,
;; `:prefix-docstring' can be specified to set documentation of created
;; `:prefix-map' variable.
;;
;; To bind multiple keys in a `bind-key*' way (to be sure that your bindings
;; will not be overridden by other modes), you may use `bind-keys*' macro:
;;
;;    (bind-keys*
;;     ("C-o" . other-window)
;;     ("C-M-n" . forward-page)
;;     ("C-M-p" . backward-page))
;;
;; After Emacs loads, you can see a summary of all your personal keybindings
;; currently in effect with this command:
;;
;;   M-x describe-personal-keybindings
;;
;; This display will tell you if you've overriden a default keybinding, and
;; what the default was.  Also, it will tell you if the key was rebound after
;; your binding it with `bind-key', and what it was rebound it to.

;;; Code:

;;(require 'cl-lib)
(require 'easy-mmode)

(defgroup bind-key nil
  "A simple way to manage personal keybindings"
  :group 'emacs)

(defcustom bind-key-column-widths '(18 . 40)
  "Width of columns in `describe-personal-keybindings'."
  :type '(cons integer integer)
  :group 'bind-key)

(defcustom bind-key-segregation-regexp
  "\\`\\(\\(C-[chx] \\|M-[gso] \\)\\([CM]-\\)?\\|.+-\\)"
  "Regular expression used to divide key sets in the output from
\\[describe-personal-keybindings]."
  :type 'regexp
  :group 'bind-key)

(defcustom bind-key-describe-special-forms nil
  "If non-nil, extract docstrings from lambdas, closures and keymaps if possible."
  :type 'boolean
  :group 'bind-key)

;; Create override-global-mode to force key remappings

(defvar override-global-map (make-keymap)
  "override-global-mode keymap")

(define-minor-mode override-global-mode
  "A minor mode so that keymap settings override other modes."
  t "")

;; the keymaps in `emulation-mode-map-alists' take precedence over
;; `minor-mode-map-alist'
(add-to-list 'emulation-mode-map-alists
             `((override-global-mode . ,override-global-map)))

(defvar personal-keybindings nil
  "List of bindings performed by `bind-key'.
Elements have the form ((KEY . [MAP]) CMD ORIGINAL-CMD)")

;;;###autoload
(defmacro bind-key (key-name command &optional keymap predicate)
  "Bind KEY-NAME to COMMAND in KEYMAP (`global-map' if not passed).
KEY-NAME may be a vector, in which case it is passed straight to
`define-key'. Or it may be a string to be interpreted as
spelled-out keystrokes, e.g., \"C-c C-z\". See documentation of
`edmacro-mode' for details.
COMMAND must be an interactive function or lambda form.
KEYMAP, if present, should be a keymap and not a quoted symbol.
For example:
  (bind-key \"M-h\" #'some-interactive-function my-mode-map)
If PREDICATE is non-nil, it is a form evaluated to determine when
a key should be bound. It must return non-nil in such cases.
Emacs can evaluate this form at any time that it does redisplay
or operates on menu data structures, so you should write it so it
can safely be called at any time."
  (let ((namevar (make-symbol "name"))
        (keyvar (make-symbol "key"))
        (kdescvar (make-symbol "kdesc"))
        (bindingvar (make-symbol "binding")))
    `(let* ((,namevar ,key-name)
            (,keyvar (if (vectorp ,namevar) ,namevar
                       (read-kbd-macro ,namevar)))
            (,kdescvar (cons (if (stringp ,namevar) ,namevar
                               (key-description ,namevar))
                             (quote ,keymap)))
            (,bindingvar (lookup-key (or ,keymap global-map) ,keyvar)))
       (let ((entry (assoc ,kdescvar personal-keybindings))
             (details (list ,command
                            (unless (numberp ,bindingvar)
                              ,bindingvar))))
         (if entry
             (setcdr entry details)
           (add-to-list 'personal-keybindings (cons ,kdescvar details))))
       ,(if predicate
            `(define-key (or ,keymap global-map) ,keyvar
               '(menu-item "" nil :filter (lambda (&optional _)
                                            (when ,predicate
                                              ,command))))
          `(define-key (or ,keymap global-map) ,keyvar ,command)))))

;;;###autoload
(defmacro unbind-key (key-name &optional keymap)
  "Unbind the given KEY-NAME, within the KEYMAP (if specified).
See `bind-key' for more details."
  `(progn
     (bind-key ,key-name nil ,keymap)
     (setq personal-keybindings
           (cl-delete-if #'(lambda (k)
                             ,(if keymap
                                  `(and (consp (car k))
                                        (string= (caar k) ,key-name)
                                        (eq (cdar k) ',keymap))
                                `(and (stringp (car k))
                                      (string= (car k) ,key-name))))
                         personal-keybindings))))

;;;###autoload
(defmacro bind-key* (key-name command &optional predicate)
  "Similar to `bind-key', but overrides any mode-specific bindings."
  `(bind-key ,key-name ,command override-global-map ,predicate))

(defun bind-keys-form (args keymap)
  "Bind multiple keys at once.
Accepts keyword arguments:
:map MAP               - a keymap into which the keybindings should be
                         added
:prefix KEY            - prefix key for these bindings
:prefix-map MAP        - name of the prefix map that should be created
                         for these bindings
:prefix-docstring STR  - docstring for the prefix-map variable
:menu-name NAME        - optional menu string for prefix map
:filter FORM           - optional form to determine when bindings apply
The rest of the arguments are conses of keybinding string and a
function symbol (unquoted)."
  (let (map
        doc
        prefix-map
        prefix
        filter
        menu-name
        pkg)

    ;; Process any initial keyword arguments
    (let ((cont t))
      (while (and cont args)
        (if (cond ((and (eq :map (car args))
                        (not prefix-map))
                   (setq map (cadr args)))
                  ((eq :prefix-docstring (car args))
                   (setq doc (cadr args)))
                  ((and (eq :prefix-map (car args))
                        (not (memq map '(global-map
                                         override-global-map))))
                   (setq prefix-map (cadr args)))
                  ((eq :prefix (car args))
                   (setq prefix (cadr args)))
                  ((eq :filter (car args))
                   (setq filter (cadr args)) t)
                  ((eq :menu-name (car args))
                   (setq menu-name (cadr args)))
                  ((eq :package (car args))
                   (setq pkg (cadr args))))
            (setq args (cddr args))
          (setq cont nil))))

    (when (or (and prefix-map (not prefix))
              (and prefix (not prefix-map)))
      (error "Both :prefix-map and :prefix must be supplied"))

    (when (and menu-name (not prefix))
      (error "If :menu-name is supplied, :prefix must be too"))

    (unless map (setq map keymap))

    ;; Process key binding arguments
    (let (first next)
      (while args
        (if (keywordp (car args))
            (progn
              (setq next args)
              (setq args nil))
          (if first
              (nconc first (list (car args)))
            (setq first (list (car args))))
          (setq args (cdr args))))

      (cl-flet
          ((wrap (map bindings)
                 (if (and map pkg (not (memq map '(global-map
                                                   override-global-map))))
                     `((if (boundp ',map)
                           ,(macroexp-progn bindings)
                         (eval-after-load
                             ,(if (symbolp pkg) `',pkg pkg)
                           ',(macroexp-progn bindings))))
                   bindings)))

        (append
         (when prefix-map
           `((defvar ,prefix-map)
             ,@(when doc `((put ',prefix-map 'variable-documentation ,doc)))
             ,@(if menu-name
                   `((define-prefix-command ',prefix-map nil ,menu-name))
                 `((define-prefix-command ',prefix-map)))
             ,@(if (and map (not (eq map 'global-map)))
                   (wrap map `((bind-key ,prefix ',prefix-map ,map ,filter)))
                 `((bind-key ,prefix ',prefix-map nil ,filter)))))
         (wrap map
               (cl-mapcan
                (lambda (form)
                  (let ((fun (and (cdr form) (list 'function (cdr form)))))
                    (if prefix-map
                        `((bind-key ,(car form) ,fun ,prefix-map ,filter))
                      (if (and map (not (eq map 'global-map)))
                          `((bind-key ,(car form) ,fun ,map ,filter))
                        `((bind-key ,(car form) ,fun nil ,filter))))))
                first))
         (when next
           (bind-keys-form (if pkg
                               (cons :package (cons pkg next))
                             next) map)))))))

;;;###autoload
(defmacro bind-keys (&rest args)
  "Bind multiple keys at once.
Accepts keyword arguments:
:map MAP               - a keymap into which the keybindings should be
                         added
:prefix KEY            - prefix key for these bindings
:prefix-map MAP        - name of the prefix map that should be created
                         for these bindings
:prefix-docstring STR  - docstring for the prefix-map variable
:menu-name NAME        - optional menu string for prefix map
:filter FORM           - optional form to determine when bindings apply
The rest of the arguments are conses of keybinding string and a
function symbol (unquoted)."
  (macroexp-progn (bind-keys-form args nil)))

;;;###autoload
(defmacro bind-keys* (&rest args)
  (macroexp-progn (bind-keys-form args 'override-global-map)))

(defun get-binding-description (elem)
  (cond
   ((listp elem)
    (cond
     ((memq (car elem) '(lambda function))
      (if (and bind-key-describe-special-forms
               (stringp (nth 2 elem)))
          (nth 2 elem)
        "#<lambda>"))
     ((eq 'closure (car elem))
      (if (and bind-key-describe-special-forms
               (stringp (nth 3 elem)))
          (nth 3 elem)
        "#<closure>"))
     ((eq 'keymap (car elem))
      "#<keymap>")
     (t
      elem)))
   ;; must be a symbol, non-symbol keymap case covered above
   ((and bind-key-describe-special-forms (keymapp elem))
    (let ((doc (get elem 'variable-documentation)))
      (if (stringp doc) doc elem)))
   ((symbolp elem)
    elem)
   (t
    "#<byte-compiled lambda>")))

(defun compare-keybindings (l r)
  (let* ((regex bind-key-segregation-regexp)
         (lgroup (and (string-match regex (caar l))
                      (match-string 0 (caar l))))
         (rgroup (and (string-match regex (caar r))
                      (match-string 0 (caar r))))
         (lkeymap (cdar l))
         (rkeymap (cdar r)))
    (cond
     ((and (null lkeymap) rkeymap)
      (cons t t))
     ((and lkeymap (null rkeymap))
      (cons nil t))
     ((and lkeymap rkeymap
           (not (string= (symbol-name lkeymap) (symbol-name rkeymap))))
      (cons (string< (symbol-name lkeymap) (symbol-name rkeymap)) t))
     ((and (null lgroup) rgroup)
      (cons t t))
     ((and lgroup (null rgroup))
      (cons nil t))
     ((and lgroup rgroup)
      (if (string= lgroup rgroup)
          (cons (string< (caar l) (caar r)) nil)
        (cons (string< lgroup rgroup) t)))
     (t
      (cons (string< (caar l) (caar r)) nil)))))

;;;###autoload
(defun describe-personal-keybindings ()
  "Display all the personal keybindings defined by `bind-key'."
  (interactive)
  (with-output-to-temp-buffer "*Personal Keybindings*"
    (princ (format (concat "Key name%s Command%s Comments\n%s %s "
                           "---------------------\n")
                   (make-string (- (car bind-key-column-widths) 9) ? )
                   (make-string (- (cdr bind-key-column-widths) 8) ? )
                   (make-string (1- (car bind-key-column-widths)) ?-)
                   (make-string (1- (cdr bind-key-column-widths)) ?-)))
    (let (last-binding)
      (dolist (binding
               (setq personal-keybindings
                     (sort personal-keybindings
                           (lambda (l r)
                             (car (compare-keybindings l r))))))

        (if (not (eq (cdar last-binding) (cdar binding)))
            (princ (format "\n\n%s: %s\n%s\n\n"
                           (cdar binding) (caar binding)
                           (make-string (+ 21 (car bind-key-column-widths)
                                           (cdr bind-key-column-widths)) ?-)))
          (if (and last-binding
                   (cdr (compare-keybindings last-binding binding)))
              (princ "\n")))

        (let* ((key-name (caar binding))
               (at-present (lookup-key (or (symbol-value (cdar binding))
                                           (current-global-map))
                                       (read-kbd-macro key-name)))
               (command (nth 1 binding))
               (was-command (nth 2 binding))
               (command-desc (get-binding-description command))
               (was-command-desc (and was-command
                                      (get-binding-description was-command)))
               (at-present-desc (get-binding-description at-present))
               )
          (let ((line
                 (format
                  (format "%%-%ds%%-%ds%%s\n" (car bind-key-column-widths)
                          (cdr bind-key-column-widths))
                  key-name (format "`%s\'" command-desc)
                  (if (string= command-desc at-present-desc)
                      (if (or (null was-command)
                              (string= command-desc was-command-desc))
                          ""
                        (format "was `%s\'" was-command-desc))
                    (format "[now: `%s\']" at-present)))))
            (princ (if (string-match "[ \t]+\n" line)
                       (replace-match "\n" t t line)
                     line))))

        (setq last-binding binding)))))

;;; (provide 'bind-key)  <-- CDE add this back for bind-key.el in a separate file.

;; Local Variables:
;; outline-regexp: ";;;\\(;* [^\s\t\n]\\|###autoload\\)\\|("
;; indent-tabs-mode: nil
;; End:

;;; bind-key.el ends here

;;; BIND-KEY.EL ENDS HERE ----------------------------------------------------;;;

;;; Bind-key was added just to get back this essential function:
(bind-keys* ("\C-c\C-k" . kill-region))
(setq-default fill-column 95)


;;; LISP setup: