(* Author: Dmitriy Traytel *)

theory M2L_Examples
imports M2L_Equivalence_Checking "HOL-Library.Char_ord"
    "HOL-Library.Product_Lexorder"
begin

abbreviation FALSE where "FALSE \<equiv> FExists (FLess 0 0)"
abbreviation TRUE where "TRUE \<equiv> FNot FALSE"
abbreviation All where "All \<phi> \<equiv> FNot (FExists (FNot \<phi>))"
abbreviation AL where "AL \<phi> \<equiv> FNot (FEXISTS (FNot \<phi>))"
abbreviation Imp where "Imp \<phi> \<psi> \<equiv> FOr (FNot \<phi>) \<psi>"
abbreviation Iff where "Iff \<phi> \<psi> \<equiv> FAnd (Imp \<phi> \<psi>) (Imp \<psi> \<phi>)"
abbreviation Ball where "Ball X \<phi> \<equiv> All (Imp (FIn 0 (X+1)) \<phi>)"
abbreviation Bex where "Bex X \<phi> \<equiv> FExists (FAnd (FIn 0 (X+1)) \<phi>)"

abbreviation Eq where "Eq x y \<equiv> FAnd (FNot (FLess x y)) (FNot (FLess y x))"
abbreviation SUBSET where "SUBSET X Y \<equiv> Ball X (FIn 0 (Y+1))"
abbreviation EQ where "EQ X Y \<equiv> FAnd (SUBSET X Y) (SUBSET Y X)"
abbreviation First where "First x \<equiv> FNot (FExists (FLess 0 (x+1)))"
abbreviation Last where "Last x \<equiv> FNot (FExists (FLess (x+1) 0))"
abbreviation Suc where "Suc sucx x \<equiv> FAnd (FLess x sucx) (FNot (FExists (FAnd (FLess (x+1) 0) (FLess 0 (sucx+1)))))"

definition "Thm (type :: 'a :: {enum, linorder} itself) n \<phi> = fast.check_eqv n (FNot \<phi> :: 'a formula) FALSE"
definition "Thm_slow (type :: 'a :: {enum, linorder} itself) n \<phi> = slow.check_eqv n (FNot \<phi> :: 'a formula) FALSE"
definition "Thm_dual (type :: 'a :: {enum, linorder} itself) n \<phi> = dual.check_eqv n (FNot \<phi> :: 'a formula) FALSE"

definition "M2L = (FEXISTS (All (FIn 0 1)) :: Enum.finite_1 formula)"

lemma "Thm TYPE(Enum.finite_1) 0 M2L" by eval
lemma "Thm TYPE(Enum.finite_1) 0 (FNot (All (FExists (FLess 1 0))))" by eval
lemma "Thm (TYPE(bool)) 0 (FNot (FExists (FExists (FAnd (FLess 0 1) (FLess 1 0)))))" by eval
lemma Drinker: "Thm (TYPE(bool)) 1 (FExists (Imp (FIn 0 1) (All (FIn 0 2))))" by eval
lemma "Thm (TYPE(bool)) 1 (Imp (All (FIn 0 1)) (FExists (FIn 0 1)))" by eval

(*
definition "mod_two a b c d = Iff a (Iff b (Iff c d))"
definition "at_least_two a b c d = Iff d (FOr (FAnd a b) (FOr (FAnd b c) (FAnd a c)))"

definition "ADD S A B = FEXISTS (FAnd (All (Imp (First 0) (FNot (FIn 0 1))))
  (All (FAnd (mod_two (FIn 0 (A+2)) (FIn 0 (B+2)) (FIn 0 1) (FIn 0 (S+2)))
       (Imp (FExists (FAnd (Last 0) (FLess 1 0)))
            (at_least_two (FIn 0 (A+2)) (FIn 0 (B+2)) (FIn 0 1) (All (Imp (Suc 0 1) (FIn 0 2))))))))"

definition Comm_Lemma :: "Enum.finite_1 formula" where
  "Comm_Lemma = AL (AL (FEXISTS (FAnd (ADD 0 1 2) (FEXISTS (FAnd (ADD 0 3 2) (EQ 0 1))))))"

lemma "Thm TYPE(bool) 0 (AL (AL (FEXISTS (ADD 0 1 2))))"
  by eval

lemma "Thm TYPE(Enum.finite_1) 0 Comm_Lemma"
  by eval
*)

