;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Oct  5 20:15:55 2002
;;;; Contains: Auxiliary functions for character tests

(in-package :cl-test)

(defun is-ordered-by (seq fn)
  (let ((n (length seq)))
    (loop for i from 0 below (1- n)
	  for e = (elt seq i)
	  always
	  (loop for j from (1+ i) below n
		always (funcall fn e (elt seq j))))))

(defun is-antisymmetrically-ordered-by (seq fn)
  (and (is-ordered-by seq fn)
       (is-ordered-by (reverse seq) (complement fn))))

(defun is-case-insensitive (fn)
  (loop for c across +code-chars+
	for c1 = (char-upcase c)
	for c2 = (if (eql c c1) (char-downcase c) c1)
	always
	(loop for d across +code-chars+
	      for d1 = (char-upcase d)
	      for d2 = (if (eql d d1) (char-downcase d) d1)
	      always (equiv (funcall fn c d)
			    (funcall fn c2 d)
			    (funcall fn c d2)
			    (funcall fn c2 d2)))))

(defun equiv (&rest args)
  (declare (dynamic-extent args))
  (cond
   ((null args) t)
   ((car args)
    (loop for e in (cdr args) always e))
   (t (loop for e in (cdr args) never e))))

;;; From character.lsp
(defun char-type-error-check (fn)
  (loop for x in *universe*
	always (or (characterp x)
		   (eqt (catch-type-error (funcall fn x)) 'type-error))))

(defun standard-char.5.body ()
  (loop for i from 0 below (min 65536 char-code-limit)
	always (let ((c (code-char i)))
		 (not (and (typep c 'standard-char)
			   (not (standard-char-p c)))))))

(defun extended-char.3.body ()
  (loop for i from 0 below (min 65536 char-code-limit)
	always (let ((c (code-char i)))
		 (not (and (typep c 'extended-char)
			   (typep c 'base-char))))))

(defun character.1.body ()
  (loop for i from 0 below (min 65536 char-code-limit)
	always (let ((c (code-char i)))
		 (or (null c)
		     (let ((s (string c)))
		       (and
			(eqlt (character c) c)
			(eqlt (character s) c)
			(eqlt (character (make-symbol s)) c)))))))

(defun character.2.body ()
  (loop for x in *universe*
	when (not (or (characterp x)
		      (and (stringp x) (eqlt (length x) 1))
		      (and (symbolp x) (eqlt (length (symbol-name x)) 1))
		      (let ((c (catch-type-error (character x))))
			(or (eqlt c 'type-error)
			    (let ((s (catch-type-error (string x))))
			      (and (stringp s) (eqlt (char s 0) c)))))))
	do (return x)))

(defun characterp.2.body ()
  (loop for i from 0 below (min 65536 char-code-limit)
	always (let ((c (code-char i)))
		 (or (null c) (characterp c)))))

(defun characterp.3.body ()
  (loop for x in *universe*
	always (let ((p (characterp x))
		     (q (typep x 'character)))
		 (if p (notnot q) (not q)))))

(defun alphanumericp.4.body ()
  (loop for x in *universe*
	always (or (not (characterp x))
		   (if (or (digit-char-p x) (alpha-char-p x))
		       (alphanumericp x)
		     ;; The hyperspec has an example that claims alphanumeric ==
		     ;;  digit-char-p or alpha-char-p, but the text seems to suggest
		     ;;  that there can be numeric characters for which digit-char-p
		     ;;  returns NIL.  Therefore, I've weakened the next line
		     ;; (not (alphanumericp x))
		     t
		     ))))

(defun alphanumericp.5.body ()
  (loop for i from 0 below (min 65536 char-code-limit)
	for x = (code-char i)
	always (or (not (characterp x))
		   (if (or (digit-char-p x) (alpha-char-p x))
		       (alphanumericp x)
		     ;; The hyperspec has an example that claims alphanumeric ==
		     ;;  digit-char-p or alpha-char-p, but the text seems to suggest
		     ;;  that there can be numeric characters for which digit-char-p
		     ;;  returns NIL.  Therefore, I've weakened the next line
		     ;; (not (alphanumericp x))
		     t		     
		     ))))

(defun digit-char.1.body ()
  (loop
   for r from 2 to 36
   always
   (loop for i from 0 to 36
	 always (let ((c (digit-char i r)))
		  (if (>= i r) (null c)
		    (eqlt c (char +extended-digit-chars+ i)))))))

(defun digit-char-p.1.body ()
  (loop for x in *universe*
	always (not (and (characterp x)
			 (not (alphanumericp x))
			 (digit-char-p x)))))

(defun digit-char-p.2.body ()
  (loop for i from 0 below (min 65536 char-code-limit)
	for x = (code-char i)
	always (or (not x)
		   (not (and (not (alphanumericp x))
			     (digit-char-p x))))))

(defun digit-char-p.3.body ()
  (loop for r from 2 to 35
	always
	(loop for i from r to 35
	      for c = (char +extended-digit-chars+ i)
	      never (or (digit-char-p c r)
			(digit-char-p (char-downcase c) r)))))

(defun digit-char-p.4.body ()
  (loop for r from 2 to 35
	always
	(loop for i from 0 below r
	      for c = (char +extended-digit-chars+ i)
	      always (and (eqlt (digit-char-p c r) i)
			  (eqlt (digit-char-p (char-downcase c) r) i)))))

(defun standard-char-p.2.body ()
  (loop for x in *universe*
	always (or (not (characterp x))
		   (find x +standard-chars+)
		   (not (standard-char-p x)))))

(defun standard-char-p.2a.body ()
  (loop for i from 0 below (min 65536 char-code-limit)
	for x = (code-char i)
	always (or (not (characterp x))
		   (find x +standard-chars+)
		   (not (standard-char-p x)))))

(defun char-upcase.1.body ()
  (loop for x in *universe*
	always
	(or (not (characterp x))
	    (let ((u (char-upcase x))) 
	      (and
	       (or (lower-case-p x) (eqlt u x))
	       (eqlt u (char-upcase u)))))))

(defun char-upcase.2.body ()
  (loop for i from 0 below (min 65536 char-code-limit)
	for x = (code-char i)
	always
	(or (not x)
	    (let ((u (char-upcase x)))
	      (and
	       (or (lower-case-p x) (eqlt u x))
	       (eqlt u (char-upcase u)))))))

(defun char-downcase.1.body ()
  (loop for x in *universe*
	always
	(or (not (characterp x))
	    (let ((u (char-downcase x))) 
	      (and
	       (or (upper-case-p x) (eqlt u x))
	       (eqlt u (char-downcase u)))))))

(defun char-downcase.2.body ()
  (loop for i from 0 below (min 65536 char-code-limit)
	for x = (code-char i)
	always
	(or (not x)
	    (let ((u (char-downcase x)))
	      (and
	       (or (upper-case-p x) (eqlt u x))
	       (eqlt u (char-downcase u)))))))

(defun both-case-p.1.body ()
  (loop for x in *universe*
	always (or (not (characterp x))
		   (if (both-case-p x)
		       (and (graphic-char-p x)
			    (or (upper-case-p x)
				(lower-case-p x)))
		     (not (or (upper-case-p x)
			      (lower-case-p x)))))))

(defun both-case-p.2.body ()
  (loop for i from 0 below (min 65536 char-code-limit)
	for x = (code-char i)
	always (or (not (characterp x))
		   (if (both-case-p x)
		       (and (graphic-char-p x)
			    (or (upper-case-p x)
				(lower-case-p x)))
		     (not (or (upper-case-p x)
			      (lower-case-p x)))))))

(defun char-code.2.body ()
  (loop for i from 0 below (min 65536 char-code-limit)
	for c = (code-char i)
	always (or (not c)
		   (eqlt (char-code c) i))))

(defun char-int.2.fn ()
  (declare (optimize (safety 3) (speed 1) (space 1)))
  (let ((c->i (make-hash-table :test #'equal))
	(i->c (make-hash-table :test #'eql)))
    (flet ((%insert
	    (c)
	    (or (not (characterp c))
		(let* ((i (char-int c))
		       (j (gethash c c->i))
		       (d (gethash i i->c)))
		  (and
		   (or (null j) (eqlt j i))
		   (or (null d) (char= c d))
		   (progn
		     (setf (gethash c c->i) i)
		     (setf (gethash i i->c) c)
		     t))))))
      (and
       (loop for i from 0 below char-code-limit
	     always (%insert (code-char i)))
       (every #'%insert +standard-chars+)
       (every #'%insert *universe*)
       t))))

(defun char-name.1.fn ()
  (declare (optimize (safety 3) (speed 1) (space 1)))
  (flet ((%check
	  (c)
	  (or (not (characterp c))
	      (let ((name (char-name c)))
		(or (null name)
		    (and (stringp name)
			 (eqlt c (name-char name))))))))
    (and
     (loop for i from 0 below char-code-limit
	   always (%check (code-char i)))
     (every #'%check +standard-chars+)
     (every #'%check *universe*)
     t)))

(defun name-char.1.body ()
  (declare (optimize (safety 3)))
  (loop for x in *universe*
	for s = (catch-type-error (string x))
	always
	(or (eqlt s 'type-error)
	    (let ((c (name-char x)))
	      (or (not c)
		  (characterp c)
		  (let ((name (char-name c)))
		    (declare (type (or null string) name))
		    (and name
			 (string-equal name s))))))))
