;;; -*- Mode: LISP; Package: USER; Base: 10; Syntax: Common-Lisp -*-

;;; Written by Jeff Siskind Fall 1991,
;;; Revised by Mark Torrance Fall 1992.

(in-package :screamer-user)

(export '(*corpus1*
          *corpus2*
	  *corpus3*
	  *corpus4*
          *lexicon*
          on
          of
          initialize-lexicon
          test-corpus1
          test-corpus2
	  test-corpus3
	  test-corpus4))

(defvar *corpus1*)
(setf *corpus1*
      '((every white piece on some black square is some pawn)
	(the piece on some white corner is some bishop)
	(the piece on some white corner is some king)
	(the piece on some black corner is some bishop)
	(every pawn is-on some square)
	(some pawn is-on some file of every corner)
	(some piece is-on some white rank)
	(the white rook is-on some corner)
	(the bishop on some white corner is-on the rank of the black king)
	(the bishop is-on some corner)
	(some is-on corner black bishop every)
	(the piece on some white corner is-on the file of the pawn on
	 the rank of the white king)))

(defvar *corpus2*)
(setf *corpus2*
      '((the black rook is-on some corner)
	(the white king is-on some edge)
	(the black king is-on some edge)
	(the white king is-on some edge or the black rook is-on some corner)
	(the white king is-on some edge and the black rook is-on some corner)
	(the white king is-on some edge and the black rook is-on some
	 corner or the black king is-on some edge)))

(defvar *corpus3*)
(setf *corpus3*
      '((the black king is black)
	(the black king is white)
	(some piece is white)
	(some piece on some corner is white)
	(some piece on some edge is white)
	(every piece on some corner is white)))

(defvar *corpus4*)
(setf *corpus4*
      '((the white king is-on some neighbor of some pawn)
	(the black king is some neighbor of some piece)
	(the white king is some neighbor of some neighbor of some rook)
	(the white king is some neighbor of some king)
	(every white king is-on some neighbor of some white pawn)
	(some white pawn is-on some neighbor of every white king)
	(some white king is some neighbor of the black rook)
	(some white pawn is some neighbor on every rank)
	(some neighbor of every pawn is some square)
	(some neighbor of every rook is some square)
	(some pawn is some neighbor of some king)
	(some pawn is some neighbor on some square)
	(some neighbor of every rook is some rank)
	(some neighbor of every rank is of some square)
	(some pawn is-on some neighbor of some corner)
	(some pawn is-on some neighbor of some file)
	(some white square is some neighbor of the white king)
	(some black square is some neighbor of the white king)
	(every pawn is-on some neighbor of some file)
	(every king is some neighbor of some pawn)
	(some king is some neighbor of some pawn)
	(some neighbor of some square is some king)
	(some neighbor of some bishop is some file)
	(some neighbor on some bishop is some file)
	(some neighbor of the black rook is some pawn)
	(some neighbor of some neighbor of the black rook is some pawn)
	(the rook is-on some neighbor of some corner)
	(the rook is some neighbor of some corner)
	(some pawn is-on some neighbor of some king)
	(some pawn is some neighbor of some rook)
	(some pawn is some neighbor of some neighbor of some rook)
	(some king is-on some neighbor of some neighbor of some edge)))

(defvar *lexicon* nil)

