#lang racket

(require slib/format srfi/1)

;;; P46  (**) Truth tables for logical expressions.
;;; Approach: Use pattern matching to parse expressions.
;;; Catamorphic patterns a la SRFI-241 would be useful here but they can be emulated with app
(define (table a-sym b-sym expr)
  (define (eval-table a-sym a b-sym b table)
    (define cat (curry eval-table a-sym a b-sym b)) ; aka catamorphism
    (match table
      [(== a-sym eq?) a]
      [(== b-sym eq?) b]
      [`(not  ,(app cat expr1))                  (not expr1)]
      [`(and  ,(app cat expr1) ,(app cat expr2)) (and expr1 expr2)]
      [`(or   ,(app cat expr1) ,(app cat expr2)) (or expr1 expr2)]
      [`(nand ,(app cat expr1) ,(app cat expr2)) (not (and expr1 expr2))]
      [`(nor  ,(app cat expr1) ,(app cat expr2)) (not (or expr1 expr2))]
      [`(xor  ,(app cat expr1) ,(app cat expr2)) (xor expr1 expr2)]
      [`(impl ,(app cat expr1) ,(app cat expr2)) (if expr1 expr2 #t)]
      [`(equ  ,(app cat expr1) ,(app cat expr2)) (eq? expr1 expr2)]))
  (format #t "~A~1,5@T~A~1,5@TResult~%" a-sym b-sym)
  (for* ([a (in-list '(#t #f))]
         [b (in-list '(#t #f))])
    (format #t "~A~1,5@T~A~1,5@T~A~%" a b (eval-table a-sym a b-sym b expr))))

(table 'A 'B '(and A (or A B)))

;;; P47 (*) Truth tables for logical expressions (2).
;;; Approach: Convert the infix notated expressions to prefix notation and solve using the above P46 function
(define (infix-table a-sym b-sym expr)
  (define (infix->prefix expr)
    (match expr
      [(== a-sym eq?) a-sym]
      [(== b-sym eq?) b-sym]
      [(list 'not (app infix->prefix expr1))
       (list 'not expr1)]
      [(list (app infix->prefix expr1) (? symbol? binary-op) (app infix->prefix expr2))
       (list binary-op expr1 expr2)]))
  (table a-sym b-sym (infix->prefix expr)))

(displayln "---")
(infix-table 'A 'B '(A and (A or (not B))))

;;; P48 (**) Truth tables for logical expressions (3).
;;; Evaluate infix expressions directly using an arbitrary number of symbols instead of a fixed 2.
;;; Just use a simple alist for the symbol table
(define (infix-table* symbols expr)
  (define (eval-table symtab expr)
    (define cat (curry eval-table symtab))
    (match expr
      [(? symbol? (app (curryr assq symtab) (cons sym val))) val]
      [`(not ,(app cat expr1))                   (not expr1)]
      [`(,(app cat expr1) and  ,(app cat expr2)) (and expr1 expr2)]
      [`(,(app cat expr1) or   ,(app cat expr2)) (or expr1 expr2)]
      [`(,(app cat expr1) nand ,(app cat expr2)) (not (and expr1 expr2))]
      [`(,(app cat expr1) nor  ,(app cat expr2)) (not (or expr1 expr2))]
      [`(,(app cat expr1) xor  ,(app cat expr2)) (xor expr1 expr2)]
      [`(,(app cat expr1) impl ,(app cat expr2)) (if expr1 expr2 #f)]
      [`(,(app cat expr1) equ  ,(app cat expr2)) (eq? expr1 expr2)]))
  (format #t "~{~A~1,5@T~}Result~%" symbols)
  (let loop ([symbols symbols]
             [symtab '()])
    (cond
      [(null? symbols)
       (void (format #t "~{~A~1,5@T~}~A~%" (reverse (map cdr symtab)) (eval-table symtab expr)))]
      [else
       (loop (cdr symbols) (alist-cons (car symbols) #t symtab))
       (loop (cdr symbols) (alist-cons (car symbols) #f symtab))])))

(displayln "---")
(infix-table* '(A B C) '((A and (B or C)) equ ((A and B) or (A and C))))

standard-module-name-resolver: collection not found
  for module path: slib/format
  collection: "slib"
  in collection directories:
   /home/pasterack/.local/share/racket/8.8/collects
   /home/pasterack/racket88/collects/
   ... [179 additional linked and package directories]
  context...:
   /home/pasterack/racket88/collects/racket/require-transform.rkt:266:2: expand-import
   /home/pasterack/racket88/collects/racket/private/reqprov.rkt:648:16
   /home/pasterack/racket88/collects/racket/private/reqprov.rkt:646:2: filter-by-mode
   /home/pasterack/racket88/collects/racket/require-transform.rkt:266:2: expand-import
   /home/pasterack/racket88/collects/racket/private/reqprov.rkt:287:21: try-next
   /home/pasterack/racket88/collects/racket/private/reqprov.rkt:401:21: try-next
   /home/pasterack/racket88/collects/racket/private/reqprov.rkt:258:2
   /home/pasterack/racket88/collects/syntax/wrap-modbeg.rkt:46:4
   /home/pasterack/racket88/share/pkgs/scribble-lib/scribble/run.rkt:175:26: go
   .../private/map.rkt:40:19: loop
   .../racket/cmdline.rkt:191:51
   body of "/home/pasterack/racket88/share/pkgs/scribble-lib/scribble/run.rkt"