; $Id: align.scm 2156 2008-01-25 13:25:12Z schimans $
; (load "~/minlog/init.scm")

(set! COMMENT-FLAG #f)
(libload "nat.scm")
(libload "listrev.scm")
(set! COMMENT-FLAG #t)

(add-alg "char" '("A" "char") '("B" "char") '("C" "char"))


; We want to use (unit yplus char) as the type characters including space.

(add-param-alg "yplus" 'sum-typeop
	       '("Inleft" "alpha1=>yplus")
	       '("Inright" "alpha2=>yplus"))

(type-to-string
 (const-to-type (car (type-info-to-rec-consts (py "unit yplus char=>alpha")))))
; "(unit=>alpha)=>(char=>alpha)=>unit yplus char=>alpha"

; (pp (pt "(Inleft unit char)Dummy"))
; (pp (pt "(Inright char unit) A"))
; (pp (pt "(Inright char unit) B"))

(add-token "Spc" 'const (pt "(Inleft unit char)Dummy"))

(add-token
 "I" 'prefix-op
 (lambda (x) (mk-term-in-app-form (pt "(Inright char unit)") x)))

(add-display
 (py "unit yplus char")
 (lambda (x)
   (let ((op (term-in-app-form-to-final-op x))
	 (args (term-in-app-form-to-args x)))
     (cond ((and (term-in-const-form? op)
		 (string=? "Inleft"
			   (const-to-name (term-in-const-form-to-const op)))
		 (= 1 (length args))
		 (let* ((arg (car args))
			(argop (term-in-app-form-to-final-op arg))
			(argargs (term-in-app-form-to-args arg)))
		   (and (term-in-const-form? argop)
			(string=? "Dummy"
				  (const-to-name
				   (term-in-const-form-to-const argop)))
			(null? argargs))))
	    (list 'const "Spc"))
	   ((and (term-in-const-form? op)
		 (string=? "Inright"
			   (const-to-name (term-in-const-form-to-const op)))
		 (= 1 (length args)))
	    (list 'prefix-op "I" (term-to-token-tree (car args))))
	   (else #f)))))

; (pp (pt "I A"))
; (pp (pt "I B"))
; (pp (pt "Spc"))


; We use (tensor) pairs of characters, to work with alignments.

(add-param-alg "ytensor" 'tensor-typeop
	       '("TensorPair" "alpha1=>alpha2=>ytensor"))

(type-to-string
 (const-to-type
  (car (type-info-to-rec-consts (py "alpha1 ytensor alpha2=>alpha")))))
; "(alpha1=>alpha2=>alpha)=>alpha1 ytensor alpha2=>alpha"

; We want the display r#s for terms, and (Lft r) and (Rht r) for the
; components.

(add-token
 "#" 'pair-op ;hence right associative
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form
     (let* ((const (constr-name-to-constr "TensorPair"))
	    (tvars (const-to-tvars const))
	    (type1 (term-to-type x))
	    (type2 (term-to-type y))
	    (subst (make-substitution tvars (list type1 type2))))
       (const-substitute const subst #f)))
    x y)))

(add-display
 (py "alpha1 ytensor alpha2")
 (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=? "TensorPair"
			    (const-to-name (term-in-const-form-to-const op)))
		  (= 2 (length args)))
	     (list 'pair-op "#"
		   (term-to-token-tree (car args))
		   (term-to-token-tree (cadr args)))
	     #f))
       #f)))

; (pp (pt "alpha1#boole"))

(add-program-constant
 "TensorLft" (py "alpha1 ytensor alpha2=>alpha1") t-deg-one)

(add-program-constant
 "TensorRht" (py "alpha1 ytensor alpha2=>alpha2") t-deg-one)

(add-token
 "Lft" 'prefix-op
 (lambda (x)
   (mk-term-in-app-form
    (make-term-in-const-form
     (let* ((const (pconst-name-to-pconst "TensorLft"))
	    (tvars (const-to-tvars const))
	    (tensortype (term-to-type x))
	    (types (alg-form-to-types tensortype))
	    (subst (make-substitution tvars types)))
       (const-substitute const subst #f)))
    x)))

(add-display
 (py "alpha")
 (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=? "TensorLft"
			    (const-to-name (term-in-const-form-to-const op)))
		  (= 1 (length args)))
	     (list 'prefix-op "Lft"
		   (term-to-token-tree (car args)))
	     #f))
       #f)))

(add-token
 "Rht" 'prefix-op
 (lambda (x)
   (mk-term-in-app-form
    (make-term-in-const-form
     (let* ((const (pconst-name-to-pconst "TensorRht"))
	    (tvars (const-to-tvars const))
	    (tensortype (term-to-type x))
	    (types (alg-form-to-types tensortype))
	    (subst (make-substitution tvars types)))
       (const-substitute const subst #f)))
    x)))

(add-display
 (py "alpha")
 (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=? "TensorRht"
			    (const-to-name (term-in-const-form-to-const op)))
		  (= 1 (length args)))
	     (list 'prefix-op "Rht"
		   (term-to-token-tree (car args)))
	     #f))
       #f)))

(add-computation-rule (pt "Lft(alpha1#alpha2)") (pt "alpha1"))
(add-computation-rule (pt "Rht(alpha1#alpha2)") (pt "alpha2"))

(pp (nt (pt "Rht(nat#alpha)")))


(add-var-name "c" (py "char")) ;character
(add-var-name "d" (py "unit yplus char")) ;extended character
(add-var-name "cc" (py "char ytensor char")) ;pair of characters
(add-var-name "dd" (py "(unit yplus char) ytensor (unit yplus char)"))
; pair of extended characters


(add-var-name "s" (py "list char")) ;list of characters, string
(add-var-name "t" (py "list(unit yplus char)"))
; list of extended characters, extended string
(add-var-name "u" (py "list(char ytensor char)"))
; list of pairs of characters
(add-var-name "v" (py "list((unit yplus char) ytensor (unit yplus char))"))
; list of pairs of extended characters


; "NoDSpc" expresses that in v there are no double spaces.

(add-program-constant
 "NoDSpc" (py "list((unit yplus char) ytensor (unit yplus char))=>boole")
 t-deg-one)

(add-computation-rule
 (pt "NoDSpc(Nil (unit yplus char) ytensor (unit yplus char))")
 (pt "True"))

(add-computation-rule (pt "NoDSpc(v::(Spc#Spc))") (pt "False"))
(add-computation-rule (pt "NoDSpc(v::(I c#d))") (pt "True"))
(add-computation-rule (pt "NoDSpc(v::(Spc#I c))") (pt "True"))

(add-rewrite-rule (pt "NoDSpc(v::(d#I c))") (pt "True"))

; We take some canonical inhabitants.

(add-computation-rule (pt "(Inhab char)") (pt "A"))

(pp (nt (pt "(Inhab char)")))
(pp (nt (pt "(Inhab alpha)")))
(pp (nt (pt "(Inhab alpha1)")))

(add-computation-rule (pt "(Inhab (unit yplus char))") (pt "Spc"))
(add-computation-rule (pt "(Inhab char ytensor char)") (pt "A#A"))

(add-computation-rule
 (pt "(Inhab (unit yplus char) ytensor (unit yplus char))")
 (pt "Spc#Spc"))

; "CharEProj"
(set-goal (pf "all n,u E(u__n)"))
(assume "n")
(ind)
(use "Truth-Axiom")
(assume "u" "cc" "H1")
(ng)
(cases 'auto)
(assume "H2")
(use "H1")
(assume "H2")
(use "Truth-Axiom")
(save "CharEProj")

; "ExtCharEProj"
(set-goal (pf "all n,v E(v__n)"))
(assume "n")
(ind)
(use "Truth-Axiom")
(assume "v" "dd" "H1")
(ng)
(cases 'auto)
(assume "H2")
(use "H1")
(assume "H2")
(use "Truth-Axiom")
(save "ExtCharEProj")


(add-var-name "a" (py "list char=>list char=>
                       list((unit yplus char) ytensor (unit yplus char))"))
; alignment


; "Cp" compresses a list of extended characters, by removing spaces.

(add-program-constant "Cp" (py "list(unit yplus char)=>list char") t-deg-one)

(add-computation-rule (pt "Cp(Nil unit yplus char)") (pt "(Nil char)"))
(add-computation-rule (pt "Cp(t::I c)") (pt "Cp t::c"))
(add-computation-rule (pt "Cp(t::Spc)") (pt "Cp t"))

(pp (nt (pt "Cp(:I A::Spc::I A::I B::Spc)"))) ;:A::A::B


; To express that "a" is a correct alignment we use an inductive definition.

(add-ids
 (list (list "Align"
	     (make-arity
	      (py "list char=>list char=>
                   list((unit yplus char) ytensor (unit yplus char))"))))
 '("all a.(all s1,s2 Cp(([dd]Lft dd)map a s1 s2)=s1) ->
          (all s1,s2 Cp(([dd]Rht dd)map a s1 s2)=s2) ->
          (all s1,s2 NoDSpc(a s1 s2)) -> Align a" "DefAlign"))

; (pp "DefAlign")


; For simplicity we assume that scores have nat values.

(add-var-name
 "sc" (py "(unit yplus char) ytensor (unit yplus char)=>nat")) ;score

(add-program-constant "Sum" (py "list nat=>nat") t-deg-one)

(add-computation-rule (pt "Sum(Nil nat)") (pt "Zero"))
(add-computation-rule (pt "Sum(list nat::nat)") (pt "Sum list nat+nat"))

; (pp (nt (pt "Sum(:1::2::3::4)")))


; The recursively defined V function.  Computation rules to be added.

(add-program-constant
 "V" (py "((unit yplus char) ytensor (unit yplus char)=>nat)=>nat=>nat=>nat")
 t-deg-one)


; Theorem 1 consists of two parts:

(set-goal
 (pf "all sc ex a.Align a & all s1,s2.V sc Lh s1 Lh s2=Sum(sc map a s1 s2)"))

(set-goal
 (pf "all sc,a,s1,s2.Align a -> V sc Lh s1 Lh s2<=Sum(sc map a s1 s2)"))
(assume "sc" "a" "s1" "s2" "H1")
(inversion "H1")
(assume "a1")
