#lang scheme

;;; EL REGRESSUS DE LEIBNIZ COMO MÉTODO DE DECISIÓN
;;; 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))

(define es-falso #\¬)

(define categorica?
  (lambda (string)
    (if (= (string-length string) 3)
        (let ((id (string-ref string 0))
              (sujeto (string-ref string 1))
              (predicado (string-ref string 2)))
          (if
           (and
            (member id ids)
            (member sujeto conceptos)
            (member predicado conceptos))
           string
           (error "No es un esquema categórico") ))
        (error "No es un esquema categórico") ) ))

;;; LEYES DEL SILOGISMO
(define barbara '())
(define celarent '())
(define darii '())
(define ferio '())

(define-syntax barbara!
  (syntax-rules ()
    ((barbara! m p s)
     (list
      (string #\a m p)
      (string #\a s m)
      (string #\a s p))) ))

(define-syntax celarent!
  (syntax-rules ()
    ((barbara! m p s)
     (list
      (string #\e m p)
      (string #\a s m)
      (string #\e s p))) ))

(define-syntax darii!
  (syntax-rules ()
    ((barbara! m p s)
     (list
      (string #\a m p)
      (string #\i s m)
      (string #\i s p))) ))

(define-syntax ferio!
  (syntax-rules ()
    ((barbara! m p s)
     (list
      (string #\e m p)
      (string #\i s m)
      (string #\o s p))) ))

(define leyes!
  (lambda (m p s)
    (set! barbara (barbara! m p s))
    (set! celarent (celarent! m p s))
    (set! darii (darii! m p s))
    (set! ferio (ferio! m p s)) ))

;;; REGLAS DERIVADAS
(define falso-que
  (lambda (s)
    (string-append
     (string es-falso #\()
     s
     (string #\)) ) ))

(define contradictoria-de
  (lambda (s)
    (let ((neg? (char=? #\¬ (string-ref s 0))) )
      (if neg?
          (let ((expr (substring s 2 (sub1 (string-length s)))) )
            (case (string-ref expr 0)
              ((#\a) (string-append
                      (string #\o)
                      (substring expr 1 (string-length expr))) )
              ((#\e) (string-append
                      (string #\i)
                      (substring expr 1 (string-length expr))) )
              ((#\i) (string-append
                      (string #\e)
                      (substring expr 1 (string-length expr))) )
              ((#\o) (string-append
                      (string #\a)
                      (substring expr 1 (string-length expr))) ) ))
          (let ((expr s) )
            (case (string-ref expr 0)
              ((#\a) (falso-que
                      (string-append
                       (string #\o)
                       (substring expr 1 (string-length expr)))) )
              ((#\e) (falso-que
                      (string-append
                       (string #\i)
                       (substring expr 1 (string-length expr)))) )
              ((#\i) (falso-que
                      (string-append
                       (string #\e)
                       (substring expr 1 (string-length expr)))) )
              ((#\o) (falso-que
                      (string-append
                       (string #\a)
                       (substring expr 1 (string-length expr)))) ) ))
          ) ) ))

;;;;; EL CALCULO
(define subalternacion-r
  (lambda (s)
    (let ((i? (char=? #\i (string-ref s 0)))
          (o? (char=? #\o (string-ref s 0))) )
      (if i?
          (string-append
           (string #\a)
           (substring s 1 (string-length s)))
          (if o?
              (string-append
               (string #\e)
               (substring s 1 (string-length s)))
              #f)) ) ))

(define de-la-figura
  (lambda (lista)
    (let* ((p1 (car lista))
           (sp1 (string-ref p1 1))
           (pp1 (string-ref p1 2))
           (p2 (cadr lista))
           (sp2 (string-ref p2 1))
           (pp2 (string-ref p2 2))
           (c (caddr lista)) )
      (if (char=? sp1 pp2)
          (begin
            (leyes! sp1 pp1 sp2)
            1)
          (if (char=? pp1 pp2)
              (begin
                (leyes! sp1 pp1 sp2)
                2)
              (if (char=? sp1 sp2)
                  (begin
                    (leyes! pp2 pp1 sp2)
                    3)
                  #f)))
      )))

(define calculo
  (lambda (p1 p2 c)
    (let* ((problema (list p1 p2 c))
           (problema-figura (de-la-figura problema)) 
           (origen1 #f)
           (origen2 #f)
           (origen3 #f)
           (lst-origen #f)
           )
      (case problema-figura
        ((1) (newline)
             (display "El modo problema es de la 1ra")
             (display-modo problema)
             (regressus problema-figura p1 p2 c 
                        p1 p2 c) )
        ((2) (newline)
             (display "El modo problema es de la 2da")
             (display-modo problema)
             (regressus problema-figura p1 p2 c 
                        p1 
                        (contradictoria-de (falso-que c)) 
                        (contradictoria-de (falso-que p2))) )
        ((3) (newline)
             (display "El modo problema es de la 3ra") 
             (display-modo problema)
             (regressus problema-figura p1 p2 c 
                        (contradictoria-de (falso-que c)) 
                        p2 
                        (contradictoria-de (falso-que p1))
                        ) )
        (else #f) )
      ) ))

(define regressus
  (lambda (fig p1 p2 c o1 o2 o3)
    (call/cc
     (lambda (exit)
       (let* ((origen1 o1)
              (origen2 o2)
              (origen3 o3)
              (origen3r (subalternacion-r o3))
              (origen '())
              )
         (for-each
          (lambda (x)
            (when (equal? x (list origen1 origen2 origen3))
              (display-modo 
               (produccion (if (= fig 1) 0 fig) p1 p2 c origen1 origen2 origen3))
              (exit (display "Modo válido")))
            (when (equal? x (list origen1 origen2 origen3r))
              (display-modo 
               (produccion (* fig -1) p1 p2 c origen1 origen2 origen3 origen3r))
              (exit (display "Modo válido")))
            )
          (list barbara celarent darii ferio))
         (exit (display "Modo no válido")) ) )) ))

(define produccion
  (lambda (f p1 p2 c o1 o2 o3 . o3r)
    (case f
      ((0) (list "Es una ley silogística"))
      ((-1) (set! o3 (subalternacion-r c))
           (list
            (list o1 "=" p1)
            (list o2 "=" p2)
            (list o3 "<-regressus--" o3 "<-subalternacion--" c))
           )
      ((2) (list
            (list o1 "<-regressus--" p1)
            (list o2 "<-regressus--" 
                  (contradictoria-de (falso-que c))
                  "<-contradictoria--"
                  (falso-que c)
                  "<-es-falso--"
                  c)
            (list o3 "<-regressus--" 
                  (contradictoria-de (falso-que p2))
                  "<-contradictoria--"
                  (falso-que p2)
                  "<-es-falso--"
                  p2) ))
      ((3) (list
            (list o1 "<-regressus--" 
                  (contradictoria-de (falso-que c))
                  "<-contradictoria--"
                  (falso-que c)
                  "<-es-falso--"
                  c)
                  
            (list o2 "<-regressus--" p2)
            (list o3 "<-regressus--" 
                  (contradictoria-de (falso-que p1))
                  "<-contradictoria--"
                  (falso-que p1)
                  "<-es-falso--"
                  p1)
                  )
           )
      ((-2) (list
            (list o1 "<-regressus--" p1)
            (list o2 "<-regressus--" 
                  (contradictoria-de (falso-que c))
                  "<-contradictoria--"
                  (falso-que c)
                  "<-es-falso--"
                  c)
            (list (car o3r) "<-regressus--"
                  (car o3r) "<-subalternacion--" 
                  (contradictoria-de (falso-que p2))
                  "<-contradictoria--"
                  (falso-que p2)
                  "<-es-falso--"
                  p2) )
            )
      ((-3) (list
             (list o1 "<-regressus--"
                   (contradictoria-de (falso-que c))
                   "<-contradictoria--"
                   (falso-que c)
                   "<-es-falso--"
                   c)
             (list o2 "<-regressus--" p2)
             (list (car o3r) "<-regressus--" 
                   (car o3r) "<-subalternacion--"
                   (contradictoria-de (falso-que p1))
                   "<-contradictoria--"
                   (falso-que p1)
                   "<-es-falso--"
                   p1)
             ))
      (else #f) ))) 
                     
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define display-modo
  (lambda (lista)
    (newline)
    (cond
      ((null? lista) )
      (else
       (display (car lista)) 
       (display-modo (cdr lista)) )) ))

(define mensaje
  (lambda ()
    (printf "Regressus es un cálculo propuesto por Leibniz para la Silogística de 3 figuras.~n")
    (printf "Es un cálculo claramente algorítmico: a partir de modos legítimos de la 1ra.~nse producen modos legítimos de la 2da. y de la 3ra. por aplicación de reglas.~n")
    (printf "Por ello, es posible plantearlo como un método de decisión:~npartir de un modo problema, aplicarle reglas de transformación y obtener la ley lógica~nde la que se ha producido, si es un modo legítimo. Si no es el caso, el modo es ilegítimo.~n")
    (printf "Modos legítimos de la Primera figura: ~a~n" '(barbara celarent darii ferio sub1-AAI sub2-EAO))
    (printf "Modos legítimos de la Segunda figura: ~a~n" '(cesare camestre festino baroco octavo-2ª-AEO vigesimo-2ª-EAO))
    (printf "Modos legítimos de la Tercera figura: ~a~n" '(darapti disamis datisi bocardo ferison felapton))
    (printf "~nCada enunciado categórico, por ejemplo: todos los mamíferos son animales, se ha de escribir así:~naMA, donde: a = universal afirmativo, M = mamífero, A = animal.~nEn lugar de ~aa~a, se escribirá e = universal negativa, i = particular afirmativa,~no = particular negativa.~n" #\' #\')
    ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(mensaje)
(let go((premisa1 #f)
        (premisa2 #f)
        (conclusion #f) )
  (newline) (newline)
  (display "(Pulsa enter para acabar)")
  (newline) (newline)
  (display "Escribe la primera premisa ")
  (set! premisa1 (read-line))
  (if (not (string=? premisa1 ""))
      (begin
        (set! premisa1 (categorica? premisa1))
        (display "Escribe la segunda premisa ")
        (set! premisa2 (categorica? (read-line)))
        (display "Escribe la conclusión ")
        (set! conclusion (categorica? (read-line)))
        (calculo premisa1 premisa2 conclusion)
        (go #f #f #f))
      #f
      )
  )

