#lang scheme

(require "Silogista-modos-posibles.rkt")
(require "Silogistica-interfaz.rkt")

;;; SILOGÍSTICA
;;; Notación
(define conceptos '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z))

(define ids '(#\a #\e #\i #\o))

;;Gramática de expresiones mediante Predicados de tipo
;;Un enunciado categórico ha de escribirse así: identificador_subtipo Sujeto Predicado
;;Extractores
(define suj
  (lambda (expr)
    (if (> (string-length expr) 3)
        (string-ref expr 3)
        (string-ref expr 1)) ))
(define pred
  (lambda (expr)
    (if (> (string-length expr) 3)
        (string-ref expr 4)
        (string-ref expr 2)) ))
;;Predicado del tipo proposición categórica
(define categorica?
  (lambda (string)
    (if (= (string-length string) 3)
        (let ((id (string-ref string 0))
              (sujeto (suj string))
              (predicado (pred string))
              )
          (if
           (and
            (member id ids)
            (member sujeto conceptos)
            (member predicado conceptos))
           #t
           #f)
          )
        #f)
    ))
;;Subtipos según cantidad y cualidad
(define universal?
  (lambda (string)
    (let ((id (string-ref string 0)) )
      (or (char=? id #\a) (char=? id #\e))
      ) ))
(define particular?
  (lambda (string)
    (let ((id (string-ref string 0)) )
      (or (char=? id #\i) (char=? id #\o))
      ) ))
(define afirmativa?
  (lambda (string)
    (let ((id (string-ref string 0)) )
      (or (char=? id #\a) (char=? id #\i))
      ) ))
(define negativa?
  (lambda (string)
    (let ((id (string-ref string 0)) )
      (or (char=? id #\e) (char=? id #\o))
      ) ))
;;Heurística escolástica
;;Premisas negativas
(define premisas-negativas?
  (lambda (lst)
    (let ((una (first lst))
          (dos (second lst))
          (tres (third lst))
          )
      (and (negativa? una) (negativa? dos))
      )
    ))
;;Premisas particulares
(define premisas-particulares?
  (lambda (lst)
    (let ((una (first lst))
          (dos (second lst))
          (tres (third lst))
          )
      (and (particular? una) (particular? dos))
      )
    ))
;; La conclusión sigue la peor parte
(define una-premisa-negativa-y-conclusion-afirmativa?
  (lambda (lst)
    (let ((una (first lst))
          (dos (second lst))
          (tres (third lst))
          )
      (if (or (negativa? una) (negativa? dos))
          (if (afirmativa? tres)
           #t;ilegal
           #f)
          #f);no es el caso 
      )
    ))
(define una-premisa-particular-y-conclusion-universal?
  (lambda (lst)
    (let ((una (first lst))
          (dos (second lst))
          (tres (third lst))
          )
      (if (or (particular? una) (particular? dos))
          (if (universal? tres) 
              #t;ilegal
              #f)
          #f);no es el caso
      )
    ))
;;Dos premisas afirmativas y conclusión negativa
(define dos-premisas-afirmativas-y-conclusion-negativa?
  (lambda (lst)
    (let ((una (first lst))
          (dos (second lst))
          (tres (third lst))
          )
    (if (and (afirmativa? una) (afirmativa? dos))
        (if (negativa? tres)
            #t;ilegal
            #f)
        #f);no es el caso 
      )
    ))
;; Extensión de términos
(define extension-terminos
  (lambda (enunciado)
    (case (string-ref enunciado 0)
      ((#\a) (values (string (string-ref enunciado 1) #\u)
                     (string (string-ref enunciado 2) #\i))
             )
      ((#\e) (values (string (string-ref enunciado 1) #\u)
                     (string (string-ref enunciado 2) #\u))
             )
      ((#\i) (values (string (string-ref enunciado 1) #\i)
                     (string (string-ref enunciado 2) #\i))
             )
      ((#\o) (values (string (string-ref enunciado 1) #\i)
                     (string (string-ref enunciado 2) #\u))
             )
      (else 'falla)
      ) ))
(define extension-terminos-modo
  (lambda (modo)
    (let-values ([(prem1-s prem1-p) 
                  (extension-terminos (first modo))]
                 [(prem2-s prem2-p) 
                  (extension-terminos (second modo))]
                 [(concl-s concl-p) 
                  (extension-terminos (third modo))])
      (values prem1-s prem1-p prem2-s prem2-p concl-s concl-p)
      )
    ))
(define reconstruye-modo-segun-extension-terminos
  (lambda (modo)
    (let-values ([(prem1) (first modo)]
                 [(prem2) (second modo)]
                 [(concl) (third modo)]
                 [(prem1-s prem1-p prem2-s prem2-p concl-s concl-p)
                  (extension-terminos-modo modo)]
                 )
      (list
       (string-append 
        prem1-s prem1-p)
       (string-append 
        prem2-s prem2-p)
       (string-append 
        concl-s concl-p))
      )
    ))
;;Extensión del término medio
(define extension-termino-medio
  (lambda (modo)
    (let* ((modus
            (reconstruye-modo-segun-extension-terminos modo))
           (prem1 (first modus))
           (prem2 (second modus))
           (concl (third modus))
           )
    (if (char=? (string-ref prem1 0) #\M)
        (not 
         (match-medio (substring prem1 0 2) prem2))
        (not 
         (match-medio 
          (substring prem1 2 (string-length prem1)) prem2))
        )
      )
    ))
(define match-medio
  (lambda (e1 e2)
    (if (= (string-length e2) 0)
        'fallo
        (if (char=? (string-ref e1 0) (string-ref e2 0))
            (case (string-ref e1 1)
              ((#\i) (char=? (string-ref e2 1) #\u))
              ((#\u)'fallo)
              )
            (match-medio 
             e1 (substring e2 2 (string-length e2)))
            )
        )
    ))
;;Extensión términos de la conclusión
(define matcher-e2
  (lambda (e1 e2)
    (if (= (string-length e2) 0)
        'fallo
        (if (char=? (string-ref e1 0) (string-ref e2 0))
            (case (string-ref e1 1)
              ((#\i) 'fallo)
              ((#\u)
               (char=? (string-ref e1 1) (string-ref e2 1)))
              )
            (matcher-e2 e1 (substring e2 2 (string-length e2)))
            )
        )
    ))
(define matcher
  (lambda (e1 e2)
    (let ((suj_c (matcher-e2 (substring e1 0 2) e2))
          (pred_c (matcher-e2 (substring e1 2 4) e2))
          )
      (values suj_c pred_c)
      )
    ))
(define extension-terminos-conclusion
  (lambda (modo)
    (let* ((modus
            (reconstruye-modo-segun-extension-terminos modo))
           (prem1 (first modus))
           (prem2 (second modus))
           (concl (third modus))
           )
      (let-values ([(uno dos) (matcher concl prem2)]
                   [(tres cuatro) (matcher concl prem1)]
                   )
        (if (and  uno dos tres cuatro)
            #f
            #t);ilegal
        )
      )
    ))
;;;
(define heuristica-escolastica
  (lambda (modus . id)
    (let* ((una (first modus))
          (dos (second modus))
          (tres (third modus))
          (criterios
           (lambda (modo)
             (cond
               ((dos-premisas-afirmativas-y-conclusion-negativa? modo)
                (list 
                 #f 
                 "Modo inválido porque ~a y ~a son afirmativas y ~a negativa.~n"
                 una dos tres)
                )
               ((premisas-negativas? modo)
                (list 
                 #f 
                 "Modo inválido porque ~a y ~a son negativas.~n" 
                 una dos)
                )
               ((premisas-particulares? modo)
                (list 
                 #f 
                 "Modo inválido porque ~a y ~a son particulares.~n" 
                 una dos)
                )
               ((una-premisa-negativa-y-conclusion-afirmativa? modo)
                (list 
                 #f 
                 "Modo inválido porque ~a es negativa y ~a afirmativa.~n"
                 (if (negativa? una) una dos) tres)
                )
               ((una-premisa-particular-y-conclusion-universal? modo)
                (list 
                 #f 
                 "Modo inválido porque ~a es particular y ~a universal.~n"
                 (if (particular? una) una dos) tres)
                )
               ((extension-termino-medio modo)
                (list
                 #f
                 "Modo inválido porque la extensión de M no es universal en ~a ni en ~a~n"
                 una dos)
                )
               ((extension-terminos-conclusion modo)
                (list
                 #f
                 "Modo inválido porque en ~a algún término tiene más extensión que en las premisas ~a ~a~n"
                 tres una dos)
                )
               (else 
                (list #t "Modo válido~n~n") ); ~a ~a ~a ~n" una dos tres))
               )
             ))
          )
      (let* ((una (first modus))
             (dos (second modus))
             (tres (third modus))
             (r (criterios modus))
             (booleano (first r))
             (mensa (rest r))
             )
        (if booleano
            r
            r)
        )
      ) ))

;;Para comprobar todos los modos posibles de una figura
(define comprobar-modos-posibles-figura
  (lambda (figura figura-id)
    (letrec ((aux
              (lambda (lista a)
                (if (null? lista)
                    (printf "Hecho. Modos legítimos: ~a" a)
                    (let* ((una (first (car lista)))
                           (dos (second (car lista)))
                           (tres (third (car lista)))
                           (valor (heuristica-escolastica (car lista)))
                           (booleano (first valor))
                           (mensa (rest valor))
                           (legal
                            (matching 
                             (car lista) 
                             (para-figura figura) 
                             figura-id))
                           )
                      (if booleano
                          (begin
                            (printf "~n~a:: ~a~n" (add1 a) legal)
                            (apply printf mensa)
                            ;(read-line)
                            (aux (rest lista) (add1 a))
                            )
                          (begin
                            (printf "~n---::  ~a~n" legal)
                            (apply printf mensa)
                            ;(read-line)
                            (aux (rest lista) a)
                            )
                          )
                      )
                    )
                ))
             )
      (printf "~n~nExamen de los modos posibles de la figura ~a ~n" figura)
      (aux (modos-posibles-figura (genera '(a e i o)) figura) 0)
      ) ))
;;
(define para-figura
  (lambda (fig)
    (case fig
      ((1) primera)
      ((2) segunda)
      ((3) tercera)
      ((4) cuarta)
      (else 'no-hay)) ))
(define matching
  (lambda (modo legitimos ids)
    (if (null?  legitimos)
        modo
        (if (match modo (first legitimos))
            (cons modo (first ids))
            (matching modo (rest legitimos) (rest ids)))
        ) ))
(define match
  (lambda (p1 p2)
    (if (null? p1)
        #t
        (if (string=? (car p1) (car p2))
            (match (cdr p1) (cdr p2))
            #f))
    ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 1ª Figura, modos válidos
(define barbara '("aMP" "aSM" "aSP"))
(define celarent '("eMP" "aSM" "eSP"))
(define darii '("aMP" "iSM" "iSP"))
(define ferio '("eMP" "iSM" "oSP"))
(define sub1-AAI '("aMP" "aSM" "iSP"))
(define sub2-EAO '("eMP" "aSM" "oSP"))
; 2ª Figura, modos válidos
(define cesare '("ePM" "aSM" "eSP"))
(define camestre '("aPM" "eSM" "eSP"))
(define festino '("ePM" "iSM" "oSP"))
(define baroco '("aPM" "oSM" "oSP"))
(define subalterna-AEO '("aPM" "eSM" "oSP"))
(define subalterna-EAO '("ePM" "aSM" "oSP"))
;; 3ª Figura, modos válidos
(define darapti '("aMP" "aMS" "iSP"))
(define disamis '("iMP" "aMS" "iSP"))
(define datisi '("aMP" "iMS" "iSP"))
(define bocardo '("oMP" "aMS" "oSP"))
(define ferison '("eMP" "iMS" "oSP"))
(define felapton '("eMP" "aMS" "oSP"))
;; 4ª Figura, galénica, modos válidos
(define bramantip '("aPM" "aMS" "iSP"))
(define camenes '("aPM" "eMS" "eSP"))
(define dimaris '("iPM" "aMS" "iSP"))
(define fesapo '("ePM" "aMS" "oSP"))
(define fresison '("ePM" "iMS" "oSP"));
(define subalterna-4-AEO '("aPM" "eMS" "oSP"))
(define subalterna-4-AEI bramantip)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define primera (list barbara celarent darii ferio sub1-AAI sub2-EAO))
(define primera-id '(barbara celarent darii ferio sub1-AAI sub2-EAO))
(define segunda (list cesare subalterna-EAO camestre subalterna-AEO festino baroco))
(define segunda-id '(cesare subalterna-EAO camestre subalterna-AEO festino baroco))
(define tercera (list darapti datisi felapton ferison disamis bocardo))
(define tercera-id '(darapti datisi felapton ferison disamis bocardo))
(define cuarta (list bramantip camenes dimaris fesapo fresison subalterna-4-AEO))
(define cuarta-id '(subalterna-4-AEI camenes dimaris fesapo fresison subalterna-4-AEO))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Interfaz
(define interfaz
  (lambda ()
    (printf "Es posible analizar los 64 modos posibles de una figura (1)~n")
    (printf "Es posible analizar un modo legítima de una de las cuatro figuras (2)~n")
    (printf "Es posible analizar un modo posibles introducido en español (3)~n")
    (let go ((i (read)))
      (cond
        ((= i 1)
         (printf "Número de la figura? ")
         (let go ((j (read)))
           (cond
             ((= j 1) (comprobar-modos-posibles-figura 1 primera-id))
             ((= j 2) (comprobar-modos-posibles-figura 2 segunda-id))
             ((= j 3) (comprobar-modos-posibles-figura 3 tercera-id))
             ((= j 4) (comprobar-modos-posibles-figura 4 cuarta-id))
             (else (go (read)))
             )))
        ((= i 2)
         (printf "Nombre del modo? ")
         (let go ((id (read)))
           (let ((ids (eval id)))
           (if
            (or
             (member ids primera)
             (member ids segunda)
             (member ids tercera)
             (member ids cuarta))
            (let ((r
                   (heuristica-escolastica ids id)))
              (apply printf (rest r)))
            (go (read))
            ))))
        ((= i 3)
         (printf "Escribe las premisas y la conclusión ~n")
         (read-char)
         (ensayo-modo))
        (else (go (read)))
        ))
    ))
          
(define ensayo-modo
  (lambda ()
    (let ((u-a "todo animal es mortal")
          (u-n "ningún animal es inmortal")
          (p-a "algún hombre es mortal")
          (p-n "algún hombre no es inmortal")
          )
    (printf "Las universales afirmativas se escriben así: ~a~n" u-a)
    (printf "Las universales negativas se escriben así: ~a~n" u-n)
    (printf "Las particulares afirmativas se escriben así: ~a~n" p-a)
    (printf "Las particulares negativas se escriben así: ~a~n" p-n)
      (let go ((i 0)
               (j 3)
               (modo '())
               )
        (if (= i j)
            (let ((r
                   (heuristica-escolastica modo 'ensayo)))
              (apply printf (rest r)))
            (go (add1 i) j (append modo (list (reconstruye-input))))
            )
        )
      )
    )
  )
;(interfaz)