(defun on (x y)
 (cond
   ((and (eq (first x) 'square) (eq (first y) 'rank))
    (= (second x) (second y)))
   ((and (eq (first x) 'square) (eq (first y) 'file)) (= (third x) (second y)))
   ((and (or (eq (first x) 'white) (eq (first x) 'black))
         (eq (first y) 'square))
    (and (= (third x) (second y)) (= (fourth x) (third y))))
   ((and (or (eq (first x) 'white) (eq (first x) 'black)) (eq (first y) 'rank))
    (= (third x) (second y)))
   ((and (or (eq (first x) 'white) (eq (first x) 'black)) (eq (first y) 'file))
    (= (fourth x) (second y)))
   ;; this fail implements a semantic constraint
   (t (fail))))

(defun of (x y)
 (cond
   ((and (eq (first x) 'square) (eq (first y) 'rank))
    (= (second x) (second y)))
   ((and (eq (first x) 'square) (eq (first y) 'file)) (= (third x) (second y)))
   ((and (eq (first x) 'square)
         (or (eq (first y) 'white) (eq (first y) 'black)))
    (and (= (second x) (third y)) (= (third x) (fourth y))))
   ((and (eq (first x) 'rank) (eq (first y) 'square))
    (= (second x) (second y)))
   ((and (eq (first x) 'rank) (or (eq (first y) 'white) (eq (first y) 'black)))
    (= (second x) (third y)))
   ((and (eq (first x) 'file) (eq (first y) 'square)) (= (second x) (third y)))
   ((and (eq (first x) 'file) (or (eq (first y) 'white) (eq (first y) 'black)))
    (= (second x) (fourth y)))
   ;; this fail implements a semantic constraint
   (t (fail))))

(defun initialize-lexicon ()
 (let* ((situation '((white pawn 4 1)
		     (white pawn 4 5)
		     (white pawn 3 8)
		     (white king 3 5)
		     (black rook 1 8)
		     (black bishop 8 1)
		     (black king 8 5)
		     (black bishop 8 8)))
	(objects `(,@(loop for rank from 1 to 8
			   append (loop for file from 1 to 8
					collect `(square ,rank ,file)))
		   ,@(loop for rank from 1 to 8 collect `(rank ,rank))
		   ,@(loop for file from 1 to 8 collect `(file ,file))
		   ,@situation)))
  (setf *lexicon*
	`((square (object -> boolean) ,#'(lambda (x) (eq (first x) 'square)))
	  (piece (object -> boolean)
	   ,#'(lambda (x)
	       (or (eq (second x) 'pawn)
		   (eq (second x) 'rook)
		   (eq (second x) 'knight)
		   (eq (second x) 'bishop)
		   (eq (second x) 'queen)
		   (eq (second x) 'king))))
	  (pawn (object -> boolean) ,#'(lambda (x) (eq (second x) 'pawn)))
	  (rook (object -> boolean) ,#'(lambda (x) (eq (second x) 'rook)))
	  (knight (object -> boolean) ,#'(lambda (x) (eq (second x) 'knight)))
	  (bishop (object -> boolean) ,#'(lambda (x) (eq (second x) 'bishop)))
	  (queen (object -> boolean) ,#'(lambda (x) (eq (second x) 'queen)))
	  (king (object -> boolean) ,#'(lambda (x) (eq (second x) 'king)))
	  (rank (object -> boolean) ,#'(lambda (x) (eq (first x) 'rank)))
	  (file (object -> boolean) ,#'(lambda (x) (eq (first x) 'file)))
	  (edge (object -> boolean)
	   ,#'(lambda (x)
	       (and (or (eq (first x) 'rank) (eq (first x) 'file))
		    (or (= (second x) 1) (= (second x) 8)))))
	  (corner (object -> boolean)
	   ,#'(lambda (x)
	       (and (eq (first x) 'square)
		    (or (= (second x) 1) (= (second x) 8))
		    (or (= (third x) 1) (= (third x) 8)))))
	  (black ((object -> boolean) -> (object -> boolean))
	   ,#'(lambda (noun)
	       #'(lambda (x)
		  (and (funcall noun x)
		       (cond
			 ((eq (first x) 'black) t)
			 ((eq (first x) 'white) nil)
			 ((eq (first x) 'square)
			  (oddp (+ (second x) (third x))))
			 ;; this fail implements a semantic constraint
			 (t (fail)))))))
	  (white ((object -> boolean) -> (object -> boolean))
	   ,#'(lambda (noun)
	       #'(lambda (x)
		  (and (funcall noun x)
		       (cond
			 ((eq (first x) 'black) nil)
			 ((eq (first x) 'white) t)
			 ((eq (first x) 'square)
			  (evenp (+ (second x) (third x))))
			 ;; this fail implements a semantic constraint
			 (t (fail)))))))
	  (every ((object -> boolean) -> ((object -> boolean) -> boolean))
	   ,#'(lambda (noun)
	       #'(lambda (vp)
		  (every #'(lambda (x)
			    (or (not (funcall noun x))
				(funcall vp x)))
			 objects))))
	  (some ((object -> boolean) -> ((object -> boolean) -> boolean))
	   ,#'(lambda (noun)
	       #'(lambda (vp)
		  (some #'(lambda (x)
			   (and (funcall noun x) (funcall vp x)))
			objects))))
	  (the ((object -> boolean) -> ((object -> boolean) -> boolean))
	   ,#'(lambda (noun)
	       #'(lambda (vp)
		  (if (= (count-if noun objects) 1)
		      (funcall vp (find-if noun objects))
		      (fail)))))
	  (is-on (((object -> boolean) -> boolean)
		  ->
		  (boolean <- ((object -> boolean) -> boolean)))
	   ,#'(lambda (object)
	       #'(lambda (subject)
		  (funcall
		   subject
		   #'(lambda (x)
		      (funcall
		       object #'(lambda (y) (on x y))))))))
	  (is-on (((object -> boolean) -> boolean)
		  ->
		  (boolean <- ((object -> boolean) -> boolean)))
	   ,#'(lambda (object)
	       #'(lambda (subject)
		  (funcall
		   object
		   #'(lambda (y)
		      (funcall
		       subject #'(lambda (x) (on x y))))))))
	  (is (((object -> boolean) -> boolean)
	       ->
	       (boolean <- ((object -> boolean) -> boolean)))
	   ,#'(lambda (object)
	       #'(lambda (subject)
		  (funcall
		   subject
		   #'(lambda (x)
		      (funcall
		       object #'(lambda (y) (equal x y))))))))
	  (is (((object -> boolean) -> boolean)
	       ->
	       (boolean <- ((object -> boolean) -> boolean)))
	   ,#'(lambda (object)
	       #'(lambda (subject)
		  (funcall
		   object
		   #'(lambda (y)
		      (funcall
		       subject #'(lambda (x) (equal x y))))))))
	  (of (((object -> boolean) -> boolean)
	       ->
	       ((object -> boolean) <- (object -> boolean)))
	   ,#'(lambda (object)
	       #'(lambda (noun)
		  #'(lambda (x)
		     (and (funcall noun x)
			  (funcall object #'(lambda (y) (of x y))))))))
	  (on (((object -> boolean) -> boolean)
	       ->
	       ((object -> boolean) <- (object -> boolean)))
	   ,#'(lambda (object)
	       #'(lambda (noun)
		  #'(lambda (x)
		     (and (funcall noun x)
			  (funcall object
				   #'(lambda (y) (on x y))))))))))))

(defun test-corpus1 ()
 (initialize-lexicon)
 (dolist (sentence *corpus1*)
  (format t "~&Sentence: ~A, Meanings: ~A~%" sentence (true? sentence))))

(defun test-corpus2 ()
  (initialize-lexicon)
  (new-definition-for-conj)
  (dolist (sentence *corpus2*)
    (format t "~&Sentence: ~A, Meanings: ~A~%" sentence (true? sentence))))

(defun test-corpus3 ()
 (initialize-lexicon)
 (new-definition-for-is)
 (dolist (sentence *corpus3*)
  (format t "~&Sentence: ~A, Meanings: ~A~%" sentence (true? sentence))))

(defun test-corpus4 ()
 (initialize-lexicon)
 (new-definitions-for-neighbor)
 (dolist (sentence *corpus3*)
  (format t "~&Sentence: ~A, Meanings: ~A~%" sentence (true? sentence))))

;;; The following two lists contain the types t that can be parsed as
;;; t->t' or t'<-t respectively. They are derived from table 2.

(defvar *left-types*)
(setf *left-types*
      `((object -> boolean)
	((object -> boolean) -> boolean)))

(defvar *right-types*)
(setf *right-types*
      `((object -> boolean)
	((object -> boolean) -> boolean)))
	

(defun true? (sentence)
  (interpret sentence 'boolean))

(defun interpret (sentence type)
  ;;; If the sentence is empty then fail
  (if (not sentence)
      (fail)
    ;;; If there is just a word
    (if (not (cdr sentence))
        ;;; then interpret it only if it is of the right type
	(if (equal type (look-type (car sentence) *lexicon*))
	    (look-value (car sentence) *lexicon*)
	  (fail))
      ;;; else pick a split point and a type and recurse
      (interpret-split (list (car sentence)) (cdr sentence) type))))

(defun interpret-split (s1 s2 type)
  (if (or (not s1) (not s2))
      (fail)
    (either (interpret-splitted s1 s2 type)
	    (interpret-split (append s1 (list (car s2))) (cdr s2) type))))

(defun interpret-splitted (s1 s2 type)
  (either (interpret-forward s1 s2 type)
	  (interpret-backward s1 s2 type)))

(defun interpret-forward (s1 s2 type)
  (setf type1 (a-member-of *left-types*))
  (setf type2 (list type1 '-> type))
  (funcall (interpret s1 type2) (interpret s2 type1)))

(defun interpret-backward (s1 s2 type)
  (setf type1 (a-member-of *right-types*))
  (setf type2 (list type '<- type1))
  (funcall (interpret s2 type2) (interpret s1 type1)))

(defun look-type (word lex)
  (if (not lex)
      (fail)
    (if (equal (car (car lex)) word)
	(either (car (cdr (car lex)))
		(look-type word (cdr lex)))
      (look-type word (cdr lex)))))

(defun look-value (word lex)
  (if (not lex)
      (fail)
    (if (equal (car (car lex)) word)
	(either (car (cdr (cdr (car lex))))
		(look-value word (cdr lex)))
      (look-value word (cdr lex)))))