;;; *****************************
;;; *  PORTABLE AI LAB  - IDSIA *
;;; *****************************
;;;  
;;; Filename:    Net-6 
;;; Module:      ATN AUGMENTED TRANSITION NETWORKS
;;; Author(s):   Fabio Baj 
;;; Short Desc:  A sample network which returns a 3BQ formalism
;;;===================================================================

;; Example sentences (must run with lexicon lex-3
;;
;; paolo loves every woman who does not have any car
;; Mary is the  woman who needs this program
;; Paolo does not  see the man who knows every woman
;; Mary likes luca and luca likes mary
;; every woman knows the man who eats a pizza
;; this man is a woman
;; 
;;
;;
;;


(in-package :atn)
(setq *network*
  '(
   (FR
     (regs FLS1 FLS2 CONN)
     (0 (push S 1 t () (setr FLS1 *)))
       
     (1 (cat Conj 2 t (setr CONN (getftr CONN)))
         (pop t  (postp (3bq2fmla (getr FLS1)))))
     (2 (push S 3 t () (setr FLS2 *)))
     (3 (pop t
        (postp (3bq2fmla
            (build CONN FLS1 FLS2))))))
   (S  
     (regs FL ESOGG FLVERB SN-OUT)
     (init (progn (setr ESOGG (newvar))))
     (0 (push SN 1 t  (sendr SN-ESOGG (getr ESOGG))
                    (progn 
                      (setr SN-OUT *)
                      (cond ((eq 'constant (car (getr SN-OUT)))
                             (setr ESOGG (cadr (getr SN-OUT))))))))
                                                     

     (1 (push SV 2 t (sendr SV-ESOGG (getr ESOGG))
                    (setr  FLVERB *)))
     (2 (pop t
    
     	(if (eq 'constant (car (getr SN-OUT)))
            (getr  FLVERB)
          (append (getr SN-OUT)(list(getr  FLVERB)))))))
    (SN
     (regs SN-ESOGG SN-PRED SN-DET RELOUT)
    
     (0 (cat PN 4  t (setr SN-ESOGG (getftr PRED)))
	(cat DET 1 t (setr SN-DET *)))
     (1 (cat N 2  t (setr SN-PRED (getftr PRED))))
     (2 (push REL 3 t
                    (progn (sendr EN (getr SN-ESOGG))
                           (sendr FLN  (build SN-PRED SN-ESOGG)))
                    (setr RELOUT *)))
     (3 (pop t 
         (if (eq (getr RELOUT) 'no-rel)
           (build  SN-DET SN-ESOGG (build SN-PRED SN-ESOGG))
            (build  SN-DET SN-ESOGG RELOUT))))
           
     (4 (pop t (list 'constant (getr SN-ESOGG)))))
   (REL
     (regs FLN FLSV EN)
     (0 (cat RELP 1)
        (pop t 'no-rel))
     (1 (push SV 2 t (sendr SV-ESOGG (getr EN)) (setr FLSV *)))
     (2 (pop t (build '& FLN  FLSV))))
          
   (SV
      (regs SV-ESOGG EOGG SV-PRED SN-OUT1 NEGATIVE COP)
      (init (progn (setr EOGG (newvar))))
      (5 (word "does" 6)
         (jump 0))
      (6 (word "not" 0 (setr NEGATIVE t)))
      (0 (cat Vt 1 t (setr SV-PRED (getftr PRED)))
	 (cat Vi 3 t (setr SV-PRED (getftr PRED)))
         (cat Cop 7 ))
      (7 (push SN 2 t (sendr  SN-ESOGG (getr SV-ESOGG))
                       (progn (setr SN-OUT1 *)(setr COP t))))
                               
      (1 (push SN 2 t (sendr  SN-ESOGG (getr EOGG))
		      (progn (setr SN-OUT1 *)
                         (cond((eq 'constant (car (getr SN-OUT1)))
                                (setr EOGG (cadr (getr SN-OUT1))))))))
                             
      (2 (pop t
           (if (getr COP)
               (caddr (getr SN-OUT1))
           (if (getr NEGATIVE) 
           (build '~ 
            (if (eq 'constant (car (getr SN-OUT1)))
              (build SV-PRED SV-ESOGG EOGG)
              (append  (getr SN-OUT1) 
                         (list (build SV-PRED SV-ESOGG EOGG)))))
	(if (eq 'constant (car (getr SN-OUT1)))
              (build SV-PRED SV-ESOGG EOGG)
              (append  (getr SN-OUT1) 
                         (list (build SV-PRED SV-ESOGG EOGG))))))))
	
       (3 (pop t (if (getr NEGATIVE)
             (build '~ (build SV-PRED SV-ESOGG ))
            (build SV-PRED SV-ESOGG )))))))



(setq   *varn* 0)
(defun newvar()
   (string-downcase (read-from-string (format nil "x~D" (incf *varn*)))))

(setq universal '( "every" "chi" "tutte" "tutti" "ogni"))
(setq existential '( "a" "any" "this" "the"  "some" "uno" "una" "un" "il" ))

(defun 3bq2fmla (tb)
  (cond ((leaf tb) tb)
	((is-univ (nth 0 tb))
	 (list "all" (nth 1 tb) 
		    (list  '=>
		     (3bq2fmla (nth 2 tb))
		     (3bq2fmla (nth 3 tb)))))
	((is-exist (nth 0 tb))
	(list "exists" (nth 1 tb)
		     (list  '&
		     (3bq2fmla (nth 2 tb))
		     (3bq2fmla (nth 3 tb)))))
	(t (cons (root tb)(mapcar  '3bq2fmla (cdr tb))))))
	
(defun postp (fmla)
 (let* ((string 	 (post fmla))
        (thname (add-path "AtnOut.th" 
               (add-subdir *pail-path* "atp/examples")))
        (out-stream (open thname :direction :output
                       :if-exists :append
                       :if-does-not-exist :create)))
   (princ string out-stream)
   (princ ".

" out-stream)
   
   (close out-stream)
   string))
(defun post (fmla)		 
 (cond ((atom fmla) (format nil"~A" fmla))
       ((member  (car fmla) '(& => or))
	(format nil "(~A ~A ~A)" (post (nth 1 fmla)) (car fmla)(post( nth 2 fmla))))
       ((member (car fmla) '("all" "exists") :test #'string=)
	(format nil "~A ~A ~A"(car fmla)  (format nil"~A " (nth 1 fmla))
		                  (post (nth 2 fmla))))
       ((eq (car fmla) '~) 
          (format nil "~A ~A"(car fmla)  (post (nth 1 fmla))))
       (t (term-to-string fmla))))

(defun is-univ (x) (member x universal :test 'string=))
(defun is-exist (x) (member x existential :test 'string=))

(defun leaf (x) (atom x))
(defun root (x) (car x))

(defun term-to-string (tm)
  (cond ((atom tm)(format nil "~A"  tm))
        (t (concatenate 'string
	      (format nil "~A" (car tm)) 
	     "("
	     (tmx-l-to-string (cdr tm))
	     ")"))))
(defun tmx-l-to-string (tl)
  (cond ((null (cdr tl))  (term-to-string (car tl)))
	(t    (concatenate 'string 
		(term-to-string (car tl))
		","
		(tmx-l-to-string  (cdr tl))))))


(let* ((thname (add-path "AtnOut.th" 
               (add-subdir *pail-path* "atp/examples")))
        (out-stream (open thname :direction :output
                       :if-exists  :supersede
                       :if-does-not-exist :create)))
  (format out-stream
     ";;;=============================================================
;;; ATN-ATP interaction
;;; A Theorem generated with the Natural Language Module
;;;=============================================================

list(axioms).
")
 (close out-stream))
