; $Id: unicode.scm 2156 2008-01-25 13:25:12Z schimans $

; MINLOG: unicode.scm

; (load "~/minlog/init.scm")


; (add-token "⊥" 'const (make-term-in-const-form false-const))




;; BOOLEAN SYMBOLS

; most of code originates from src/boole.scm


; CONJUNCTION ∧


(add-token
 "∧" 'and-op
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form (pconst-name-to-pconst "AndConst")) x y)))

(add-display
 (py "boole")
 (lambda (x)
   (if (term-in-app-form? x)
       (let ((op (term-in-app-form-to-final-op x))
             (args (term-in-app-form-to-args x)))
         (if (and (term-in-const-form? op)
                  (string=? "AndConst"
                            (const-to-name (term-in-const-form-to-const op)))
                  (= 2 (length args)))
             (list 'and-op "∧"
                   (term-to-token-tree (car args))
                   (term-to-token-tree (cadr args)))
             #f))
       #f)))



; IMPLICATION →

(add-token
 "→" 'imp-op
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form (pconst-name-to-pconst "ImpConst")) x y)))

(add-display
 (py "boole")
 (lambda (x)
   (if (term-in-app-form? x)
       (let ((op (term-in-app-form-to-final-op x))
	     (args (term-in-app-form-to-args x)))
	 (if (and (term-in-const-form? op)
		  (string=? "ImpConst"
			    (const-to-name (term-in-const-form-to-const op)))
		  (= 2 (length args)))
	     (list 'imp-op "→"
		   (term-to-token-tree (car args))
		   (term-to-token-tree (cadr args)))
	     #f))
       #f)))



; DISJUNCTION ∨

(add-token
 "∨" 'or-op
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form (pconst-name-to-pconst "OrConst")) x y)))

(add-display
 (py "boole")
 (lambda (x)
   (if (term-in-app-form? x)
       (let ((op (term-in-app-form-to-final-op x))
	     (args (term-in-app-form-to-args x)))
	 (if (and (term-in-const-form? op)
		  (string=? "OrConst"
			    (const-to-name (term-in-const-form-to-const op)))
		  (= 2 (length args)))
	     (list 'or-op "∨"
		   (term-to-token-tree (car args))
		   (term-to-token-tree (cadr args)))
	     #f))
       #f)))


; NEGATION ¬

(add-token
 "¬" 'prefix-op
 (lambda (x)
   (mk-term-in-app-form
    (make-term-in-const-form (pconst-name-to-pconst "NegConst")) x)))

(add-display
 (py "boole")
 (lambda (x)
   (if (term-in-app-form? x)
       (let ((op (term-in-app-form-to-final-op x))
	     (args (term-in-app-form-to-args x)))
	 (if (and (term-in-const-form? op)
		  (string=? "NegConst"
			    (const-to-name (term-in-const-form-to-const op)))
		  (= 1 (length args)))
	     (list 'prefix-op "¬"
		   (term-to-token-tree (car args)))
	     #f))
       #f)))





;; FORMULAE


; LEIBNITZEQUALITY ≈

; I do not know how to define infix notation
; for predicate constants.

; (pp(pf "Equal boole1 boole2"))

(add-token
 "≈"
 'pred-infix
 (lambda (x y)
   ((string-and-arity-to-predconst-parse-function
	 "Equal" (make-arity (term-to-type x) (term-to-type y)))
	(- 1) x y)))
 
(add-predconst-display "Equal" 'pred-infix "≈")



; FUNCTION NEEDED FOR (pretty-print)

; It would be good to save the op-string in a seperated variable.
; Otherwise the whole code of (formula-token-tree-to-pp-tree )
; needs to be duplicated.

(define (formula-token-tree-to-pp-tree token-tree)
  (case (car token-tree)
    ((atom predicate) (make-pp-line (cadr token-tree)))
    ((imp-op and-op tensor-op)
     (let* ((op-string (cadr token-tree))
            (arg1 (formula-token-tree-to-pp-tree (caddr token-tree)))
            (arg2 (formula-token-tree-to-pp-tree (cadddr token-tree)))
            (prec-op (formula-token-type-to-precedence (car token-tree)))
            (prec-arg1
             (formula-token-type-to-precedence (car (caddr token-tree))))
            (prec-arg2
             (formula-token-type-to-precedence (car (cadddr token-tree))))
            (arg1-prefix (make-pp-line ""))
            (arg1-postfix (make-pp-line ""))
            (arg2-prefix (make-pp-line ""))
            (arg2-postfix (make-pp-line "")))
       (if (or (and (< prec-arg1 prec-op)
                    (not (quant-prime-token-tree-form? (caddr token-tree))))
               (and (= prec-arg1 prec-op)
                    (formula-right-assoc? (car (caddr token-tree)))))
           (begin (set! arg1-prefix (make-pp-line "("))
                  (set! arg1-postfix (make-pp-line ")")))
           (set! arg1-postfix
                 (make-pp-line
                  (separator-string (pp-tree-end arg1) op-string))))
       (if (or (and (< prec-arg2 prec-op)
                    (not (memq (car (cadddr token-tree))
                               '(and-op tensor-op all-op ex-op
                                        allnc-op exnc-op exca-op excl-op))))
               (and (= prec-arg2 prec-op)
                    (formula-left-assoc? (car (cadddr token-tree)))))
           (begin (set! arg2-prefix (make-pp-line "("))
                  (set! arg2-postfix (make-pp-line ")"))))
       (let* ((arg1-tree (list (+ (car arg1-prefix)
                                  (car arg1)
                                  (car arg1-postfix)) 
                               (car arg1-prefix)
                               'cat
                               (list arg1-prefix arg1 arg1-postfix)))
              (arg2-tree (list (+ (car arg2-prefix)
                                  (car arg2)
                                  (car arg2-postfix))
                               (car arg2-prefix)
                               'cat 
                               (list arg2-prefix arg2 arg2-postfix)))
              (op (if (string=? op-string "")
                      (make-pp-line (separator-string
                                     (pp-tree-end arg1-tree)
                                     (pp-tree-start arg2-tree)))
                      (make-pp-line op-string)))
              (arg1-op-tree (list (+ (car arg1-tree) (car op)) 0 'cat
                                  (list arg1-tree op))))
         (list (+ (car arg1-op-tree) (car arg2-tree)) 0 'newline
               (list arg1-op-tree arg2-tree)))))
    ((all-op ex-op allnc-op exnc-op exca-op excl-op)
     (let* ((op-string
             (case (car token-tree)
               ((all-op) "∀")
               ((ex-op) "∃")
               ((allnc-op) "∀nc")
               ((exnc-op) "∃nc")
               ((exca-op) "∃ca")
               ((excl-op) "∃cl")
               (else (myerror "formula-token-tree-to-pp-tree"
                              "unexpected op-string" op-string
                              "in token tree" token-tree))))
            (varstrings-and-kernel
             (formula-token-tree-to-varstrings-and-kernel token-tree))
            (varstrings (car varstrings-and-kernel))
            (kernel (cadr varstrings-and-kernel))
            (comma-string (do ((l (cdr varstrings) (cdr l))
                               (res (car varstrings)
                                    (string-append res "," (car l))))
                              ((null? l) res)))
            (sep-string (if (or (prime-form? kernel)
                                (quant-prime-token-tree-form? kernel))
                            " " "."))
            (prefix (string-append op-string comma-string sep-string))
            (prefix-width (string-length prefix))
            (postfix (formula-token-tree-to-pp-tree kernel))
            (postfix-width (car postfix)))
       (list (+ prefix-width postfix-width) 1 'newline 
             (list (make-pp-line prefix) postfix))))
    (else (begin (display "No pretty printing for: ") 
                 (display token-tree) 
                 (newline) 
                 (make-pp-line "")))))

