#| -*-Scheme-*-

Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
    2017, 2018, 2019, 2020 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme 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 of the License, or (at
your option) any later version.

MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

|#

;;;; Alias Keys



(define alias-keys '())

(define (define-alias-key key alias)
  (let ((entry (assq key alias-keys)))
    (if entry
	(set-cdr! entry alias)
	(set! alias-keys (cons (cons key alias) alias-keys))))
  unspecific)

(define (undefine-alias-key key)
  (set! alias-keys (del-assq! key alias-keys))
  unspecific)

(define (remap-alias-key key)
  (let ((entry (assq key alias-keys)))
    (cond (entry
	   (remap-alias-key (cdr entry)))
	  ((and (char? key)
		(char-bits-set? char-bit:control key))
	   (let ((code (char-code key))
		 (remap
		  (lambda (code)
		    (make-char code
			       (fix:andc (char-bits key) char-bit:control)))))
	     (cond ((<= #x40 code #x5F) (remap (- code #x40)))
		   ((<= #x61 code #x7A) (remap (- code #x60)))
		   (else key))))
	  (else key))))

(define (unmap-alias-key key)
  (if (and (char? key)
	   (ascii-controlified? key)
	   (let ((code (char-code key)))
	     (not (or (= code #x09)	;tab
		      (= code #x0A)	;linefeed
		      (= code #x0C)	;page
		      (= code #x0D)	;return
		      (= code #x1B)	;altmode
		      )))
	   (char-bits-clear? char-bit:control key))
      (unmap-alias-key
       (make-char (let ((code (char-code key)))
		    (+ code (if (<= #x01 code #x1A) #x60 #x40)))
		  (fix:or (char-bits key) char-bit:control)))
      (let ((entry
	     (find (lambda (entry)
		     (eqv? (cdr entry) key))
		   alias-keys)))
	(if entry
	    (unmap-alias-key (car entry))
	    key))))

(define-variable enable-emacs-key-names
  "True means keys are shown using Emacs-style names."
  #t
  boolean?)

(define (key-name key)
  (cond ((ref-variable enable-emacs-key-names) (emacs-key-name key #t))
	((char? key) (char->name (unmap-alias-key key)))
	((special-key? key) (special-key/name key))
	((button? key) (button-name key))
        (else (error:wrong-type-argument key "key" 'key-name))))

(define (xkey->name xkey)
  (let ((keys (xkey->list xkey)))
    (string-append-separated
     (key-name (car keys))
     (let ((key-name
	    (if (ref-variable enable-emacs-key-names)
		(lambda (key)
		  (emacs-key-name key #f))
		(lambda (key)
		  (key-name (unmap-alias-key key))))))
       (let loop ((keys (cdr keys)))
	 (if (pair? keys)
	     (string-append-separated (key-name (car keys))
				      (loop (cdr keys)))
	     ""))))))

(define (emacs-key-name key handle-prefixes?)
  (cond ((char? key)
         (let ((code (char-code key))
               (bits (char-bits key)))
	   (define (prefix bits suffix)
	     (if (zero? bits)
		 suffix
		 (string-append "M-" suffix)))
	   (define (process-code bits)
	     (if (<= code #x20)
		 (cond ((= code #x09) (prefix bits "TAB"))
		       ((= code #x0A) (prefix bits "LFD"))
		       ((= code #x0D) (prefix bits "RET"))
		       ((= code #x1B) (prefix bits "ESC"))
		       ((= code #x20) (prefix bits "SPC"))
		       (else
			(string-append (if (zero? bits) "C-" "C-M-")
				       (string
					(integer->char
					 (+ (if (<= #x01 code #x1A) #x60 #x40)
					    code))))))
		 (prefix bits
			 (if (= code #x7F)
			     "DEL"
			     (vector-ref (ref-variable char-image-strings #f)
					 code)))))
	   (cond ((or (fix:= bits 0)
		      (fix:= bits char-bit:meta))
		  (process-code bits))
		 ((and handle-prefixes?
		       (not (fix:= 0 (fix:and bits
					      (fix:or char-bit:control
						      char-bit:meta)))))
		  (string-append (if (fix:= bits char-bit:control)
				     "C-^ "
				     "C-z ")
				 (process-code 0)))
		 (else
		  (char->name (unmap-alias-key key))))))
	((special-key? key) (special-key/name key))
	((button? key) (button-name key))
        (else (error:wrong-type-argument key "key" 'emacs-key-name))))

(define (key? object)
  (or (char? object)
      (special-key? object)
      (button? object)))

(define (key-bucky-bits key)
  (cond ((char? key) (char-bits key))
	((special-key? key) (special-key/bucky-bits key))
	((button? key) (button-bits key))
        (else (error:wrong-type-argument key "key" 'key-bucky-bits))))

(define (key<? key1 key2)
  (or (< (key-bucky-bits key1) (key-bucky-bits key2))
      (and (= (key-bucky-bits key1) (key-bucky-bits key2))
	   (cond ((char? key1)
		  (or (not (char? key2))
		      (char<? key1 key2)))
		 ((special-key? key1)
		  (if (special-key? key2)
		      (string<? (special-key/name key1)
				(special-key/name key2))
		      (button? key2)))
		 ((button? key1)
		  (and (button? key2)
		       (string<? (button-name key1) (button-name key2))))
		 (else
		  (error:wrong-type-argument key1 "key" 'key<?))))))

(define (key=? key1 key2)
  (and (= (key-bucky-bits key1) (key-bucky-bits key2))
       (cond ((char? key1)
	      (and (char? key2)
		   (char=? key1 key2)))
	     ((special-key? key1)
	      (and (special-key? key2)
		   (string=? (special-key/name key1) (special-key/name key2))))
	     ((button? key1)
	      (eq? key1 key2))
	     (else
	      (error:wrong-type-argument key1 "key" 'key=?)))))

(define (xkey<? x y)
  (let loop ((x (xkey->list x)) (y (xkey->list y)))
    (or (key<? (car x) (car y))
	(and (key=? (car x) (car y))
	     (pair? (cdr y))
	     (or (not (pair? (cdr x)))
		 (loop (cdr x) (cdr y)))))))

(define (xkey->list xkey)
  (cond ((or (key? xkey) (button? xkey))
	 (list xkey))
	((and (pair? xkey)
	      (list-of-type? xkey key?))
	 xkey)
	((and (string? xkey)
	      (not (string-null? xkey)))
	 (string->list xkey))
	(else
	 (error "Not a key or list of keys" xkey))))

;;;; Special Keys (system-dependent)

(define-structure (special-key (constructor %make-special-key)
			       (conc-name special-key/)
			       (print-procedure
				(standard-print-method 'special-key
				  (lambda (key)
				    (list (special-key/name key))))))
  (symbol #f read-only #t)
  (bucky-bits #f read-only #t))

(define (intern-special-key name bucky-bits)
  (let ((name-entry (assq name (cdr hashed-keys))))
    (if name-entry
	(let ((bits-entry (assq bucky-bits (cdr name-entry))))
	  (if bits-entry
	      (cdr bits-entry)
	      (let ((new-key (%make-special-key name bucky-bits)))
		(set-cdr! name-entry
			  (cons (cons bucky-bits new-key)
				(cdr name-entry)))
		new-key)))
	(let ((new-key (%make-special-key name bucky-bits)))
	  (set-cdr! hashed-keys
		    (cons (cons name (list (cons bucky-bits new-key)))
			  (cdr hashed-keys)))
	  new-key))))

(define (special-key/name special-key)
  (string-append (bucky-bits->prefix (special-key/bucky-bits special-key))
		 (symbol->string (special-key/symbol special-key))))

(define (make-special-key name bits)
  (hook/make-special-key name bits))

(define hashed-keys (list 'hashed-keys))
(define hook/make-special-key intern-special-key)

;; Predefined special keys
(define-syntax define-special-key
  (sc-macro-transformer
   (lambda (form environment)
     environment
     `(define ,(cadr form)
	(intern-special-key ',(cadr form) 0)))))

(define-special-key backspace)
(define-special-key stop)
(define-special-key f1)
(define-special-key f2)
(define-special-key f3)
(define-special-key f4)
(define-special-key menu)
(define-special-key system)
(define-special-key user)
(define-special-key f5)
(define-special-key f6)
(define-special-key f7)
(define-special-key f8)
(define-special-key f9)
(define-special-key f10)
(define-special-key f11)
(define-special-key f12)
(define-special-key insertline)
(define-special-key deleteline)
(define-special-key insertchar)
(define-special-key deletechar)
(define-special-key home)
(define-special-key prior)
(define-special-key next)
(define-special-key up)
(define-special-key down)
(define-special-key left)
(define-special-key right)
(define-special-key select)
(define-special-key print)