;;; -*- Mode:Lisp; Package:DYPAR; Base:10; -*-


;;; ----------------------------------------------------------------
;;;
;;; 		(c) Copyright, 1989,
;;; 			by Mark Boggs and
;;;                     Jesus Gonzalez Boticario
;;;                     para Rank Xerox Espa¤ola S.A.
;;; 			All rights reserved
;;;
;;; ----------------------------------------------------------------

;;; DYTEST.LSP

;;; HISTORY
;;; 11-Sep-89 Jesus Gonzalez Boticario para Rank Xerox Espa¤a,
;;;   Modificacion de la funcion "applyrule-tester" para que considere
;;; los casos especiales de elipsis, de anafora, de la posible aplicacion
;;; del nuevo tipo de reglas llamadas de recuperacion.

;;;   Transformacion de la antigua "apply-rule-tester", ahora llamada
;;; "applyrule-tester1" para que considere la correccion ortografica.

;;;   Creacion de la funcion "applyrecos-tester" para tener en cuenta
;;; las reglas de recuperacion.

(in-package "DYPAR"); :use '("LISP" "USER" "GCLISP"))

;;; make sure the macros are around at compile time.
(eval-when (compile)
    (if (not (boundp '*macros-loaded*)) (load "macros"))
    (if (not (boundp '*struc-loaded*)) (load "struc"))
    (if (not (boundp '*babel-loaded*)) (load "babel")))

;;; These are the global variables referenced in this file

(proclaim '(special !!transmax !xmatch !newvars !!pattrans
	     !!current-vars !!readlist !!patrules $%FAILURES%$
	     !failure-flag !thisrule! !!bpunct !trans !ptrace
	     !!global-strategy-int !!global-strategy-ext
	     !original-input-string *language* *basic-dypar-test*))


;;; This function tests the functionality of the pattern matcher.  It's
;;; argument should be of the form of the the contents of the variable
;;; *basic-dypar-test*

(defun test-match (tlist)
  (terpri)
  (dolist (l tlist)
    (let ((val (xmatch (cadr l) (car l))))
      (if (not (equal val (caddr l)))
	  (format t "~2%Xmatch returned: ~S,~& but we were expecting: ~S~&  ~
		     Pattern was:  ~S with input:  ~S~&"
		  val (caddr l) (car l) (cadr l))
	  (format t "."))))
  (terpri))

;;; Form is pattern input expected-result
(defvar *basic-dypar-test*
  '(((a) (a) ((1))) 			; explicit match
    (((&m a b c)) (c) ((1))) 		; simple single word disjunct
    (((&m a b c)) (d) nil) 		; simple single word disjunct missing
    (((! (a) (b c) (d))) (b c) ((2))) 	; complex non-deterministic disjunct
    (((!! (a) (b c) (d))) (b c) ((2))) 	; complex deterministic disjunct
    (((? a) b) (b) ((1))) 		; non-deterministic optional missing
    (((? a) b) (a b) ((2))) 		; non-deterministic optional included
    (((&o a) b) (b) ((1))) 		; deterministic optional missing
    (((&o a) b) (a b) ((2))) 		; deterministic optional included
    (((* a) b) (a a a a b) ((5))) 	; Kleene star included
    (((* a) b) (b) ((1))) 		; Kleene star missing
    (((+ a)) (a a a a) ((4))) 		; Kleene plus included
    (((+ a) b) (b) nil) 		; Kleene plus missing
    (((^ 3 a) b) (a a a b) ((4))) 	; specified repitition included
    (((^ 3 a) b) (a a b) nil) 		; specified repitition missing
    (((:= !foo a)) (a) ((1 (!foo a)))) 	; variable assignment included
    (((:= !foo a)) (b) nil) 		; variable assignment missing
    (((:= !foo a) (= !foo))
     (a a) ((2 (!foo a))))		; variable reference included
    (((:= !foo a) (= !foo)) (a b) nil) 	; variable reference missing
    (((* (:= *var* $))) (a b c)
     ((3 (var3 c) (var2 b) (var1 a)))) 	; generate var names
    (((:= !foo (&i b a)))
     (a) ((1 (!foo b)))) 		; variable coercion included
    (((:= !foo (&i b a))) (b) nil) 	; variable coercion missing
    (($) (a) ((1))) 			; wildcard
    (($n) (3) ((1))) 			; numeric wildcard included
    (($n) (a) nil) 			; numeric wildcard missing
    (($w) (a) ((1))) 			; symbolic wildcard included
    (($w) (3) nil) 			; symbolic wildcard missing
;;; $d
    (($r) (a b c) ((3))) 		; rest of the input
    (((&u c) c) (a b c) ((3))) 		; upto not including included
    (((&u c) d) (a b d) nil) 		; upto not including missing
    (((&ui c)) (a b c) ((3))) 		; upto including included
    (((&ui d)) (a b c) nil) 		; upto including missing
    (((&s c) $r) (a b c d) ((4))) 	; scanning included
    (((&s e) $r) (a b c d) nil) 	; scanning missing
    (((&n a) b) (b) ((1))) 		; stationary not included
    (((&n a) a) (a) nil) 		; stationary not missing
    (((~ a)) (b) ((1))) 		; not included
    (((~ a)) (a) nil) 			; not missing
;;; &apply
;;; &funcall
;;; &morph
    ))

;;; In place of the dypar reader we present a testing function that accepts
;;; input parse-value pairs.  Patterns are drawn from the currently loaded
;;; grammar whatever that may be.
(defun test-parser (test-series)
  (format t "~&Running Dypar Parser Test~&")
  (do ((tlist test-series (cdr tlist))
       (tmp))
      ((null tlist) (format t "~&Testing Completed~&"))
    (setq tmp (applyrule-tester (caar tlist)))
    (if (or (and (null tmp) (null (cadar tlist)))
	    (not (equal tmp (cadar tlist))))
	(format t "Parser failure on Input: ~S~&  Expecting: ~S~&  Got: ~S"
		(caar tlist)
		(cadar tlist)
		tmp))))

;;; Ampliacion de applyrule-tester1 para que considere los casos especiales
;;; de correccion de errores ortograficos y aplicacion de reglas de 
;;; recuperacion.
(defun applyrule-tester (sen)
  (or (applyrule-tester1 sen)
      (let ((rev (revisarfrase sen)))
	(and (not (equal sen rev)) (applyrule-tester1 rev)))
      (applyrecos-tester sen))
  )


;;; Creacion de la nueva funcion "applyrecos-tester" para comprobar si 
;;; hay alguna regla de recuperacion aplicable.
(defun applyrecos-tester (sen)
  (let ((eleccion)
	(resul (applyrule-try-them sen !!recorules)))
    (if resul
	(progn
	  (setq eleccion (resolve-collision resul))
	  (setq !newvars (newvars (cdr eleccion)))
	  eleccion))))


;;; A simplified version of applyrule that returns the choice made without
;;; evaluating the associated action. 
;;; Integracion de la aplicacion de elipsis y anafora.
(defun applyrule-tester1 (sen)
  (setq !trans !!transmax)
  (do ((ans (apply-top-level-rules-tester sen)
	    (apply-top-level-rules-tester sen))
       (otrans !trans !trans)
       (choice))
      (ans (setq !xmatch ans)
	   (setq choice (elip-anaf (resolve-collision ans)))
	   (setq !newvars (newvars (cdr choice)))
	   choice)
    (cond ((> 1 !trans)
	   (return nil)))
    (setq !newvars nil !!current-vars nil)
    (setq sen (applytrans sen !!pattrans))
    (cond ((= otrans !trans)
	   (return nil)))))


(defun apply-top-level-rules-tester (sen)
  (let ((likely-rules (find-applicable-specific
			(car sen) (car (last sen)))))
    (or (applyrule-try-them sen likely-rules)
	(and (setq likely-rules (find-applicable-general
				  (car sen)
				  (car (last sen))
				  likely-rules))
	     (applyrule-try-them sen likely-rules)))))