; $Id: warshall.scm,v 1.5 2008/01/25 13:30:22 logik Exp $

; (mload "mpc.scm")

; (pf "MPC; INCLUDE \"/home/schwicht/minlog/examples/warshall/warshall.mpc\";")

; (set! COMMENT-STRING "; ")

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

(add-var-name "a" "b" "c" "d" "e" "i" "j" "k" (py "nat"))
(add-var-name "x" "y" "z" (py "list nat"))
(add-var-name "r" (py "nat=>nat=>boole"))

(add-program-constant "In" (py "nat=>(list nat)=>boole") 1 'const 2)

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

(add-display
 (py "boole")
 (lambda (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=? "In"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 2 (length args)))
	 (list 'rel-op "in"
	       (term-to-token-tree (car args))
	       (term-to-token-tree (cadr args)))
	 #f))))

(add-computation-rule (pt " a in (Nil nat)") (pt "False"))
(add-computation-rule (pt " a in (b::x)") (pt "[if (a=b) True (a in x)]"))

(add-program-constant
 "Path" (py "(nat=>nat=>boole)=>nat=>(list nat)=>nat=>nat=>boole") 1 'const 5)

(add-computation-rule (pt "Path r i (a:) b c") (pt "[if (a=b) (b=c) False]"))

(add-computation-rule
 (pt "Path r i (a::d:) b c")
 (pt "[if (a=b) [if (d=c) (r a d) False ]  False]"))

(add-computation-rule
 (pt "Path r i (a::d::e::x) b c")
 (pt "[if (a=b) 
	  [if (r a d) 
              [if (d<i) (Path r i (d::e::x) d c) False] False ] False]"))

(add-program-constant "Rf" (py "(list nat)=>boole") 1 'const 1)

(add-computation-rule (pt "Rf (Nil nat)") (pt "True"))
(add-computation-rule (pt "Rf (a::x)") (pt "[if (a in x) False (Rf x)]"))

(add-program-constant
 "Dot" (py "(list nat)=>(list nat)=>(list nat)") 1 'const 2)

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

(add-display
 (py "list nat")
 (lambda (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=? "Dot"
			(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))))

(add-computation-rule (pt "(Nil nat) | x") (pt "x"))
(add-computation-rule (pt "(a:) | (Nil nat)") (pt "a:"))
(add-computation-rule (pt "(a:) | (b::x)") (pt "[if (a=b) (b::x) (Nil nat)]"))
(add-computation-rule (pt "(a::d::x) | y") (pt "a::(d::x | y)"))

; For (simp) we need Atom-False: all boole.(boole -> F) -> boole=False

; (set-goal (pf "all boole.(boole -> F) -> boole=False"))
; (ind)
; (ng)
; (prop)
; (ng)
; (prop)
; (save "Atom-False")

(set-goal (pf "all r,i,j,k ex x. 
                (x=(Nil nat) -> all y.Path r i y j k -> F) &
                ((x=(Nil nat) -> F) -> Path r i x j k & Rf x)"))

(assume "r")
(ind)

; Base
(assume "j" "k")

(cases (pt "j=k"))

; Case j=k
(assume "j=k")
(ex-intro (pt "j:"))
(split)
(assume 2 "y")
(prop)
(prop)

; Case j\ne k
(cases (pt "r j k"))

; Case r j k
(assume "rjk" "jnek")
(ex-intro (pt "j::k:"))
(split)
(search)

(ng)
(simp "jnek")
(ng)
(prop)

; Case r j k -> F            
(assume "negrjk" "jnek")
(ex-intro (pt "(Nil nat)"))
(split)
(ng)

(aga "Rf0pfad" (pf "all r,x,j,k.Path r 0 x j k -> (j=k -> F) -> r j k"))

(assume 3 "y" 4)
(use "negrjk")
(use-with "Rf0pfad" (pt "r") (pt "y") (pt "j") (pt "k") 4 2)

(ng)
(prop)

; Step
(assume "i" 1 "j" "k")
; We want to use the induction hypothesis for j,k

(ex-elim (pf "ex x.(x=(Nil nat) -> all y.Path r i y j k -> F) & ((x=(Nil nat) -> F) -> Path r i x j k & Rf x)"))
; use the IH
(use 1) 

(assume "x1" 2)
(cases (pt "x1=(Nil nat)"))

; Case x1=(Nil nat)
(assume 3)
; We want to use the induction hypothesis for j,i
(ex-elim (pf "ex x.(x=(Nil nat) -> all y.Path r i y j i -> F) & ((x=(Nil nat) -> F) -> Path r i x j i & Rf x)"))
; use the IH
(use 1)

(assume "x2" 4)
; We also want to use the induction hypothesis for i,k
(ex-elim (pf "ex x.(x=(Nil nat) -> all y.Path r i y i k -> F) & ((x=(Nil nat) -> F) -> Path r i x i k & Rf x)"))
; use the IH
(use 1)

(assume "x3" 5)

(cases (pt "x2=(Nil nat)"))
; Subcase x2=(Nil nat)
(assume 6)
(ex-intro (pt "(Nil nat)"))
(split)
(assume 7 "y" 8)

(aga "pfadzerl1" (pf "all r,i1,x,i,j,k.Path r(i1+1)x j k -> 
  (Path r i1 x j k -> F) -> (all y.Path r i1 y j i -> F) -> F"))
(use-with "pfadzerl1"  (pt "r") (pt "i") (pt "y") (pt "i") (pt "j") (pt "k")
	  8 DEFAULT-GOAL-NAME DEFAULT-GOAL-NAME)
(use-with 2 'left 3 (pt "y"))
(use-with 4 'left 6)

(prop)

; Subcase x2 \ne (Nil nat)
(assume 6)
(cases (pt "x3=(Nil nat)"))

; UUFall x3=(Nil nat)
(assume 7)
(ex-intro (pt "(Nil nat)"))
(split)
(assume 8)
(assume "y" 9)
(aga "pfadzerl2" (pf "all r,i1,x,i,j,k.Path r(i1+1)x j k -> 
  (Path r i1 x j k -> F) -> (all z.Path r i1 z i k -> F) -> F"))
(use-with "pfadzerl2" (pt "r") (pt "i") (pt "y") (pt "i") (pt "j") (pt "k")
	  9 DEFAULT-GOAL-NAME DEFAULT-GOAL-NAME)
(use-with 2 'left 3 (pt "y"))
(use-with 5 'left 7)
(prop)

; UUFall x3\ne (Nil nat)
(assume 7)
(ex-intro (pt "x2 | x3"))
(split)
(assume 8)

(aga "dotdef" (pf "all r,i,j,k,x2,x3.(x2=(Nil nat) -> F) ->
  (x3=(Nil nat) -> F) -> Path r i x2 j i -> Path r i x3 i k
  -> (x2 | x3)=(Nil nat) -> F"))
(assume "y" 9)
(use-with "dotdef" (pt "r") (pt "i") (pt "j") (pt "k") (pt "x2") (pt "x3")
	  6 7 DEFAULT-GOAL-NAME DEFAULT-GOAL-NAME 8)
(prop)
(prop)

; Fall x2 | x3 \ne (Nil nat), i.e. defined
(assume 8)
(split)
(aga "pfaddot" (pf "all r,i,j,k,x2,x3.Path r i x2 j i ->
  Path r i x3 i k -> Path r(i+1)(x2 | x3)j k"))
(use-with "pfaddot" (pt "r") (pt "i") (pt "j") (pt "k") (pt "x2") (pt "x3")
	  DEFAULT-GOAL-NAME DEFAULT-GOAL-NAME)
(prop)
(prop)
(aga "Rfdot" (pf "all r,i,j,k,x2,x3.Path r i x2 j i ->
  Rf x2 -> Path r i x3 i k -> Rf x3 -> 
  (all z.Path r i z j k -> F) -> Rf(x2 | x3)"))
(use-with "Rfdot" (pt "r") (pt "i") (pt "j") (pt "k") (pt "x2") (pt "x3")
	  DEFAULT-GOAL-NAME DEFAULT-GOAL-NAME DEFAULT-GOAL-NAME
	  DEFAULT-GOAL-NAME DEFAULT-GOAL-NAME)
(prop)
(prop)
(prop)
(prop)
(use-with 2 'left 3)

; Fall x1 definiert.
(assume 3)
(ex-intro (pt "x1"))
(split)
(search)
(assume 4)
(split)

(aga "pfadlift" (pf "all r,i,j,k,x1.Path r i x1 j k -> Path r(i+1)x1 j k"))
(use-with "pfadlift" (pt "r") (pt "i") (pt "j") (pt "k") (pt "x1")
	  DEFAULT-GOAL-NAME)
(use-with 2 'right 3 'left)
(use-with 2 'right 3 'right)

(define proof (pproof-state-to-proof))
(define expr (proof-to-expr proof))

(define nproof (np proof))
(define nexpr (proof-to-expr nproof))

(define eterm (proof-to-extracted-term nproof))
(define neterm (nt eterm))
; (term-to-string neterm)

; With renaming of bound variables, and indentation

; [r](Rec nat=>nat=>nat=>list nat)
; ([j,k][if (j=k) (j:) [if (r j k) (j::k:) (Nil nat)]])
; ([i,f,j,k] [if (f j k=(Nil nat))
; 	       [if (f j i=(Nil nat))
; 		   (Nil nat)
; 		   [if (f i k=(Nil nat)) (Nil nat) (f j i|f i k)]]
; 	       (f j k)])

; In Minlog3 we had:

; Mit (dt (nt (et (np pproof)))) erhaelt man dann:

;[r00132]nat-rec([n00134,n00135][if n00134=n00135 then con n00134 eps else [if r00132 n00134 n00135 then con n00134(con n00135 eps) else (Nil nat)]])([n00136,nat=>nat=>seq00137,n00138,n00139][if (nat=>nat=>seq00137 n00138 n00139)=(Nil nat) then [if (nat=>nat=>seq00137 n00138 n00136)=(Nil nat) then (Nil nat) else [if (nat=>nat=>seq00137 n00136 n00139)=(Nil nat) then (Nil nat) else dot(nat=>nat=>seq00137 n00138 n00136)(nat=>nat=>seq00137 n00136 n00139)]] else nat=>nat=>seq00137 n00138 n00139])

; Mit Umbenennung der gebundenen Variablen (^ weggelassen):

;[r]nat-rec
;([j,k][if j=k then con j eps else 
;      [if r j k then con j(con k eps) else (Nil nat)]])
;([i,f,j,k][if (f j k)=(Nil nat) then 
;            [if (f j i)=(Nil nat) then (Nil nat) else 
;            [if (f i k)=(Nil nat) then (Nil nat) else (f j i) | (f i k)]]
;           else f j k])
