;;; -*- Mode:LISP; Package:LISP-INTERNALS; Readtable:CL; Base:10 -*-

;;;********************************************************************************
; Required Common Lisp Constants

(defconstant char-code-limit 256.
  "Character code values must be less than this.")

(defconstant char-font-limit 16.
  "Font codes in characters must be less than this.")

(defconstant char-bits-limit 16.
  "All the special bits in a character must be less than this.
They are Control, Meta, Super and Hyper.")

;;;********************************************************************************
; Other useful constants

(defconstant %%ch-char 	     (byte 8. 0.)    "Position of character value")
(defconstant %%ch-bits       (byte 4. 8.)    "Position of bits value")
(defconstant %%ch-font       (byte 4. 12.)   "Position of font value")
(defconstant %%ch-font-and-bits  (byte 8. 8.)    "Position of font and bits value")
(defconstant %%ch-fat	     (byte 16. 0.)   "Position of all the stuff in a character")

(defconstant char-control-bit 1
  "This bit within the bits of a character, is the Control bit.")

(defconstant char-meta-bit 2
  "This bit, within the bits of a character, is the Meta bit.")

(defconstant char-super-bit 4
  "This bit, within the bits of a character, is the Super bit.")

(defconstant char-hyper-bit 8.
  "This bit, within the bits of a character, is the Hyper bit.")

;;; defsubst
(defun %char-int (c)
  (hw:ldb c %%ch-char 0))

;;; defsubst
(defun %fat-char-int (c)
  (hw:ldb c %%ch-fat 0))
 
(defconstant char-int-0       #.(lisp:char-int #\0))
(defconstant char-int-9       #.(lisp:char-int #\9))
(defconstant char-int-lower-a #.(lisp:char-int #\a))
(defconstant char-int-lower-z #.(lisp:char-int #\z))
(defconstant char-int-upper-a #.(lisp:char-int #\A))
(defconstant char-int-upper-z #.(lisp:char-int #\Z))

;;;********************************************************************************


(defsubst CHAR-CODE (c)
  (li:%trap-if-not-character c)
  (hw:ldb c %%ch-char 0))

(defsubst CHAR-BITS (c)
  (li:%trap-if-not-character c)
  (hw:ldb c %%ch-bits 0))

(defsubst CHAR-FONT (c)
  (li:%trap-if-not-character c)
  (hw:ldb c %%ch-font 0))

(defsubst CHAR-INT (c)
  (li:%trap-if-not-character c)
  (hw:dpb-boxed c %%ch-fat 0))

(defsubst INT-CHAR (i)
  (hw:dpb-boxed i %%ch-fat gr:*dtp-character*))


(defun CHARACTERP (c)
  "Returns T if c is a character, otherwise nil"
  (vinc:characterp c))

(defun STRING-CHAR-P (c)
  "Returns T if c is a character with zero font and bit codes"
  (li:%trap-if-not-character c)
  (zerop (hw:ldb c %%ch-font-and-bits 0)))

(defun GRAPHIC-CHAR-P (c)
  "Returns T if c is a character with zero font and bit codes and a standard print reresentation"
  (li:%trap-if-not-character c)
  (and (zerop (hw:ldb c %%ch-font-and-bits 0))
       (<= (hw:ldb c %%ch-char 0) 127.)))

(defun STANDARD-CHAR-P (c)
  "Returns T if c is a is one of the standard ASCII printable chars, space, or newline"
  (and
    (zerop (hw:ldb c %%ch-font-and-bits 0))		;no special bits or fonts
    (or (and (char>= c #\Space)
	     (char<= c #\~))
	(char= c #\Newline))))

(defsubst UPPER-CASE-P (c)
  "Return T if c is an upper case character A-Z"
  (char<= #\A c #\Z))

(defsubst LOWER-CASE-P (c)
  "Return t if c is a lower case character a-z"
  (char<= #\a c #\z))

(defun ALPHA-CHAR-P (c)
  "Returns T if c is a alphabetic character"
  (and (zerop (hw:ldb c %%ch-font-and-bits 0))		;no special bits or fonts
       (or (char<= #\A c #\Z)
	   (char<= #\a c #\z))))

(defun BOTH-CASE-P (c)
  (or (upper-case-p c)
      (lower-case-p c)))


(defun DIGIT-CHAR-P (c &optional (radix 10.))
  "Returns value if c is a numeric character"
  (and
    (zerop (hw:ldb c %%ch-font-and-bits 0))		;no special bits or fonts
    (let* ((char (%char-int c))
	   (n (cond
		((and (char>= c #\0) (char<= c #\9))
		 (- char char-int-0))
		((and (char>= c #\A) (char<= c #\Z))
		 (- char (- char-int-upper-a 10.)))
		((and (char>= c #\a) (char<= c #\z))
		 (- char (- char-int-lower-a 10.)))
		(t (return-from digit-char-p nil)))))
      (if (< n radix)
	  n
	nil))))

(defun DIGIT-CHAR (weight &optional (radix 10) (font 0))
  (if (< weight radix)
      (make-char (array:svref "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" weight) 0 font)
    nil))

(defun ALPHANUMERICP (c)
  "Return T if c is either an alphabetic or numeric character"
  (or (alpha-char-p c)
      (digit-char-p c)))


(defun CHAR-UPCASE (c)
  (li:%trap-if-not-character c)
  (let ((char (char-code c)))
    (if (and (>= char char-int-lower-a) (<= char char-int-lower-z))
	(hw:dpb (- char (- char-int-lower-a char-int-upper-a)) %%ch-char c)
      c)))

;(defun CHAR-UPCASE (c)
;  (li:%trap-if-not-character c)
;  (if (char<= #\a c #\z)
;      (int-char (- (char-int c)
;		   (- (char-int #\a)
;		      (char-int #\A))))
;    c))

(defun CHAR-DOWNCASE (c)
  (li:%trap-if-not-character c)
  (let ((char (char-code c)))
    (if (and (>= char char-int-upper-a) (<= char char-int-upper-z))
	(hw:dpb (+ char (- char-int-lower-a char-int-upper-a)) %%ch-char c)
      c)))

;(defun CHAR-UPCASE (c)
;  (if (char<= #\A c #\Z)
;      (int-char (+ (char-int c)
;		   (- (char-int #\a)
;		      (char-int #\A))))
;    c))


(defun CHAR-BIT (c bit-name)
  "T if the bit specified by BIT-NAME (a keyword) is on in CHAR.
BIT-NAME can be :CONTROL, :META, :SUPER or :HYPER."
  (li:%trap-if-not-character c)
  (hw:32logbitp
    (+ (byte-position %%ch-bits)
       (case bit-name
	 (:CONTROL char-control-bit)
	 (:META    char-meta-bit)
	 (:SUPER   char-super-bit)
	 (:HYPER   char-hyper-bit)
	 (t (error "Illegal bit name to CHAR-BIT: ~s" bit-name))))
    c))

(defun SET-CHAR-BIT (c bit-name value)
  (li:%trap-if-not-character c)
  (hw:dpb-boxed
    value
    (byte 1. (cond
	       ((eq bit-name ':control)
		(+ char-control-bit (byte-position %%ch-bits)))
	       ((eq bit-name ':meta)
		(+ char-meta-bit (byte-position %%ch-bits)))
	       ((eq bit-name ':super)
		(+ char-super-bit (byte-position %%ch-bits)))
	       ((eq bit-name ':hyper)
		(+ char-hyper-bit (byte-position %%ch-bits)))
	       (t (trap::illop "Illegal bit name to CHAR-BIT"))))
    c))

;;; compiler rewiters for the character predicates are defined in "k-sys:FLEABIT;REWRITE.LISP".
;;; That's why it is O.K. to refer to the comparison function in these definitions.  Normally
;;; the compiler rewriters will implement these operations.  The definitions here exist to
;;; support use of these comparison operations as callable functions, for example with FUNCALL,
;;; APPLY and the interpreter.

(defmacro define-n-arg-compare-function (function)
  `(defun ,function (&rest args)
     (cond ((null args) t)
	   ((null (cdr args)) t)
	   (t (do ((args args (cdr args)))
		  ((null (cdr args)) t) 
		(unless (,function (first args) (second args))
		  (return nil)))))))

(define-n-arg-compare-function li:char<)
(define-n-arg-compare-function li:char<=)
(define-n-arg-compare-function li:char=)
(define-n-arg-compare-function li:char>=)
(define-n-arg-compare-function li:char>)

(defun CHAR/= (&rest characters)
  (cond ((null characters) t)
	((null (cdr characters)) t)
	(t (block foo
	     (do ((c1 characters (cdr c1)))
		 ((null (cdr c1)) (return-from foo t))
	       (do ((c2 (cdr c1) (cdr c2)))
		   ((null c2))
		 (unless (char/= (car c1) (car c2))
		   (return-from foo nil))))))))

(defmacro define-char-????-predicate-functions (n-arg-name 2-arg-name 3-arg-name primitive)
  `(progn

     (defun ,2-arg-name (char1 char2)
       (,primitive (char-upcase char1)
		       (char-upcase char2)))

     (defun ,3-arg-name (char1 char2 char3)
       (let ((c2 (char-upcase char2)))
	 (and (,primitive (char-upcase char1) c2)
	      (,primitive c2 (char-upcase char3)))))
       
     (defun ,n-arg-name (first-char &rest chars)
       (if (null chars)
	   t
	 (do* ((char (char-upcase first-char)
		     next-char)
	       (chars chars (cdr chars))
	       (next-char (char-upcase (car chars))
			  (char-upcase (car chars))))
	      ((null (cdr chars))
	       (,primitive char next-char))
	   (unless (,primitive char next-char)
	     (return nil)))))
       ))

(define-char-????-predicate-functions char-equal char-equal-2-args
				      char-equal-3-args li:%char-equal)
(define-char-????-predicate-functions char-lessp char-lessp-2-args
				      char-lessp-3-args li:%char-lessp)
(define-char-????-predicate-functions char-greaterp char-greaterp-2-args
				      char-greaterp-3-args li:%char-greaterp)
(define-char-????-predicate-functions char-not-lessp char-not-lessp-2-args
				      char-not-lessp-3-args li:%char-not-lessp)
(define-char-????-predicate-functions char-not-greaterp char-not-greaterp-2-args
				      char-not-greaterp-3-args li:%char-not-greaterp)

(defun char-not-equal-2-args (char1 char2)
  (li:%char-not-equal (char-upcase char1)
		      (char-upcase char2)))

(defun char-not-equal-3-args (char1 char2 char3)
  (let ((c1 (char-upcase char1))
	(c2 (char-upcase char2))
	(c3 (char-upcase char3)))
  (and (li:%char-not-equal c1 c2)
       (li:%char-not-equal c1 c3)
       (li:%char-not-equal c2 c3))))

(defun char-not-equal (char &rest chars)
  (do ((chars (mapcar #'char-upcase (cons char chars))
	      (cdr chars)))
      ((null chars) t)
    (do ((cs (cdr chars) (cdr cs)))
	((null cs))
      (unless (li:%char-not-equal (car chars) (car cs))
	(return-from char-not-equal nil)))))


(defun code-char (code &optional (bits 0) (font 0))
  (make-char (int-char code) bits font))

(defun CHARACTER (thing)
  "Coerce THING into a character"
  (cond
    ((vinc:characterp thing)	thing)
    ((stringp thing) (if (= 1 (array:%string-length thing))
			 (array:svref thing 0)
		       (error "The string ~s is the wrong length to be coerced into a character" thing)))
    ((vinc:symbolp thing) (let ((pname (symbol:symbol-name thing)))
		       (if (= 1 (array:%string-length thing))
			   (array:svref thing 0)
			 (error "The symbol ~s has a print name that is the wrong length to be coerced into a character" thing))))
    ((vinc:integerp thing) (int-char thing))
    (t		(error "The object ~s can not be coerced into a character" thing))))

(defun MAKE-CHAR (char &optional (bits 0) (font 0))
  (if (vinc:characterp char)
      (hw:dpb-boxed font %%ch-font (hw:dpb-boxed bits %%ch-bits char))
    (error "MAKE-CHAR expected a character, not ~a" char)))


(defun CHAR-NAME (c) ;;;; Fix ME
  nil)