;; Extended character input

;; This file provides the data type used by the keyboard stream,
;; and CLtL1 compatible character functions operating on font and bits.

(in-package "EXT")
(export '(char-bits char-font char-font-limit char-bits-limit
          char-control-bit char-meta-bit char-super-bit char-hyper-bit
          make-char char-bit set-char-bit char-key))

(in-package "SYSTEM")

(defconstant char-font-limit 16) ; for backward compatibility only
(defconstant char-bits-limit 16)
;; CLtL1, p. 233, 234
(defconstant char-int-limit     ; CLISP specific
  (* char-code-limit char-font-limit char-bits-limit))

(defstruct input-character
  (char nil :type (or null character))
  (bits 0   :type (integer 0 #.(1- char-bits-limit)))
  (font 0   :type (integer 0 #.(1- char-font-limit)))
  (key  nil :type (or null character symbol)))

(defconstant char-control-bit 1)
(defconstant char-meta-bit 2)
(defconstant char-super-bit 4)
(defconstant char-hyper-bit 8)
;; CLtL1, p. 243

(defun error-char-arg (arg caller)
  (error-of-type 'type-error
    :datum arg :expected-type 'character
    (TEXT "~S: argument ~S is not a character")
    caller arg))

(defun char-bits (char)
  (cond ((typep char 'character) 0)
        ((input-character-p char) (input-character-bits char))
        (t (error-char-arg char 'char-bits))))

(defun char-font (char)
  (cond ((typep char 'character) 0)
        ((input-character-p char) (input-character-font char))
        (t (error-char-arg char 'char-font))))

(defun char-key (char)
  (cond ((typep char 'character) char)
        ((input-character-p char) (input-character-key char))
        (t (error-char-arg char 'char-key))))

(defun test-font-arg (arg caller)
  (if (integerp arg)
    arg
    (error-of-type 'type-error
      :datum arg :expected-type 'integer
      (TEXT "~S: the font argument should be an integer, not ~S")
      caller arg)))

(defun test-bits-arg (arg caller)
  (if (integerp arg)
    arg
    (error-of-type 'type-error
      :datum arg :expected-type 'integer
      (TEXT "~S: the bits argument should be an integer, not ~S")
      caller arg)))

(defun make-char (char &optional (bits 0) (font 0))
  (test-font-arg font 'make-char)
  (test-bits-arg bits 'make-char)
  (unless (typep char 'character) (error-char-arg char 'make-char))
  (if (and (<= 0 bits) (< bits char-bits-limit)
           (<= 0 font) (< font char-font-limit))
    (make-input-character :char char :bits bits :font font)
    nil))

(defun test-bitname-arg (arg caller)
  (case arg
    (:CONTROL char-control-bit)
    (:META    char-meta-bit)
    (:SUPER   char-super-bit)
    (:HYPER   char-hyper-bit)
    (t (error-of-type 'type-error
         :datum arg :expected-type '(MEMBER :CONTROL :META :SUPER :HYPER)
         (TEXT "~S: the only bit names are ~S, ~S, ~S, ~S, not ~S")
         caller ':CONTROL ':META ':SUPER ':HYPER arg))))

(defun char-bit (char name)
  (let ((bitmask (test-bitname-arg name 'char-bit)))
    (cond ((typep char 'character) nil)
          ((input-character-p char)
           (not (zerop (logand (input-character-bits char) bitmask))))
          (t (error-char-arg char 'char-bit)))))

(defun set-char-bit (char name newvalue)
  (let ((bitmask (test-bitname-arg name 'char-bit))
        (new
          (cond ((typep char 'character) (make-input-character :char char))
                ((input-character-p char) (copy-input-character char))
                (t (error-char-arg char 'set-char-bit)))))
    (if newvalue
      (setf (input-character-bits new)
            (logior (input-character-bits new) bitmask))
      (setf (input-character-bits new)
            (logand (input-character-bits new) (lognot bitmask))))
    new))

;; Characters which had names in earlier versions of CLISP:
; WIN32_CHARNAMES
;  charname_hyper_13     (make-input-character :key :Enter)
;  charname_hyper_16     (make-input-character :key :Insert)
;  charname_hyper_17     (make-input-character :key :End)
;  charname_hyper_18     (make-input-character :key :Down)
;  charname_hyper_19     (make-input-character :key :PgDn)
;  charname_hyper_20     (make-input-character :key :Left)
;  charname_hyper_21     (make-input-character :key :Center)
;  charname_hyper_22     (make-input-character :key :Right)
;  charname_hyper_23     (make-input-character :key :Home)
;  charname_hyper_24     (make-input-character :key :Up)
;  charname_hyper_25     (make-input-character :key :PgUp)
;  charname_hyper_127    (make-input-character :key :Delete)
;  charname_hyper_a      (make-input-character :key :F1)
;  charname_hyper_b      (make-input-character :key :F2)
;  charname_hyper_c      (make-input-character :key :F3)
;  charname_hyper_d      (make-input-character :key :F4)
;  charname_hyper_e      (make-input-character :key :F5)
;  charname_hyper_f      (make-input-character :key :F6)
;  charname_hyper_g      (make-input-character :key :F7)
;  charname_hyper_h      (make-input-character :key :F8)
;  charname_hyper_i      (make-input-character :key :F9)
;  charname_hyper_j      (make-input-character :key :F10)
;  charname_hyper_k      (make-input-character :key :F11)
;  charname_hyper_l      (make-input-character :key :F12)
; UNIX_CHARNAMES
;  charname_hyper_16     (make-input-character :key :Insert)
;  charname_hyper_17     (make-input-character :key :End)
;  charname_hyper_18     (make-input-character :key :Down)
;  charname_hyper_19     (make-input-character :key :PgDn)
;  charname_hyper_20     (make-input-character :key :Left)
;  charname_hyper_21     (make-input-character :key :Center)
;  charname_hyper_22     (make-input-character :key :Right)
;  charname_hyper_23     (make-input-character :key :Home)
;  charname_hyper_24     (make-input-character :key :Up)
;  charname_hyper_25     (make-input-character :key :PgUp)
;  charname_hyper_a      (make-input-character :key :F1)
;  charname_hyper_b      (make-input-character :key :F2)
;  charname_hyper_c      (make-input-character :key :F3)
;  charname_hyper_d      (make-input-character :key :F4)
;  charname_hyper_e      (make-input-character :key :F5)
;  charname_hyper_f      (make-input-character :key :F6)
;  charname_hyper_g      (make-input-character :key :F7)
;  charname_hyper_h      (make-input-character :key :F8)
;  charname_hyper_i      (make-input-character :key :F9)
;  charname_hyper_j      (make-input-character :key :F10)
;  charname_hyper_k      (make-input-character :key :F11)
;  charname_hyper_l      (make-input-character :key :F12)
