;**** Funtion zum Auswerten boolscher Ausdrücke und Uebersetzung in's Disjunktive
;**** System wobei die Ausdrücke gekürzt werden. (hier in Lisp max 6 oder 7 Variablen)
;*************************************************************************************************
;**** Die Funktion :  ( BOOL '( liste ) )
;**** Die Liste kann mit Variablen gefuellt werden oder mit den Werten 1 und 0
;**** Operatoren sind (not !), (and &), (or +), (xor $), (implikation >), (aeqivalenz =)
;**** Die OperatorenSymbole koennen im Quelltext geaendert werden siehe in der Zeile
;**** 32 (setq not_s '!) ..... , weiterhin sind die Werte 0 und 1 als logische
;**** Werte verarbeitbar, dh. das Ergebnis von (bool '(1 + 0)) ist (1)
;**** Klammern werden vom Programm natürlich auch bearbeitet Bsp. ( bool '(1 + (a & 1)) )
;**** alles was keine 1, 0 oder ein Operator ist, ist eine Variable. AND - Ausdruecke
;**** muessen nicht geschrieben werden, dh. (bool '(a b)) ist gleich (bool '(a & b))
;**** Der Quelltext muss am Anfang komlett durchlaufen werden. Dann kann man im
;**** Interpreter die Funktion "bool" einfach so aufrufen
;************************************************************************************************
;*************************** G L O B A L E   V A R I A B L E N **********************************
;************************************************************************************************
(setq *print-length* 0)       ;Globale Variable für AusgabeLänge unbegrenzt
(setq *print-level*  0)        ;Globale Variable für AusgabeTiefe unbegernzt
(setq fehler 0)                 ;Globale Variable für gemachte Fehler
(setq bol '())                  ;**** Normalisierter BoolscherAusdruck
(setq id_wer '0)                ;**** KombinationsVector
(setq id_nam '())               ;**** Namen und Werte der Variablen im BoolAusdruck
(setq id_pos '0)                ;**** Pos&Anzahl der Variablen im NamenListe
(setq w_anz  '0)                ;**** Anzahl der möglichen Werte einer DNV
(setq w      '0)                ;**** Der MatrixSpeicher für alle Kombinationen und deren Wert
(setq zeichen 0)                ;**** das aktuelle Zeichen wird hier gespeichert
(setq stack '())                ;**** Der PostFixStack
(setq stac1 '())                ;**** Der HilfeStack

(setq not_s '!) (setq and_s '&) (setq or_s  '+)   ;**** Symbole für die Operatoren
(setq xor_s '$) (setq imp_s '>) (setq equ_s '=)   ;**** Symbole für die Operatoren
;************************************************************************************************
;************************************ Ausgabe des Fehlers ***************************************
;************************************************************************************************
(defun Fehl()
  (cond ;****** ((= fehler 0) (pprint "<OK>"))
        ((= fehler 1) (pprint "Stack Überschritten"))
        ((= fehler 2) (pprint "Stack Unterschritten"))
        ((= fehler 3) (pprint "Zu viele Identifers"))
        ((= fehler 4) (pprint "Identifer nicht gefunden"))
        ((= fehler 5) (pprint "KlammerSetzungsFehler"))
        ((= fehler 6) (pprint "ReihenfolgeFehler zwischen Variablen und Operatoren"))
        ((= fehler 7) (pprint "Fehler im Stringausdruck"))
        ((= fehler 8) (pprint "Strings zu lang"))))
;************************************************************************************************
;*********************************** I D T O O L S **********************************************
;************************************************************************************************
;************************** Zählen und Registrieren der Identifers ******************************
;************************************************************************************************
(defun id_count(ein)
 (dolist (el ein)
  (cond ((and (atom el) (neq el not_s) (neq el and_s) (neq el or_s) (neq el xor_s)
         (neq el imp_s) (neq el equ_s) (neq el '0) (neq el '1) (not (member el id_nam)))
         (push el id_nam) (setq id_pos (+ 1 id_pos)))
        ((listp el) (id_count el))))
nil)
;************************************************************************************************
;************** Increment des Identifer Werte Vectors == Nächste Kommbination *******************
;************************************************************************************************
(defun id_inc(inc_x)
 (setf (aref w w_anz 0) inc_x)                      ;Speichern Ergebnis in WerteTabelle
 (do* ((i 0 (+ 1 i))) ((= i id_pos))            ;rette Bitkombination in Werte
 (setf (aref w w_anz (+ 1 i)) (aref id_wer i))) ;tabelle
 (setq w_anz (+ 1 w_anz))                       ;nächste Mal eine neue Zeile in WerteTabelle
 (setf (aref id_wer 0) (+ 1 (aref id_wer 0)))
 (do* ((i 1 (+ 1 i))) ((= i (+ 1 id_pos)))
   (cond ((= (aref id_wer (- i 1)) 2)
    (setf (aref id_wer (- i 1)) 0) (setf (aref id_wer i) (+ 1 (aref id_wer i))))))
(aref id_wer id_pos))
;************************************************************************************************
;********************************* WertSuche der Variablen  *************************************
;************************************************************************************************
(defun get_wert (get_x)
 (ifn (member get_x id_nam) (return-from get_wert get_x))
 (setq l id_nam)
 (setq p (do ((pos 0 (+ 1 pos)) (el (car l) (car l)) (l (cdr l) (cdr l))) ((eq get_x el) pos)))
 (aref id_wer p))
;************************************************************************************************
;************************** Normalisieren des EingabeStrings  ***********************************
;************************************************************************************************
(defun bol_mak(ein)
 (do ((e0 (car ein) (car ein)) (e1 (cadr ein) (cadr ein))) ((eq nil e0))
        ;*************** Anpassen der Negationen ***********************************
  (cond ((and (eq e0 not_s) (eq e1 not_s)) (setq ein (cdr ein)))
        ;*************** Anpassen Element Element or Element !Element **************
        ((and (atom e0) (neq e0 not_s) (neq e0 and_s) (neq e0 or_s) (neq e0 xor_s)
                        (neq e0 imp_s) (neq e0 equ_s)
                        (neq e1 and_s) (neq e1 or_s) (neq e1 xor_s) (neq e1 imp_s)
                        (neq e1 equ_s) (neq e1 nil)) (push (get_wert e0) bol) (push '& bol))
        ;************** Anpassen (bol) (bol) oder (bol) Element ********************
        ((and (listp e0) (neq e1 and_s) (neq e1 or_s) (neq e1 xor_s) (neq e1 imp_s) (neq e1 equ_s)
              (neq e1 nil)) (push 'kla bol) (bol_mak e0) (push 'klz bol) (push '& bol))
        ;************** Ausführen einer (bol) **************************************
        ((and (listp e0)) (push 'kla bol) (bol_mak e0) (push 'klz bol))
        ;************** Eintrag der Bitkombination *********************************
        (T (push (get_wert e0) bol) ))
 (setq ein (cdr ein) ))
nil)

;************************************************************************************************
;****************************** P A R S E N *****************************************************
;************************************************************************************************
;************************************************************************************************
;* UP9 ********** RausHolen eines Zeichens aus dem String mit Probe auf Gültigkeit **************
;************************************************************************************************
(defun match (m_x)
 (cond ((eq zeichen m_x) (setq zeichen (pop bol))) ;**** alles OK dann neues Zeichen
       (T (setq fehler 5))))                     ;**** Vorkommen nur bei KlammerFehler
 

;************************************************************************************************
;*********************** Umwandlung eines BoolStrings in die InfixNotaion ***********************
;************************************************************************************************
(defun parse()
(setq stack '())
(setq zeichen (pop bol)) ;********** Festlegen des ersten Zeichens
(do () ((eq zeichen nil))
  (if (neq fehler '0) (return-from parse fehler))
  (G_EQU)))
;************************************************************************************************
;* UP1 ***************** Äquvalenz besteht aus Imlikationen *************************************
;************************************************************************************************
(defun G_EQU ()
 (if (neq fehler '0) (return-from G_EQU fehler))
 (G_IMP)  (if (neq fehler '0) (return-from G_EQU fehler))
 (do () ((neq zeichen equ_s))
   (push zeichen stac1)  (if (neq fehler '0) (return-from G_EQU fehler))
   (match zeichen)       (if (neq fehler '0) (return-from G_EQU fehler))
   (G_IMP)               (if (neq fehler '0) (return-from G_EQU fehler))
   (push (pop stac1) stack)))
;************************************************************************************************
;* UP1 ***************** Implikation besteht aus Alternative ************************************
;************************************************************************************************
(defun G_IMP()
 (if (neq fehler '0) (return-from G_IMP fehler))
 (G_XOR)  (if (neq fehler '0) (return-from G_IMP fehler))
 (do () ((neq zeichen imp_s))
   (push zeichen stac1)  (if (neq fehler '0) (return-from G_IMP fehler))
   (match zeichen)       (if (neq fehler '0) (return-from G_IMP fehler))
   (G_XOR)               (if (neq fehler '0) (return-from G_IMP fehler))
   (push (pop stac1) stack)))
;************************************************************************************************
;* UP3 ***************** Alternative besteht aus Disjunktion ************************************
;************************************************************************************************
(defun G_XOR()
 (if (neq fehler '0) (return-from G_XOR fehler))
 (G_OR)  (if (neq fehler '0) (return-from G_XOR fehler))
 (do () ((neq zeichen xor_s))
   (push zeichen stac1)  (if (neq fehler '0) (return-from G_XOR fehler))
   (match zeichen)       (if (neq fehler '0) (return-from G_XOR fehler))
   (G_OR)                (if (neq fehler '0) (return-from G_XOR fehler))
   (push (pop stac1) stack)))
;************************************************************************************************
;* UP4 ***************** Disjunktion besteht aus Konjunktion ************************************
;************************************************************************************************
(defun G_OR()
 (if (neq fehler '0) (return-from G_OR fehler))
 (G_AND)  (if (neq fehler '0) (return-from G_OR fehler))
 (do () ((neq zeichen or_s))
   (push zeichen stac1)  (if (neq fehler '0) (return-from G_OR fehler))
   (match zeichen)       (if (neq fehler '0) (return-from G_OR fehler))
   (G_AND)               (if (neq fehler '0) (return-from G_OR fehler))
   (push (pop stac1) stack)))
;************************************************************************************************
;* UP5 ***************** Konjuntion besteht aus NOT-Symbol **************************************
;************************************************************************************************
(defun G_AND()
 (if (neq fehler '0) (return-from G_AND fehler))
 (G_NOT)  (if (neq fehler '0) (return-from G_AND fehler))
 (do () ((neq zeichen and_s))
   (push zeichen stac1)  (if (neq fehler '0) (return-from G_AND fehler))
   (match zeichen)       (if (neq fehler '0) (return-from G_AND fehler))
   (G_NOT)               (if (neq fehler '0) (return-from G_AND fehler))
   (push (pop stac1) stack)))
;************************************************************************************************
;* UP6 ***************** NOT-SYMBOL besteht aus SYMBOL ******************************************
;************************************************************************************************
(defun G_NOT()
 (if (neq fehler '0) (return-from G_NOT fehler))
 (cond ((eq zeichen not_s)
   (push zeichen stac1) (if (neq fehler '0) (return-from G_NOT fehler))
   (match zeichen)      (if (neq fehler '0) (return-from G_NOT fehler))
   (G_AUS)              (if (neq fehler '0) (return-from G_NOT fehler))
   (push (pop stac1) stack))
   (T (G_AUS))))
;************************************************************************************************
;* UP7 ****** Ein Element besteht aus '0', '1' und '(Äquivalenz)' *******************************
;************************************************************************************************
(defun G_AUS()
 (if (neq fehler '0) (return-from G_AUS fehler))
 (cond ((eq zeichen 'kla)
         (match zeichen)
         (G_EQU)        (if (neq fehler '0) (return-from G_AUS fehler))
         (match 'klz)   (if (neq fehler '0) (return-from G_AUS fehler)))
       ((or (eq zeichen '0) (eq zeichen '1))
         (push zeichen stack)
         (match zeichen) (if (neq fehler '0) (return-from G_AUS fehler)))
       (T (setq fehler 5))))
;************************************************************************************************
;**** T O O L S   Z U R   B E R E C H N U N G   D E R   P O S T F I X N O T A T I O N ***********
;************************************************************************************************
;************************************************************************************************
;* UP1 ************************************ Negation ********************************************
;************************************************************************************************
(defun not_f (not_x)
 (if (= not_x 0) (return-from not_f 1))
 (if (= not_x 1) (return-from not_f 0)))
;************************************************************************************************
;* UP2 ************************************ Konjuktion ******************************************
;************************************************************************************************
(defun and_f (and_x and_y)
 (if (and (= and_x 0) (= and_y 0)) (return-from and_f 0))
 (if (and (= and_x 0) (= and_y 1)) (return-from and_f 0))
 (if (and (= and_x 1) (= and_y 0)) (return-from and_f 0))
 (if (and (= and_x 1) (= and_y 1)) (return-from and_f 1)))
;************************************************************************************************
;* UP3 ************************************ Disjunktion *****************************************
;************************************************************************************************
(defun or_f (or_x or_y)
 (if (and (= or_x 0) (= or_y 0)) (return-from or_f 0))
 (if (and (= or_x 0) (= or_y 1)) (return-from or_f 1))
 (if (and (= or_x 1) (= or_y 0)) (return-from or_f 1))
 (if (and (= or_x 1) (= or_y 1)) (return-from or_f 1)))
;************************************************************************************************
;* UP4 ************************************ Alternative *****************************************
;************************************************************************************************
(defun xor_f (xor_x xor_y)
 (if (and (= xor_x 0) (= xor_y 0)) (return-from xor_f 0))
 (if (and (= xor_x 0) (= xor_y 1)) (return-from xor_f 1))
 (if (and (= xor_x 1) (= xor_y 0)) (return-from xor_f 1))
 (if (and (= xor_x 1) (= xor_y 1)) (return-from xor_f 0)))
;************************************************************************************************
;* UP5 ************************************ Implikation *****************************************
;************************************************************************************************
(defun imp_f (imp_x imp_y)
 (if (and (= imp_x 0) (= imp_y 0)) (return-from imp_f 1))
 (if (and (= imp_x 0) (= imp_y 1)) (return-from imp_f 0))
 (if (and (= imp_x 1) (= imp_y 0)) (return-from imp_f 1))
 (if (and (= imp_x 1) (= imp_y 1)) (return-from imp_f 1)))
;************************************************************************************************
;* UP6 ************************************ Äquivalenz ******************************************
;************************************************************************************************
(defun equ_f (equ_x equ_y)
 (if (and (= equ_x 0) (= equ_y 0)) (return-from equ_f 1))
 (if (and (= equ_x 0) (= equ_y 1)) (return-from equ_f 0))
 (if (and (= equ_x 1) (= equ_y 0)) (return-from equ_f 0))
 (if (and (= equ_x 1) (= equ_y 1)) (return-from equ_f 1)))

(defun berechne ()
 (dolist (el stack)
   (cond ((or (eq el '1) (eq el '0)) (push el stac1))
         ((eq el not_s) (push (not_f (pop stac1)            ) stac1))
         ((eq el and_s) (push (and_f (pop stac1) (pop stac1)) stac1))
         ((eq el or_s ) (push (or_f  (pop stac1) (pop stac1)) stac1))
         ((eq el xor_s) (push (xor_f (pop stac1) (pop stac1)) stac1))
         ((eq el imp_s) (push (imp_f (pop stac1) (pop stac1)) stac1))
         ((eq el equ_s) (push (equ_f (pop stac1) (pop stac1)) stac1))))
(pop stac1))
;************************************************************************************************
;******************************* Ausgabe des Strings ********************************************
;************************************************************************************************
(defun get_nam (num)
 (setq nam id_nam)
 (do ((el (car nam) (car nam)) (nam (cdr nam) (cdr nam)) (cnt 0 (+ 1 cnt))) ((= cnt num) el)))
(defun ausgabe ()
(setq aus '())
;******************************* Zählen der DisjuntionsGlieder **********************************
(setq danz (do ((e 0 (+ 1 e)) (da 0))((= e w_anz) da) (if(= (aref w e 0) 1)(setq da (+ da 1)))))
;*********************** Ausgabe der Disjuntionsglieder *****************************************
(cond ((= (aref w 0 0) 2) (push 1 aus))
      ((= danz 0)         (push 0 aus))
      (T (do ((l1 0 (+ l1 1))) ((= l1 w_anz))
           (cond ((= (aref w l1 0) 1) (
              do ((l2 1 (+ l2 1))) ((= l2 (+ 1 id_pos)))
                 (cond ((= (aref w l1 l2) 0) (push '! aus) (push (get_nam (- l2 1)) aus))
                       ((= (aref w l1 l2) 1) (push (get_nam (- l2 1)) aus))))
                 (setq danz (- danz 1))
                 (if (> danz 0) (push '+ aus))))))))
;************************************************************************************************
;************************** K U E R Z E N   D E R   W E R T E T A B E L L E *********************
;************************************************************************************************
(defun kuerzen ()
;******************************** Kuerzen nach Schema 1 *****************************************
 (do ((pos   id_pos      (- pos 1))     ;position in WerteSpalte
      (b_abs (/ w_anz 2) (/ b_abs 2))   ;Abstand in WerteTabelle zur nächsten Zeile
      (b_anz 1           (* b_anz 2)))  ;Anzahl der zu überprüfenden Blöcke
      ((= pos 0))
   (setq ptr 0)
   (do ((l1 b_anz (- l1 1))) ((= l1 0))
   (do ((l2 b_abs (- l2 1))) ((= l2 0))
      (cond ((and (= 1 (aref w ptr 0)) (= 1 (aref w (+ ptr b_abs) 0)))
            (setf (aref w ptr pos) 9) (setf (aref w (+ ptr b_abs) pos) 9)
            (do ((l3 id_pos (- l3 1))) ((= l3 0))
              (cond ((= (aref w (+ ptr b_abs) l3) 9)
                  (setf (aref w (+ ptr b_abs) l3) (aref w ptr l3)))
                    ((= (aref w ptr l3) 9)
                  (setf (aref w ptr l3) (aref w (+ ptr b_abs) l3)))))))
      (setq ptr (+ ptr 1)))
      (setq ptr (+ ptr b_abs))))
;******************************** Kuerzen nach Schema 2 *****************************************
 (cond ((= (do ((l1 0 (+ l1 1)) (l2 0 (+ l2 (aref w l1 0)))) ((= l1 w_anz) l2)) w_anz)
   (setf (aref w 0 0) 2) (return-from kuerzen nil)))
;******************************** Kuerzen nach Schema 3 *****************************************
 (do ((l1 0 (+ l1 1))) ((= l1 (- w_anz 1)))                    ;for(l1=0;l1<w_anz-1;l1++){
   (do ((l2 (+ l1 1) (+ l2 1))) ((= l2 w_anz))           ; for(l2=l1+1 ;l2<w_anz;l2++){
      (if (= (do ((l3 0 (+ 1 l3)) (ptr 0)) ((= l3 (+ id_pos 1)) ptr)
                (if (= (aref w l1 l3) (aref w l2 l3)) (setq ptr (+ 1 ptr))))
             (+ 1 id_pos)) (setf (aref w l1 0) 0)))))
;************************************************************************************************
;************************** M A I N R O U T I N E ***********************************************
;************************************************************************************************
(defun bool(ein)
(setq fehler 0)                 ;**** Globale Variable für gemachte Fehler
(setq id_nam '())               ;**** Namen und Werte der Variablen im BoolAusdruck
(setq id_pos '0)                ;**** Pos&Anzahl der Variablen im NamenListe
(setq w_anz  '0)                ;**** Anzahl der möglichen Werte einer DNV

 (id_count ein) (setq id_nam (reverse id_nam))   ;** Zählen der Variablen in einer Liste
 (setq id_wer (make-array (+ 1 id_pos)))         ;** Vector für die Kombinationen festlegen
 (setq dim '()) (push (+ 1 id_pos) dim) (push (expt 2 id_pos) dim);** Kombinations-Werte
 (setq w      (make-array dim))                                   ;** Matrix erstellen
 (do ((e 0)) ((= e 1))
   (setq bol '()) (bol_mak ein) (setq bol (reverse bol)) ;normalisieren des EingabeStrings
   (parse)
   (setq stack (reverse stack))         ;Postfix in PräfixNotation umwandeln
   (setq bool_x (berechne))
   (setq e (id_inc bool_x)))
(setq *print-length* nil)       ;Globale Variable für AusgabeLänge unbegrenzt
(setq *print-level*  nil)        ;Globale Variable für AusgabeTiefe unbegernzt
 (pprint w)
 (kuerzen)
 (ausgabe) (setq aus (reverse aus))
 (pprint aus)
(fehl))                                 ;Ausgabe des Fehlers

(bool '((0 + 1) > (0 + 1)))