#lang scheme

(require "BaseDatos-Lpo.rkt")
(require "Eval-conj-Lpo.rkt")
(require "Gramatica-Lpo.rkt")
(require "Interfaz-Lpo.rkt")
(require "Pattern-matching-Lpo.rkt")
(require "Renombrar-variables.rkt")

;;OPERACIONES LÓGICAS
(define neg ;;SEGÚN LA LÓGICA
  (lambda (form)
    (cond
      ((equal? form '(fallo)) '(()))
      (else '(fallo)) ) ))
;;;
(define disy
  (lambda (form1 form2)
    (cond
      ((equal? form1 '(fallo)) form2)
      ((equal? form2 '(fallo)) form1)
      ((equal? form1 (list empty)) form1)
      ((equal? form2 (list empty)) form2)
      (else (append form1 form2))
      ) ))
;;Transformación de una disyunción
(define disy->serie
  (lambda (disyun)
    (let
        ((all
          (map 
           (lambda (form) 
             (instanciar form (qeval form))) 
           (rest disyun)))
         )
      (mezclas (first all) (second all))
      )
    ))
(define mezclas
  (lambda (s1 s2)
    (if (null? s1)
        '()
        (append
         (mezcla-uno-todos (first s1) s2)
         (mezclas (rest s1) s2))
        ) ))
(define mezcla-uno-todos
  (lambda (uno s2)
    (if (null? s2)
        '()
        (cons
         (mezcla-dos uno (first s2))
         (mezcla-uno-todos uno (rest s2)))
        )))
(define mezcla-dos
  (lambda (s1 s2)
    (list 'o s1 s2) ))
;;EVALUAR UNA ATOMICA
(define evaluar-atomica
  (lambda (sexpr subtabla cuadro-sust)
    (cond
      ((null? subtabla) cuadro-sust)
      (else
       (evaluar-atomica 
        sexpr 
        (rest subtabla) 
        (cons 
         (pattern-matching sexpr (first subtabla)) 
         cuadro-sust)))
      ) ))
;;FILTRO DE RESPUESTAS
(define sustitucion?
  (lambda (lista)
    (if (null? lista)
        #t
        (if (pair? (first lista))
            (and #t
                 (sustitucion? (rest lista)))
            #f)) ))
(define filtro-respuestas
  (lambda (lista)
    (letrec 
        ((hay-verdadero (member empty lista))
         (hay-sust (ormap sustitucion? lista));list?
         (proc (if hay-sust 
                   sustitucion?;list? 
                   (when hay-verdadero 
                       empty?)))
         (aux
          (lambda (lst)
            (cond
              ((null? lst) '())
              ((proc (first lst))
               (cons (first lst)
                     (aux (rest lst))) )
              (else (aux (rest lst)))
              ) ))
         )
      (if (or hay-verdadero hay-sust)
          (aux lista)
          (list 'fallo))
     ) ))
;;;EVALUAR SIMPLE O COMPUESTA
(define evaluar-compuesta
  (lambda (s-expr)
    ;(printf "(2) Evaluar compuest~n")
    (let ((proc (if (eq? (first s-expr) 'y) conj disy)) )
      (proc
       (qeval (second s-expr))
       (qeval (third s-expr)))
      ) ))
(define evaluar-simple
  (lambda (expr hechos reglas cuadro-sust)
    (set! cuadro-sust
          (cond
            ((null? hechos)
             (cond
               ((null? reglas) '(fallo))
               (else
                (qeval
                 (aplica-regla expr (first reglas))) )
               ))
            (else
             (filtro-respuestas
              (evaluar-atomica expr hechos cuadro-sust)) )
            ) )
    cuadro-sust
    ))
(define eval-simple
  (lambda (expr datos rules cuadro-sust)
    ;(printf "(1)Expr= ~a Hay datos= ~a Reglas= ~a Marco-sust= ~a~n" expr (not(null? datos)) rules cuadro-sust)
    (let ((hechos datos)
          (reglas rules)
          (marco-sust cuadro-sust)
          )
      (set! marco-sust
      (cond
        ((null? hechos)
         (printf "Predicado inexistente en BD. Se comprueba si hay regla.~n")
         (cond
           ((null? reglas)
            ;(printf "Tampoco hay una regla~n")
            '(fallo))
           (else
            (printf "Hay una regla~a~n" reglas)
            (qeval
             (aplica-regla expr (first reglas))) )
           ))
        (else
         (filtro-respuestas
          (evaluar-atomica expr hechos marco-sust)) )
        ) )
      marco-sust)
    ))
;;;EVALUAR-SEGUN-TIPO-DE-SEXPR      
(define qeval
  (lambda (s-expr)
    (let ((marco-sust '()) 
          )
      (cond
        ((neg? s-expr) (neg (qeval (second s-expr))))
        ((bin? s-expr)
         (evaluar-compuesta s-expr))
        ((expr-atomica? s-expr 'func-prop)
         (let-values ([(hechos reglas) (subtabla-o-regla s-expr)] 
                      )
           (evaluar-simple s-expr hechos reglas marco-sust) ) )
        (else "S-EXPR de tipo desconocido")
        )
      )
     ))
;;;;;;;;;;;;;;;;
(define driver
  (lambda ()
    (mensaje1)
    (let-values ([(ebd ibd) (predicados-en-bd BD)] )
      (printf "Predicados en los hechos declarados: ~a~n" ebd)
      (printf "Predicados definidos (reglas): ~a~n~n" ibd)
      (printf "Interrogación:: ")
      (let go ((formula (lectura-una-expresion))
               )
        (if (eq? formula 'fin)
            'adios
            (begin
              (print-respuesta
               (instanciar
                formula
                (qeval formula)))
              (printf "Interrogación:: ")
              (go (lectura-una-expresion)) )
            )
        )
      ) ))
(driver)

;(asienta-en-bd '(regla (hijo-de X Y) (o (padre Y X) (madre Y X))))