abbreviation Globally ("\<box>_" [40] 40) where "Globally P == %n. All (Imp (FNot (FLess (n+1) 0)) (P 0))"
abbreviation Future ("\<diamond>_" [40] 40) where "Future P == %n. FExists (FAnd (FNot (FLess (n+1) 0)) (P 0))"
abbreviation IMP (infixr "\<rightarrow>" 50) where "IMP P1 P2 == %n. Imp (P1 n) (P2 n)"

abbreviation "FOR xs n \<equiv> rexp_of_list FOr FALSE (map (\<lambda>x. FQ x n) xs)"

abbreviation \<Phi>0 :: "bool formula" where "\<Phi>0 \<equiv>
  (All (((\<box>(FOR [(True)])) \<rightarrow> (\<box>(FOR [(True)]))) 0))"

abbreviation \<Phi>1 :: "(bool \<times> bool) formula" where "\<Phi>1 \<equiv>
  (All (((\<box>(FOR [(True, True), (True, False)] \<rightarrow>
            FOR [(True, True), (False, True)])) \<rightarrow>
         (\<box>(FOR [(True, True), (True, False)])) \<rightarrow>
         (\<box>(FOR [(True, True), (False, True)]))) 0))"

abbreviation \<Phi>2 :: "(bool \<times> bool \<times> bool) formula" where "\<Phi>2 \<equiv>
  (All (((\<box>(FOR [(True, True, True), (True, True, False), (True, False, True), (True, False, False)] \<rightarrow>
            FOR [(True, True, True), (True, True, False), (False, True, True), (False, True, False)] \<rightarrow>
            FOR [(True, True, True), (True, False, True), (False, True, True), (False, False, True)])) \<rightarrow>
        (\<box>(FOR [(True, True, True), (True, True, False), (True, False, True), (True, False, False)])) \<rightarrow>
        (\<box>(FOR [(True, True, True), (True, True, False), (False, True, True), (False, True, False)])) \<rightarrow>
        (\<box>(FOR [(True, True, True), (True, True, False), (False, True, True), (False, True, False)]))) 0))"

definition \<Psi> :: "nat \<Rightarrow> Enum.finite_1 formula" where
  "\<Psi> n = All (((\<box>(foldr (\<lambda>i \<phi>. (\<lambda>m. FIn m (2 + i)) \<rightarrow> \<phi>) [0..<n] (\<lambda>m. FIn m (n + 2)))) \<rightarrow>
     foldr (\<lambda>i \<phi>. (\<box>(\<lambda>m. FIn m (2 + i))) \<rightarrow> \<phi>) [0..<n] (\<box>(\<lambda>m. FIn m (n + 2)))) 0)"

definition "Thm1 n = Thm (TYPE(Enum.finite_1)) (n + 1) (\<Psi> n)"
definition "Thm1_slow n = Thm_slow (TYPE(Enum.finite_1)) (n + 1) (\<Psi> n)"
definition "Thm1_dual n = Thm_dual (TYPE(Enum.finite_1)) (n + 1) (\<Psi> n)"

lemma "Thm1 0" by eval
lemma "Thm1 1" by eval
lemma "Thm1 2" by eval

lemma "Thm (TYPE(bool)) 0 \<Phi>0" by eval
lemma "Thm (TYPE(bool * bool)) 0 \<Phi>1" by eval
lemma "Thm (TYPE(bool * bool * bool)) 0 \<Phi>2" by eval

(*
export_code Thm1 Nat in SML module_name M2L_Thm1 file "M2L_Thm1.ML"
export_code Thm1_slow Nat in SML module_name M2L_Thm1_slow file "M2L_Thm1_slow.ML"
export_code Thm1_dual Nat in SML module_name M2L_Thm1_dual file "M2L_Thm1_dual.ML"

ML_file "M2L_Thm1.ML"
ML_file "M2L_Thm1_slow.ML"
ML_file "M2L_Thm1_dual.ML"

ML {* PolyML.timing true; open M2L_Thm1; thm1 (Nat 0); thm1 (Nat 1); thm1 (Nat 2); thm1 (Nat 3); *}
ML {* PolyML.timing true; open M2L_Thm1_dual; thm1_dual (Nat 0); thm1_dual (Nat 1); thm1_dual (Nat 2); thm1_dual (Nat 3); *}
ML {* PolyML.timing true; open M2L_Thm1_slow; thm1_slow (Nat 0); thm1_slow (Nat 1); thm1_slow (Nat 2); *}
*)
end


section "Small-Step Semantics of Commands"

theory Small_Step imports "~~/src/HOL/IMP/Star" "./Big_Step" begin

subsection "The transition relation"

inductive
  small_step :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "(x ::= a, s) \<rightarrow> (SKIP, s(x := aval a s))" |

Seq1:    "(SKIP;;c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |
Seq2:    "(c\<^sub>1,s) \<rightarrow> (c\<^sub>1',s') \<Longrightarrow> (c\<^sub>1;;c\<^sub>2,s) \<rightarrow> (c\<^sub>1';;c\<^sub>2,s')" |

IfTrue:  "bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>1,s)" |
IfFalse: "\<not>bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |

While:   "(WHILE b DO c,s) \<rightarrow>
            (IF b THEN c;; WHILE b DO c ELSE SKIP,s)" |

Or1:     "(a OR b, s) \<rightarrow> (a, s)" |
Or2:     "(a OR b, s) \<rightarrow> (b, s)"

abbreviation
  small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step x y"

subsection{* Executability *}

code_pred small_step .

values "{(c',map t [''x'',''y'',''z'']) |c' t.
   (''x'' ::= V ''z'';; ''y'' ::= V ''x'',
    <''x'' := 3, ''y'' := 7, ''z'' := 5>) \<rightarrow>* (c',t)}"

subsection{* Proof infrastructure *}

subsubsection{* Induction rules *}

text{* The default induction rule @{thm[source] small_step.induct} only works
for lemmas of the form @{text"a \<rightarrow> b \<Longrightarrow> \<dots>"} where @{text a} and @{text b} are
not already pairs @{text"(DUMMY,DUMMY)"}. We can generate a suitable variant
of @{thm[source] small_step.induct} for pairs by ``splitting'' the arguments
@{text"\<rightarrow>"} into pairs: *}
lemmas small_step_induct = small_step.induct[split_format(complete)]

subsubsection{* Proof automation *}

declare small_step.intros[simp,intro]

text{* Rule inversion: *}

inductive_cases SkipE[elim!]: "(SKIP,s) \<rightarrow> ct"
thm SkipE
inductive_cases AssignE[elim!]: "(x::=a,s) \<rightarrow> ct"
thm AssignE
inductive_cases SeqE[elim]: "(c1;;c2,s) \<rightarrow> ct"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<rightarrow> ct"
inductive_cases OrE[elim!]: "(a OR b, s) \<rightarrow> ct"
inductive_cases WhileE[elim]: "(WHILE b DO c, s) \<rightarrow> ct"

subsection "Equivalence with big-step semantics"

lemma star_seq2: "(c1,s) \<rightarrow>* (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow>* (c1';;c2,s')"
proof(induction rule: star_induct)
  case refl thus ?case by simp
next
  case step
  thus ?case by (metis Seq2 star.step)
qed

lemma seq_comp:
  "\<lbrakk> (c1,s1) \<rightarrow>* (SKIP,s2); (c2,s2) \<rightarrow>* (SKIP,s3) \<rbrakk>
   \<Longrightarrow> (c1;;c2, s1) \<rightarrow>* (SKIP,s3)"
by(blast intro: star.step star_seq2 star_trans)

text{* The following proof corresponds to one on the board where one would
show chains of @{text "\<rightarrow>"} and @{text "\<rightarrow>*"} steps. *}

lemma big_to_small:
  "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
proof (induction rule: big_step.induct)
  fix s show "(SKIP,s) \<rightarrow>* (SKIP,s)" by simp
next
  fix x a s show "(x ::= a,s) \<rightarrow>* (SKIP, s(x := aval a s))" by auto
next
  fix c1 c2 s1 s2 s3
  assume "(c1,s1) \<rightarrow>* (SKIP,s2)" and "(c2,s2) \<rightarrow>* (SKIP,s3)"
  thus "(c1;;c2, s1) \<rightarrow>* (SKIP,s3)" by (rule seq_comp)
next
  fix s::state and b c0 c1 t
  assume "bval b s"
  hence "(IF b THEN c0 ELSE c1,s) \<rightarrow> (c0,s)" by simp
  moreover assume "(c0,s) \<rightarrow>* (SKIP,t)"
  ultimately
  show "(IF b THEN c0 ELSE c1,s) \<rightarrow>* (SKIP,t)" by (metis star.simps)
next
  fix s::state and b c0 c1 t
  assume "\<not>bval b s"
  hence "(IF b THEN c0 ELSE c1,s) \<rightarrow> (c1,s)" by simp
  moreover assume "(c1,s) \<rightarrow>* (SKIP,t)"
  ultimately
  show "(IF b THEN c0 ELSE c1,s) \<rightarrow>* (SKIP,t)" by (metis star.simps)
next
  fix b c and s::state
  assume b: "\<not>bval b s"
  let ?if = "IF b THEN c;; WHILE b DO c ELSE SKIP"
  have "(WHILE b DO c,s) \<rightarrow> (?if, s)" by blast
  moreover have "(?if,s) \<rightarrow> (SKIP, s)" by (simp add: b)
  ultimately show "(WHILE b DO c,s) \<rightarrow>* (SKIP,s)" by(metis star.refl star.step)
next
  fix b c s s' t
  let ?w  = "WHILE b DO c"
  let ?if = "IF b THEN c;; ?w ELSE SKIP"
  assume w: "(?w,s') \<rightarrow>* (SKIP,t)"
  assume c: "(c,s) \<rightarrow>* (SKIP,s')"
  assume b: "bval b s"
  have "(?w,s) \<rightarrow> (?if, s)" by blast
  moreover have "(?if, s) \<rightarrow> (c;; ?w, s)" by (simp add: b)
  moreover have "(c;; ?w,s) \<rightarrow>* (SKIP,t)" by(rule seq_comp[OF c w])
  ultimately show "(WHILE b DO c,s) \<rightarrow>* (SKIP,t)" by (metis star.simps)
next
  case (Or1 a s1 s2 b)
  have "(a OR b, s1) \<rightarrow>* (a, s1)" by auto
  moreover have "(a, s1) \<rightarrow>* (SKIP, s2)" using Or1.IH by auto
  ultimately show ?case by (metis star_trans)
next
  case (Or2 b s1 s2 a)
  have "(a OR b, s1) \<rightarrow>* (b, s1)" by auto
  moreover have "(b, s1) \<rightarrow>* (SKIP, s2)" using Or2.IH by auto
  ultimately show ?case by (metis star_trans)
qed

text{* Each case of the induction can be proved automatically: *}
lemma  "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
proof (induction rule: big_step.induct)
  case Skip show ?case by blast
next
  case Assign show ?case by blast
next
  case Seq thus ?case by (blast intro: seq_comp)
next
  case IfTrue thus ?case by (blast intro: star.step)
next
  case IfFalse thus ?case by (blast intro: star.step)
next
  case WhileFalse thus ?case
    by (metis star.step star_step1 small_step.IfFalse small_step.While)
next
  case WhileTrue
  thus ?case
    by(metis While seq_comp small_step.IfTrue star.step[of small_step])
next
  case Or1
  thus ?case by (metis star.step small_step.Or1)
next
  case Or2
  thus ?case by (metis star.step small_step.Or2)
qed

lemma small1_big_continue:
  "cs \<rightarrow> cs' \<Longrightarrow> cs' \<Rightarrow> t \<Longrightarrow> cs \<Rightarrow> t"
apply (induction arbitrary: t rule: small_step.induct)
apply auto
done

lemma small_to_big:
  "cs \<rightarrow>* (SKIP,t) \<Longrightarrow> cs \<Rightarrow> t"
apply (induction cs "(SKIP,t)" rule: star.induct)
apply (auto intro: small1_big_continue)
done

text {*
  Finally, the equivalence theorem:
*}
theorem big_iff_small:
  "cs \<Rightarrow> t = cs \<rightarrow>* (SKIP,t)"
by(metis big_to_small small_to_big)

subsection "Final configurations and infinite reductions"

definition "final cs \<longleftrightarrow> \<not>(EX cs'. cs \<rightarrow> cs')"

lemma finalD: "final (c,s) \<Longrightarrow> c = SKIP"
apply(simp add: final_def)
apply(induction c)
apply blast+
done

lemma final_iff_SKIP: "final (c,s) = (c = SKIP)"
by (metis SkipE finalD final_def)

text{* Now we can show that @{text"\<Rightarrow>"} yields a final state iff @{text"\<rightarrow>"}
terminates: *}

lemma big_iff_small_termination:
  "(EX t. cs \<Rightarrow> t) \<longleftrightarrow> (EX cs'. cs \<rightarrow>* cs' \<and> final cs')"
by(simp add: big_iff_small final_iff_SKIP)

text{* This is the same as saying that the absence of a big step result is
equivalent with absence of a terminating small step sequence, i.e.\ with
nontermination.  Since @{text"\<rightarrow>"} is determininistic, there is no difference
between may and must terminate. *}

end