section \<open>Semantics of IMP\<close>
theory Semantics
imports Syntax "HOL-Eisbach.Eisbach_Tools"
begin

subsection \<open>State\<close>
text \<open>The state maps variable names to values\<close>
type_synonym state = "vname \<Rightarrow> val"

text \<open>We introduce some syntax for the null state, and a state where only certain
  variables are set.\<close>
definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. \<lambda>i. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

subsubsection \<open>State Combination\<close>
text \<open>The state combination operator constructs a state by
  taking the local variables from one state, and the globals from another state.\<close>

definition combine_states :: "state \<Rightarrow> state \<Rightarrow> state" ("<_|_>" [0,0] 1000)
  where "<s|t> n = (if is_local n then s n else t n)"

text \<open>We prove some basic facts.

Note that we use Isabelle's context command to locally declare the
  definition of @{const combine_states} as simp lemma, such that it is
  unfolded automatically.\<close>

context notes [simp] = combine_states_def begin

lemma combine_collapse: "<s|s> = s" by auto

lemma combine_nest:
  "<s|<s'|t>> = <s|t>"
  "<<s|t'>|t> = <s|t>"
  by auto

lemma combine_query:
  "is_local x \<Longrightarrow> <s|t> x = s x"
  "is_global x \<Longrightarrow> <s|t> x = t x"
  by auto

lemma combine_upd:
  "is_local x \<Longrightarrow> <s|t>(x:=v) = <s(x:=v)|t>"
  "is_global x \<Longrightarrow> <s|t>(x:=v) = <s|t(x:=v)>"
  by auto

lemma combine_cases[cases type]:
  obtains l g where "s = <l|g>"
  by (fastforce)

end

subsection \<open>Arithmetic Expressions\<close>
text \<open>The evaluation of arithmetic expressions is straightforward. \<close>
fun aval :: "aexp \<Rightarrow> state \<Rightarrow> pval" where
  "aval (N n) s = n"
| "aval (Vidx x i) s = s x (aval i s)"
| "aval (Unop f a\<^sub>1) s = f (aval a\<^sub>1 s)"
| "aval (Binop f a\<^sub>1 a\<^sub>2) s = f (aval a\<^sub>1 s) (aval a\<^sub>2 s)"

subsection \<open>Boolean Expressions\<close>
text \<open>The evaluation of Boolean expressions is straightforward. \<close>

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
  "bval (Bc v) s = v"
| "bval (Not b) s = (\<not> bval b s)"
| "bval (BBinop f b\<^sub>1 b\<^sub>2) s = f (bval b\<^sub>1 s) (bval b\<^sub>2 s)"
| "bval (Cmpop f a\<^sub>1 a\<^sub>2) s = f (aval a\<^sub>1 s) (aval a\<^sub>2 s)"

subsection \<open>Big-Step Semantics\<close>
text \<open>The big-step semantics is a relation from commands and start states to end states,
  such that there is a terminating execution.

  If there is no such execution, no end state will be related to the command and start state.
  This either means that the program does not terminate, or gets stuck because it tries to call
  an undefined procedure.

  The inference rules of the big-step semantics are pretty straightforward.
\<close>

inductive big_step :: "program \<Rightarrow> com \<times> state \<Rightarrow> state \<Rightarrow> bool"
  ("_: _ \<Rightarrow> _" [1000,55,55] 55)
where
  \<comment> \<open>No-Op\<close>
  Skip: "\<pi>:(SKIP,s) \<Rightarrow> s"

  \<comment> \<open>Assignments\<close>
| AssignIdx: "\<pi>:(x[i] ::= a,s) \<Rightarrow> s(x := (s x)(aval i s := aval a s))"
| ArrayCpy: "\<pi>:(x[] ::= y,s) \<Rightarrow> s(x := s y)"
| ArrayClear: "\<pi>:(CLEAR x[],s) \<Rightarrow> s(x := (\<lambda>_. 0))"
| Assign_Locals: "\<pi>:(Assign_Locals l,s) \<Rightarrow> <l|s>"

  \<comment> \<open>Block commands\<close>
| Seq: "\<lbrakk> \<pi>:(c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  \<pi>:(c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> \<pi>:(c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3"
| IfTrue: "\<lbrakk> bval b s; \<pi>:(c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> \<pi>:(IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t"
| IfFalse: "\<lbrakk> \<not>bval b s;  \<pi>:(c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> \<pi>:(IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t"
| Scope: "\<lbrakk> \<pi>:(c,<<>|s>) \<Rightarrow> s' \<rbrakk> \<Longrightarrow> \<pi>:(SCOPE c, s) \<Rightarrow> <s|s'>"
| WhileFalse: "\<not>bval b s \<Longrightarrow> \<pi>:(WHILE b DO c,s) \<Rightarrow> s"
| WhileTrue: "\<lbrakk> bval b s\<^sub>1;  \<pi>:(c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  \<pi>:(WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
    \<Longrightarrow> \<pi>:(WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3"

  \<comment> \<open>Procedure commands\<close>
| PCall: "\<lbrakk> \<pi> p = Some c; \<pi>:(c,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> \<pi>:(PCall p,s) \<Rightarrow> t"
| PScope: "\<lbrakk> \<pi>':(c,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> \<pi>:(PScope \<pi>' c, s) \<Rightarrow> t"

subsubsection \<open>Proof Automation\<close>
text \<open>
  We do some setup to make proofs over the big-step semantics more automatic.
\<close>

declare big_step.intros [intro]
lemmas big_step_induct[induct set] = big_step.induct[split_format(complete)]

inductive_simps Skip_simp: "\<pi>:(SKIP,s) \<Rightarrow> t"
inductive_simps AssignIdx_simp: "\<pi>:(x[i] ::= a,s) \<Rightarrow> t"
inductive_simps ArrayCpy_simp: "\<pi>:(x[] ::= y,s) \<Rightarrow> t"
inductive_simps ArrayInit_simp: "\<pi>:(CLEAR x[],s) \<Rightarrow> t"
inductive_simps AssignLocals_simp: "\<pi>:(Assign_Locals l,s) \<Rightarrow> t"

inductive_simps Seq_simp: "\<pi>:(c1;;c2,s1) \<Rightarrow> s3"
inductive_simps If_simp: "\<pi>:(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
inductive_simps Scope_simp: "\<pi>:(SCOPE c,s) \<Rightarrow> t"
inductive_simps PCall_simp: "\<pi>:(PCall p,s) \<Rightarrow> t"
inductive_simps PScope_simp: "\<pi>:(PScope \<pi>' p,s) \<Rightarrow> t"

lemmas big_step_simps =
  Skip_simp AssignIdx_simp ArrayCpy_simp ArrayInit_simp
  Seq_simp If_simp Scope_simp PCall_simp PScope_simp

inductive_cases SkipE[elim!]: "\<pi>:(SKIP,s) \<Rightarrow> t"
inductive_cases AssignIdxE[elim!]: "\<pi>:(x[i] ::= a,s) \<Rightarrow> t"
inductive_cases ArrayCpyE[elim!]: "\<pi>:(x[] ::= y,s) \<Rightarrow> t"
inductive_cases ArrayInitE[elim!]: "\<pi>:(CLEAR x[],s) \<Rightarrow> t"
inductive_cases AssignLocalsE[elim!]: "\<pi>:(Assign_Locals l,s) \<Rightarrow> t"

inductive_cases SeqE[elim!]: "\<pi>:(c1;;c2,s1) \<Rightarrow> s3"
inductive_cases IfE[elim!]: "\<pi>:(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
inductive_cases ScopeE[elim!]: "\<pi>:(SCOPE c,s) \<Rightarrow> t"
inductive_cases PCallE[elim!]: "\<pi>:(PCall p,s) \<Rightarrow> t"
inductive_cases PScopeE[elim!]: "\<pi>:(PScope \<pi>' p,s) \<Rightarrow> t"

inductive_cases WhileE[elim]: "\<pi>:(WHILE b DO c,s) \<Rightarrow> t"

subsubsection \<open>Automatic Derivation\<close>
  (* TODO: More comments, test *)
  (* Testing the programs by constructing big-step derivations automatically *)

  (* This rule is used to enforce simplification of the newly generated state, before passing it on *)
  lemma Assign': "s' = s(x := (s x)(aval i s := aval a s)) \<Longrightarrow> \<pi>:(x[i] ::= a, s) \<Rightarrow> s'" by auto
  lemma ArrayCpy': "s' = s(x := (s y)) \<Longrightarrow> \<pi>:(x[] ::= y, s) \<Rightarrow> s'" by auto
  lemma ArrayClear': "s' = s(x := (\<lambda>_. 0)) \<Longrightarrow> \<pi>:(CLEAR x[], s) \<Rightarrow> s'" by auto

  lemma Scope': "s\<^sub>1 = <<>|s> \<Longrightarrow> \<pi>:(c,s\<^sub>1) \<Rightarrow> t \<Longrightarrow> t' = <s|t> \<Longrightarrow> \<pi>:(Scope c,s) \<Rightarrow> t'" by auto

  named_theorems deriv_unfolds \<open>Unfold rules before derivations\<close>

  method bs_simp = simp add: combine_nest combine_upd combine_query fun_upd_same fun_upd_other del: fun_upd_apply

  method big_step' =
    rule Skip Seq PScope
  | (rule Assign' ArrayCpy' ArrayClear', (bs_simp;fail))
  | (rule IfTrue IfFalse WhileTrue WhileFalse PCall Scope'), (bs_simp;fail)
  | unfold deriv_unfolds
  | (bs_simp; fail)

  method big_step =
    rule Skip
  | rule Seq, (big_step;fail), (big_step;fail)
  | rule PScope, (big_step;fail)
  | (rule Assign' ArrayCpy' ArrayClear', (bs_simp;fail))
  | (rule IfTrue IfFalse), (bs_simp;fail), (big_step;fail)
  | rule WhileTrue, (bs_simp;fail), (big_step;fail), (big_step;fail)
  | rule WhileFalse, (bs_simp;fail)
  | rule PCall, (bs_simp;fail), (big_step;fail)
  | (rule Scope', (bs_simp;fail), (big_step;fail), (bs_simp;fail))
  | unfold deriv_unfolds, big_step

  schematic_goal "Map.empty: (
    ''a'' ::= N 1;;
    WHILE Cmpop (\<lambda>x y. y < x) (V ''n'') (N 0) DO (
      ''a'' ::= Binop (+) (V ''a'') (V ''a'');;
      ''n'' ::= Binop (-) (V ''n'') (N 1)
    ),<''n'':=(\<lambda>_. 5)>) \<Rightarrow> ?s"
    by big_step

subsection \<open>Command Equivalence\<close>

text \<open>Two commands are equivalent if they have the same semantics.\<close>
definition
  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
  "c \<sim> c' \<equiv> (\<forall>\<pi> s t. \<pi>:(c,s) \<Rightarrow> t  = \<pi>:(c',s) \<Rightarrow> t)"

lemma equivI[intro?]: "\<lbrakk>
  \<And>s t \<pi>. \<pi>:(c,s) \<Rightarrow> t \<Longrightarrow> \<pi>:(c',s) \<Rightarrow> t;
  \<And>s t \<pi>. \<pi>:(c',s) \<Rightarrow> t \<Longrightarrow> \<pi>:(c,s) \<Rightarrow> t\<rbrakk>
  \<Longrightarrow> c \<sim> c'"
  by (auto simp: equiv_c_def)

lemma equivD[dest]: "c \<sim> c' \<Longrightarrow> \<pi>:(c,s) \<Rightarrow> t \<longleftrightarrow> \<pi>:(c',s) \<Rightarrow> t"
  by (auto simp: equiv_c_def)

text \<open>Command equivalence is an equivalence relation, i.e.\ it is
reflexive, symmetric, and transitive.\<close>

lemma equiv_refl[simp, intro!]:  "c \<sim> c"
  by (blast intro: equivI)
lemma equiv_sym[sym]:   "(c \<sim> c') \<Longrightarrow> (c' \<sim> c)"
  by (blast intro: equivI)
lemma equiv_trans[trans]: "c \<sim> c' \<Longrightarrow> c' \<sim> c'' \<Longrightarrow> c \<sim> c''"
  by (blast intro: equivI)

subsubsection \<open>Basic Equivalences\<close>
lemma while_unfold:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)"
  by rule auto

lemma triv_if:
  "(IF b THEN c ELSE c) \<sim> c"
  by (auto intro!: equivI)

lemma commute_if:
  "(IF b1 THEN (IF b2 THEN c11 ELSE c12) ELSE c2)
   \<sim>
   (IF b2 THEN (IF b1 THEN c11 ELSE c2) ELSE (IF b1 THEN c12 ELSE c2))"
  by (auto intro!: equivI)

lemma sim_while_cong_aux:
  "\<lbrakk>\<pi>:(WHILE b DO c,s) \<Rightarrow> t; bval b = bval b'; c \<sim> c' \<rbrakk> \<Longrightarrow> \<pi>:(WHILE b' DO c',s) \<Rightarrow> t"
  by(induction "WHILE b DO c" s t arbitrary: b c rule: big_step_induct) auto

lemma sim_while_cong: "bval b = bval b' \<Longrightarrow> c \<sim> c' \<Longrightarrow> WHILE b DO c \<sim> WHILE b' DO c'"
  using equiv_c_def sim_while_cong_aux by auto

subsection \<open>Execution is Deterministic\<close>

text \<open>This proof is automatic.\<close>

theorem big_step_determ: "\<lbrakk> \<pi>:(c,s) \<Rightarrow> t; \<pi>:(c,s) \<Rightarrow> u \<rbrakk> \<Longrightarrow> u = t"
proof (induction arbitrary: u rule: big_step.induct)
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
    then show ?case by blast
qed fastforce+

subsection \<open>Small-Step Semantics\<close>

text \<open>
  The small step semantics is defined by a step function on
  a pair of command and state. Intuitively, the command is
  the remaining part of the program that still has to be executed.
  The step function is defined to stutter if the command is @{const SKIP}.

  Moreover, the step function is explicitly partial, returning @{const None}
  on error, i.e., on an undefined procedure call.

  Most steps are straightforward.
  For a sequential composition, steps are performed on the first command,
  until it has been reduced to @{const SKIP}, then the sequential composition is
  reduced to the second command.

  A while command is reduced by unfolding the loop once.

  A scope command is reduced to the inner command, followed by
  an @{const Assign_Locals} command to restore the original local variables.

  A procedure scope command is reduced by performing a step in the inner command,
  with the new procedure environment, until the inner command has been reduced to @{const SKIP}.
  Then, the whole command is reduced to @{const SKIP}.
\<close>

fun small_step :: "program \<Rightarrow> com \<times> state \<rightharpoonup> com \<times> state" where
  "small_step \<pi> (x[i]::=a,s) = Some (SKIP, s(x := (s x)(aval i s := aval a s)))"
| "small_step \<pi> (x[]::=y,s) = Some (SKIP, s(x := s y))"
| "small_step \<pi> (CLEAR x[],s) = Some (SKIP, s(x := (\<lambda>_. 0)))"
| "small_step \<pi> (Assign_Locals l,s) = Some (SKIP,<l|s>)"
| "small_step \<pi> (SKIP;;c,s) = Some (c,s)"
| "small_step \<pi> (c\<^sub>1;;c\<^sub>2,s) = (case small_step \<pi> (c\<^sub>1,s) of Some (c\<^sub>1',s') \<Rightarrow> Some (c\<^sub>1';;c\<^sub>2,s') | _ \<Rightarrow> None)"
| "small_step \<pi> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) = Some (if bval b s then (c\<^sub>1,s) else (c\<^sub>2,s))"
| "small_step \<pi> (SCOPE c, s) = Some (c;;Assign_Locals s, <<>|s>)"
| "small_step \<pi> (WHILE b DO c,s) = Some (IF b THEN c;;WHILE b DO c ELSE SKIP, s)"
| "small_step \<pi> (PCall p, s) = (case \<pi> p of Some c \<Rightarrow> Some (c, s) | _ \<Rightarrow> None)"
| "small_step \<pi> (PScope \<pi>' SKIP, s) = Some (SKIP,s)"
| "small_step \<pi> (PScope \<pi>' c, s) = (case small_step \<pi>' (c,s) of Some (c',s') \<Rightarrow> Some (PScope \<pi>' c', s') | _ \<Rightarrow> None)"
| "small_step \<pi> (SKIP,s) = Some (SKIP,s)"

text \<open>
  We define the reflexive transitive closure of the step function.
\<close>
inductive small_steps :: "program \<Rightarrow> com \<times> state \<Rightarrow> (com \<times> state) option \<Rightarrow> bool" where
  [simp]: "small_steps \<pi> cs (Some cs)"
| "\<lbrakk> small_step \<pi> cs = None \<rbrakk> \<Longrightarrow> small_steps \<pi> cs None"
| "\<lbrakk> small_step \<pi> cs = Some cs1; small_steps \<pi> cs1 cs2 \<rbrakk> \<Longrightarrow> small_steps \<pi> cs cs2"

lemma small_steps_append: "small_steps \<pi> cs\<^sub>1 (Some cs\<^sub>2) \<Longrightarrow> small_steps \<pi> cs\<^sub>2 cs\<^sub>3 \<Longrightarrow> small_steps \<pi> cs\<^sub>1 cs\<^sub>3"
  apply (induction \<pi> cs\<^sub>1 "Some cs\<^sub>2" arbitrary: cs\<^sub>2 rule: small_steps.induct)
  apply (auto intro: small_steps.intros)
  done

subsubsection \<open>Equivalence to Big-Step Semantics\<close>
text \<open>We show that the small-step semantics yields a final
  configuration if and only if the big-step semantics terminates with the respective state.

  Moreover, we show that the big-step semantics gets stuck if the small-step semantics
  yields an error.
  \<close>

lemma small_big_append: "small_step \<pi> cs\<^sub>1 = Some cs\<^sub>2 \<Longrightarrow> \<pi>: cs\<^sub>2 \<Rightarrow> s\<^sub>3 \<Longrightarrow> \<pi>: cs\<^sub>1 \<Rightarrow> s\<^sub>3"
  apply (induction \<pi> cs\<^sub>1 arbitrary: cs\<^sub>2 s\<^sub>3 rule: small_step.induct)
  apply (auto split: option.splits if_splits)
  done

lemma smalls_big_append: "small_steps \<pi> cs\<^sub>1 (Some cs\<^sub>2) \<Longrightarrow> \<pi>: cs\<^sub>2 \<Rightarrow> s\<^sub>3 \<Longrightarrow> \<pi>: cs\<^sub>1 \<Rightarrow> s\<^sub>3"
  apply (induction \<pi> cs\<^sub>1 "Some cs\<^sub>2" arbitrary: cs\<^sub>2 rule: small_steps.induct)
  apply (auto intro: small_big_append)
  done

lemma small_imp_big:
  assumes "small_steps \<pi> cs\<^sub>1 (Some (SKIP,s\<^sub>2))"
  shows "\<pi>: cs\<^sub>1 \<Rightarrow> s\<^sub>2"
  using smalls_big_append[OF assms]
  by auto

lemma small_steps_skip_term[simp]: "small_steps \<pi> (SKIP, s) cs' \<longleftrightarrow> cs'=Some (SKIP,s)"
  apply rule
  subgoal
    apply (induction \<pi> "(SKIP,s)" cs' arbitrary: s rule: small_steps.induct)
    by (auto intro: small_steps.intros)
  by (auto intro: small_steps.intros)

lemma small_seq: "\<lbrakk>c\<noteq>SKIP; small_step \<pi> (c,s) = Some (c',s')\<rbrakk> \<Longrightarrow> small_step \<pi> (c;;cx,s) = Some (c';;cx,s')"
  apply (induction \<pi> "(c,s)" arbitrary: c s c' s' rule: small_step.induct)
  apply auto
  done

lemma smalls_seq: "\<lbrakk>small_steps \<pi> (c,s) (Some (c',s'))\<rbrakk> \<Longrightarrow> small_steps \<pi> (c;;cx,s) (Some (c';;cx,s'))"
  apply (induction \<pi> "(c,s)" "Some (c',s')" arbitrary: c s c' s' rule: small_steps.induct)
  apply (auto dest: small_seq intro: small_steps.intros)
  by (metis option.simps(1) prod.simps(1) small_seq small_step.simps(31) small_steps.intros(3))

lemma small_pscope:
  "\<lbrakk>c\<noteq>SKIP; small_step \<pi>' (c,s) = Some (c',s')\<rbrakk> \<Longrightarrow> small_step \<pi> (PScope \<pi>' c,s) = Some (PScope \<pi>' c',s')"
  apply (induction \<pi> "(c,s)" arbitrary: c s c' s' rule: small_step.induct)
  apply auto
  done

lemma smalls_pscope:
  "small_steps \<pi>' (c, s) (Some (c', s')) \<Longrightarrow> small_steps \<pi> (PScope \<pi>' c, s) (Some (PScope \<pi>' c',s'))"
  apply (induction \<pi>' "(c,s)" "(Some (c', s'))" arbitrary: c s rule: small_steps.induct)
  apply auto
  by (metis (no_types, hide_lams) option.inject prod.inject small_pscope small_steps.simps small_steps_append small_steps_skip_term)

lemma big_imp_small:
  assumes "\<pi>: cs \<Rightarrow> t"
  shows "small_steps \<pi> cs (Some (SKIP,t))"
  using assms
proof induction
  case (Skip \<pi> s)
  then show ?case by (auto 0 4 intro: small_steps.intros)
next
  case (AssignIdx \<pi> x i a s)
  then show ?case by (auto 0 4 intro: small_steps.intros)
next
  case (ArrayCpy \<pi> x y s)
  then show ?case by (auto 0 4 intro: small_steps.intros)
next
  case (ArrayClear \<pi> x s)
  then show ?case by (auto 0 4 intro: small_steps.intros)
next
  case (Seq \<pi> c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  then show ?case
    by (meson small_step.simps(5) small_steps.intros(3) small_steps_append smalls_seq)
next
  case (IfTrue b s \<pi> c\<^sub>1 t c\<^sub>2)
  then show ?case by (auto 0 4 intro: small_steps.intros)
next
  case (IfFalse b s \<pi> c\<^sub>2 t c\<^sub>1)
  then show ?case by (auto 0 4 intro: small_steps.intros)
next
  case (Scope \<pi> c s s')
  then show ?case
  by (meson small_step.simps(17) small_step.simps(4) small_step.simps(5) small_steps.intros(1) small_steps.intros(3) small_steps_append smalls_seq)
next
  case (WhileFalse b s \<pi> c)
  then show ?case by (auto 0 4 intro: small_steps.intros)
next
  case (WhileTrue b s\<^sub>1 \<pi> c s\<^sub>2 s\<^sub>3)
  then show ?case
  proof -
    have "\<forall>ca p. (small_steps \<pi> p (Some (SKIP, s\<^sub>3)) \<or> Some (ca, s\<^sub>2) \<noteq> Some (WHILE b DO c, s\<^sub>2)) \<or> small_step \<pi> p \<noteq> Some (c;; ca, s\<^sub>1)"
      by (metis (no_types) WhileTrue.IH(1) WhileTrue.IH(2) small_step.simps(5) small_steps.intros(3) small_steps_append smalls_seq)
    then have "\<forall>ca cb cc. (small_steps \<pi> (IF b THEN cc ELSE ca, s\<^sub>1) (Some (SKIP, s\<^sub>3)) \<or> Some (cb, s\<^sub>2) \<noteq> Some (WHILE b DO c, s\<^sub>2)) \<or> Some (cc, s\<^sub>1) \<noteq> Some (c;; cb, s\<^sub>1)"
      using WhileTrue.hyps(1) by force
    then show ?thesis
      using small_step.simps(18) small_steps.intros(3) by blast
  qed

next
  case (PCall \<pi> p c s t)
  then show ?case by (auto 0 4 intro: small_steps.intros)
next
  case (PScope \<pi>' c s t \<pi>)
  then show ?case
    by (meson small_step.simps(20) small_steps.simps small_steps_append smalls_pscope)

next
  case (Assign_Locals \<pi> l s)
  then show ?case by (auto 0 4 intro: small_steps.intros)
qed

text \<open>The big-step semantics yields a state \<open>t\<close>, iff and only iff there is a transition
  of the small-step semantics to \<open>(SKIP,t).\<close>
\<close>
theorem big_eq_small: "\<pi>: cs\<Rightarrow>t \<longleftrightarrow> small_steps \<pi> cs (Some (SKIP,t))"
  using big_imp_small small_imp_big by blast

lemma small_steps_determ:
  assumes "small_steps \<pi> cs None"
  shows "\<not>small_steps \<pi> cs (Some (SKIP, t))"
  using assms
  apply (induction \<pi> cs "None::(com\<times>state) option" arbitrary: t rule: small_steps.induct)
  apply (auto elim: small_steps.cases)
  done

text \<open>If the small-step semantics reaches a failure state, the big-step semantics gets stuck.\<close>
corollary small_imp_big_fail:
  assumes "small_steps \<pi> cs None"
  shows "\<nexists>t. \<pi>: cs \<Rightarrow> t"
  using assms
  by (auto simp: big_eq_small small_steps_determ)

subsection \<open>Weakest Precondition\<close>

text \<open>The following definitions are made wrt.\ a fixed program \<open>\<pi>\<close>, which becomes the first
  parameter of the defined constants when the context is left.\<close>
context
  fixes \<pi> :: program
begin

  text \<open>Weakest precondition:
    \<open>c\<close> terminates with a state that satisfies \<open>Q\<close>, when started from \<open>s\<close>.\<close>
  definition "wp c Q s \<equiv> \<exists>t. \<pi>: (c,s) \<Rightarrow> t \<and> Q t"
    \<comment> \<open>Note that this definition exploits that the semantics is deterministic!
      In general, we must ensure absence of infinite executions\<close>

  text \<open>Weakest liberal precondition:
    If \<open>c\<close> terminates when started from \<open>s\<close>, the new state satisfies \<open>Q\<close>.\<close>
  definition "wlp c Q s \<equiv> \<forall>t. \<pi>:(c,s) \<Rightarrow> t \<longrightarrow> Q t"

  subsubsection \<open>Basic Properties\<close>

  context
    notes [abs_def,simp] = wp_def wlp_def
  begin
    lemma wp_imp_wlp: "wp c Q s \<Longrightarrow> wlp c Q s"
      using big_step_determ by force

    lemma wlp_and_term_imp_wp: "wlp c Q s \<and> \<pi>:(c,s) \<Rightarrow> t \<Longrightarrow> wp c Q s" by auto

    lemma wp_equiv: "c \<sim> c' \<Longrightarrow> wp c = wp c'" by auto
    lemma wp_conseq: "wp c P s \<Longrightarrow> \<lbrakk>\<And>s. P s \<Longrightarrow> Q s\<rbrakk> \<Longrightarrow> wp c Q s" by auto

    lemma wlp_equiv: "c \<sim> c' \<Longrightarrow> wlp c = wlp c'" by auto
    lemma wlp_conseq: "wlp c P s \<Longrightarrow> \<lbrakk>\<And>s. P s \<Longrightarrow> Q s\<rbrakk> \<Longrightarrow> wlp c Q s" by auto

  subsubsection \<open>Unfold Rules\<close>
    lemma wp_skip_eq: "wp SKIP Q s = Q s" by auto
    lemma wp_assign_idx_eq: "wp (x[i]::=a) Q s = Q (s(x:=(s x)(aval i s := aval a s)))" by auto
    lemma wp_arraycpy_eq: "wp (x[]::=a) Q s = Q (s(x:=s a))" by auto
    lemma wp_arrayinit_eq: "wp (CLEAR x[]) Q s = Q (s(x:=(\<lambda>_. 0)))" by auto
    lemma wp_assign_locals_eq: "wp (Assign_Locals l) Q s = Q <l|s>" by auto
    lemma wp_seq_eq: "wp (c\<^sub>1;;c\<^sub>2) Q s = wp c\<^sub>1 (wp c\<^sub>2 Q) s" by auto
    lemma wp_if_eq: "wp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) Q s
      = (if bval b s then wp c\<^sub>1 Q s else wp c\<^sub>2 Q s)" by auto

    lemma wp_scope_eq: "wp (SCOPE c) Q s = wp c (\<lambda>s'. Q <s|s'>) <<>|s>" by auto
    lemma wp_pcall_eq: "\<pi> p = Some c \<Longrightarrow> wp (PCall p) Q s = wp c Q s" by auto

    lemmas wp_eq = wp_skip_eq wp_assign_idx_eq wp_arraycpy_eq wp_arrayinit_eq
      wp_assign_locals_eq wp_seq_eq wp_scope_eq
    lemmas wp_eq' = wp_eq wp_if_eq

    lemma wlp_skip_eq: "wlp SKIP Q s = Q s" by auto
    lemma wlp_assign_idx_eq: "wlp (x[i]::=a) Q s = Q (s(x:=(s x)(aval i s := aval a s)))" by auto
    lemma wlp_arraycpy_eq: "wlp (x[]::=a) Q s = Q (s(x:=s a))" by auto
    lemma wlp_arrayinit_eq: "wlp (CLEAR x[]) Q s = Q (s(x:=(\<lambda>_. 0)))" by auto
    lemma wlp_assign_locals_eq: "wlp (Assign_Locals l) Q s = Q <l|s>" by auto
    lemma wlp_seq_eq: "wlp (c\<^sub>1;;c\<^sub>2) Q s = wlp c\<^sub>1 (wlp c\<^sub>2 Q) s" by auto
    lemma wlp_if_eq: "wlp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) Q s
      = (if bval b s then wlp c\<^sub>1 Q s else wlp c\<^sub>2 Q s)" by auto

    lemma wlp_scope_eq: "wlp (SCOPE c) Q s = wlp c (\<lambda>s'. Q <s|s'>) <<>|s>" by auto
    lemma wlp_pcall_eq: "\<pi> p = Some c \<Longrightarrow> wlp (PCall p) Q s = wlp c Q s" by auto

    lemmas wlp_eq = wlp_skip_eq wlp_assign_idx_eq wlp_arraycpy_eq wlp_arrayinit_eq
      wlp_assign_locals_eq wlp_seq_eq wlp_scope_eq
    lemmas wlp_eq' = wlp_eq wlp_if_eq
  end

  lemma wlp_while_unfold: "wlp (WHILE b DO c) Q s = (if bval b s then wlp c (wlp (WHILE b DO c) Q) s else Q s)"
    apply (subst wlp_equiv[OF while_unfold])
    apply (simp add: wlp_eq')
    done

  lemma wp_while_unfold: "wp (WHILE b DO c) Q s = (if bval b s then wp c (wp (WHILE b DO c) Q) s else Q s)"
    apply (subst wp_equiv[OF while_unfold])
    apply (simp add: wp_eq')
    done

end \<comment> \<open>Context fixing program\<close>

text \<open>Unfold rules for procedure scope\<close>
lemma wp_pscope_eq: "wp \<pi> (PScope \<pi>' c) Q s = wp \<pi>' (c) Q s"
  unfolding wp_def by auto

lemma wlp_pscope_eq: "wlp \<pi> (PScope \<pi>' c) Q s = wlp \<pi>' (c) Q s"
  unfolding wlp_def by auto

subsubsection \<open>Weakest precondition and Program Equivalence\<close>
text \<open>The following three statements are equivalent:
  \<^enum> The commands \<open>c\<close> and \<open>c'\<close> are equivalent
  \<^enum> The weakest preconditions are equivalent, for all procedure environments
  \<^enum> The weakest liberal preconditions are equivalent, for all procedure environments
\<close>

lemma wp_equiv_iff: "(\<forall>\<pi>. wp \<pi> c = wp \<pi> c') \<longleftrightarrow> c \<sim> c'"
  unfolding equiv_c_def
  using big_step_determ unfolding wp_def
  by (auto; metis)

lemma wlp_equiv_iff: "(\<forall>\<pi>. wlp \<pi> c = wlp \<pi> c') \<longleftrightarrow> c \<sim> c'"
  unfolding equiv_c_def wlp_def
  by (auto; metis (no_types, hide_lams))

subsubsection \<open>While Loops and Weakest Precondition\<close>

text \<open>Exchanging the loop condition by an equivalent one, and the loop
  body by one with the same weakest precondition, does not change the weakest
  precondition of the loop.\<close>
lemma sim_while_wp_aux:
  assumes "bval b = bval b'"
  assumes "wp \<pi> c = wp \<pi> c'"
  assumes "\<pi>: (WHILE b DO c, s) \<Rightarrow> t"
  shows "\<pi>: (WHILE b' DO c', s) \<Rightarrow> t"
  using assms(3,2)
  apply (induction \<pi> "WHILE b DO c" s t)
  apply (auto simp: assms(1))
  by (metis WhileTrue big_step_determ wp_def)

lemma sim_while_wp: "bval b = bval b' \<Longrightarrow> wp \<pi> c = wp \<pi> c' \<Longrightarrow> wp \<pi> (WHILE b DO c) = wp \<pi> (WHILE b' DO c')"
  apply (intro ext)
  apply (auto 0 3 simp: wp_def intro: sim_while_wp_aux)
  done

text \<open>The same lemma for weakest liberal preconditions.\<close>
lemma sim_while_wlp_aux:
  assumes "bval b = bval b'"
  assumes "wlp \<pi> c = wlp \<pi> c'"
  assumes "\<pi>: (WHILE b DO c, s) \<Rightarrow> t"
  shows "\<pi>: (WHILE b' DO c', s) \<Rightarrow> t"
  using assms(3,2)
  apply (induction \<pi> "WHILE b DO c" s t)
  apply (auto simp: assms(1,2))
  by (metis WhileTrue wlp_def)

lemma sim_while_wlp: "bval b = bval b' \<Longrightarrow> wlp \<pi> c = wlp \<pi> c' \<Longrightarrow> wlp \<pi> (WHILE b DO c) = wlp \<pi> (WHILE b' DO c')"
  apply (intro ext)
  apply (auto 0 3 simp: wlp_def intro: sim_while_wlp_aux)
  done

subsection \<open>Invariants for While-Loops\<close>
  text \<open>We prove the standard invariant rules for while loops.
    We first prove them in a slightly non-standard form, summarizing the
    loop step and loop exit assumptions. Then, we derive the standard form
    with separate assumptions for step and loop exit.
  \<close>

  subsubsection \<open>Partial Correctness\<close>
  lemma wlp_whileI':
    assumes INIT: "I s\<^sub>0"
    assumes STEP: "\<And>s. I s \<Longrightarrow> (if bval b s then wlp \<pi> c I s else Q s)"
    shows "wlp \<pi> (WHILE b DO c) Q s\<^sub>0"
    unfolding wlp_def
  proof clarify
    fix t
    assume "\<pi>: (WHILE b DO c, s\<^sub>0) \<Rightarrow> t"
    thus "Q t" using INIT STEP
    proof (induction \<pi> "WHILE b DO c" s\<^sub>0 t rule: big_step_induct)
      case (WhileFalse s) with STEP show "Q s" by auto
    next
      case (WhileTrue s\<^sub>1 \<pi> s\<^sub>2 s\<^sub>3)
      note STEP' = WhileTrue.prems(2)

      from STEP'[OF \<open>I s\<^sub>1\<close>] \<open>bval b s\<^sub>1\<close> have "wlp \<pi> c I s\<^sub>1" by simp
      with \<open>\<pi>: (c, s\<^sub>1) \<Rightarrow> s\<^sub>2\<close> have "I s\<^sub>2" unfolding wlp_def by blast
      moreover have \<open>I s\<^sub>2 \<Longrightarrow> Q s\<^sub>3\<close> using STEP' WhileTrue.hyps(5) by blast
      ultimately show "Q s\<^sub>3" by blast
    qed
  qed

  (* Short proof (not the shortest possible one ;) ) *)
  lemma
    assumes INIT: "I s\<^sub>0"
    assumes STEP: "\<And>s. I s \<Longrightarrow> (if bval b s then wlp \<pi> c I s else Q s)"
    shows "wlp \<pi> (WHILE b DO c) Q s\<^sub>0"
    using STEP
    unfolding wlp_def
    apply clarify subgoal premises prems for t
      using prems(2,1) INIT
      by (induction \<pi> "WHILE b DO c" s\<^sub>0 t rule: big_step_induct; meson)
    done

  subsubsection \<open>Total Correctness\<close>
  text \<open>For total correctness, each step must decrease the state wrt.~a well-founded relation.\<close>

  lemma wp_whileI':
    assumes WF: "wf R"
    assumes INIT: "I s\<^sub>0"
    assumes STEP: "\<And>s. I s \<Longrightarrow> (if bval b s then wp \<pi> c (\<lambda>s'. I s' \<and> (s',s)\<in>R) s else Q s)"
    shows "wp \<pi> (WHILE b DO c) Q s\<^sub>0"
    using WF INIT
  proof (induction rule: wf_induct_rule[where a=s\<^sub>0]) (* Instantiation required to avoid strange HO-unification problem! *)
    case (less s)
    show "wp \<pi> (WHILE b DO c) Q s"
    proof (rule wp_while_unfold[THEN iffD2])
      show "if bval b s then wp \<pi> c (wp \<pi> (WHILE b DO c) Q) s else Q s"
      proof (split if_split; intro allI impI conjI)
        assume [simp]: "bval b s"

        from STEP \<open>I s\<close> have "wp \<pi> c (\<lambda>s'. I s' \<and> (s',s)\<in>R) s" by simp
        thus "wp \<pi> c (wp \<pi> (WHILE b DO c) Q) s" proof (rule wp_conseq)
          fix s' assume "I s' \<and> (s',s)\<in>R"
          with less.IH show "wp \<pi> (WHILE b DO c) Q s'" by blast
        qed
      next
        assume [simp]: "\<not>bval b s"
        from STEP \<open>I s\<close> show "Q s" by simp
      qed
    qed
  qed

  (* Short Proof *)
  lemma
    assumes WF: "wf R"
    assumes INIT: "I s\<^sub>0"
    assumes STEP: "\<And>s. I s \<Longrightarrow> (if bval b s then wp \<pi> c (\<lambda>s'. I s' \<and> (s',s)\<in>R) s else Q s)"
    shows "wp \<pi> (WHILE b DO c) Q s\<^sub>0"
    using WF INIT
    apply (induction rule: wf_induct_rule[where a=s\<^sub>0])
    apply (subst wp_while_unfold)
    by (smt STEP wp_conseq)

  subsubsection \<open>Standard Forms of While Rules\<close>
  lemma wlp_whileI:
    assumes INIT: "I \<ss>\<^sub>0"
    assumes STEP: "\<And>\<ss>. \<lbrakk>I \<ss>; bval b \<ss> \<rbrakk> \<Longrightarrow> wlp \<pi> c I \<ss>"
    assumes FINAL: "\<And>\<ss>. \<lbrakk> I \<ss>; \<not>bval b \<ss> \<rbrakk> \<Longrightarrow> Q \<ss>"
    shows "wlp \<pi> (WHILE b DO c) Q \<ss>\<^sub>0"
    using assms wlp_whileI' by auto

  lemma wp_whileI:
    assumes WF: "wf R"
    assumes INIT: "I \<ss>\<^sub>0"
    assumes STEP: "\<And>\<ss>. \<lbrakk>I \<ss>; bval b \<ss> \<rbrakk> \<Longrightarrow> wp \<pi> c (\<lambda>\<ss>'. I \<ss>' \<and> (\<ss>',\<ss>)\<in>R) \<ss>"
    assumes FINAL: "\<And>\<ss>. \<lbrakk> I \<ss>; \<not>bval b \<ss> \<rbrakk> \<Longrightarrow> Q \<ss>"
    shows "wp \<pi> (WHILE b DO c) Q \<ss>\<^sub>0"
    using assms wp_whileI' by auto

subsection \<open>Modularity of Programs\<close>
text \<open>Adding more procedures does not change the semantics of the existing ones.\<close>

lemma map_leD: "m\<subseteq>\<^sub>mm' \<Longrightarrow> m x = Some v \<Longrightarrow> m' x = Some v"
  by (metis domI map_le_def)

lemma big_step_mono_prog:
  assumes "\<pi> \<subseteq>\<^sub>m \<pi>'"
  assumes "\<pi>:(c,s) \<Rightarrow> t"
  shows "\<pi>':(c,s) \<Rightarrow> t"
  using assms(2,1)
  apply (induction \<pi> c s t rule: big_step_induct)
  by (auto dest: map_leD)

text \<open>Wrapping a set of recursive procedures into a procedure scope\<close>
lemma localize_recursion:
  "\<pi>': (PScope \<pi> c, s) \<Rightarrow> t \<longleftrightarrow> \<pi>:(c,s) \<Rightarrow> t"
  by auto

subsection \<open>Strongest Postcondition\<close>

context fixes \<pi> :: program begin
  definition "sp P c t \<equiv> \<exists>s. P s \<and> \<pi>: (c,s) \<Rightarrow> t"

  context notes [simp] = sp_def[abs_def] begin

    text \<open>Intuition: There exists an old value \<open>vx\<close> for the assigned variable\<close>
    lemma sp_arraycpy_eq: "sp P (x[]::=y) t \<longleftrightarrow> (\<exists>vx. let s = t(x:=vx) in t x = s y \<and> P s)"
      apply (auto simp: big_step_simps)
       apply (intro exI conjI, assumption, auto) []
      apply (intro exI conjI, assumption, auto) []
      done

    text \<open>Version with renaming of assigned variable\<close>
    lemma sp_arraycpy_eq': "sp P (x[]::=y) t \<longleftrightarrow> t x = t y \<and> (\<exists>vx. P (t(x:=vx,y:=t x)))"
      apply (auto simp: big_step_simps)
       apply (metis fun_upd_triv)
      apply (intro exI conjI, assumption)
      apply auto
      done

    lemma sp_skip_eq: "sp P SKIP t \<longleftrightarrow> P t" by auto
    lemma sp_seq_eq: "sp P (c\<^sub>1;;c\<^sub>2) t \<longleftrightarrow> sp (sp P c\<^sub>1) c\<^sub>2 t" by auto

  end
end

subsection \<open>Hoare-Triples\<close>

text \<open>A Hoare-triple summarizes the precondition, command, and postcondition.\<close>

definition HT
  where "HT \<pi> P c Q \<equiv> (\<forall>s\<^sub>0. P s\<^sub>0 \<longrightarrow> wp \<pi> c (Q s\<^sub>0) s\<^sub>0)"

definition HT_partial
  where "HT_partial \<pi> P c Q \<equiv> (\<forall>s\<^sub>0. P s\<^sub>0 \<longrightarrow> wlp \<pi> c (Q s\<^sub>0) s\<^sub>0)"

text \<open>Consequence rule---strengthen the precondition, weaken the postcondition.\<close>
lemma HT_conseq:
  assumes "HT \<pi> P c Q"
  assumes "\<And>s. P' s \<Longrightarrow> P s"
  assumes "\<And>s\<^sub>0 s. \<lbrakk>P s\<^sub>0; P' s\<^sub>0; Q s\<^sub>0 s \<rbrakk> \<Longrightarrow> Q' s\<^sub>0 s"
  shows "HT \<pi> P' c Q'"
  using assms unfolding HT_def by (blast intro: wp_conseq)

lemma HT_partial_conseq:
  assumes "HT_partial \<pi> P c Q"
  assumes "\<And>s. P' s \<Longrightarrow> P s"
  assumes "\<And>s\<^sub>0 s. \<lbrakk>P s\<^sub>0; P' s\<^sub>0; Q s\<^sub>0 s \<rbrakk> \<Longrightarrow> Q' s\<^sub>0 s"
  shows "HT_partial \<pi> P' c Q'"
  using assms unfolding HT_partial_def by (blast intro: wlp_conseq)

text \<open>Simple rule for presentation in lecture: Use a Hoare-triple during VCG.\<close>
lemma wp_modularity_rule:
  "\<lbrakk>HT \<pi> P c Q; P s; (\<And>s'. Q s s' \<Longrightarrow> Q' s')\<rbrakk> \<Longrightarrow> wp \<pi> c Q' s"
  unfolding HT_def
  by (blast intro: wp_conseq)

subsubsection \<open>Sets of Hoare-Triples\<close>
type_synonym htset = "((state \<Rightarrow> bool) \<times> com \<times> (state \<Rightarrow> state \<Rightarrow> bool)) set"

definition "HTset \<pi> \<Theta> \<equiv> \<forall>(P,c,Q)\<in>\<Theta>. HT \<pi> P c Q"

definition "HTset_r r \<pi> \<Theta> \<equiv> \<forall>(P,c,Q)\<in>\<Theta>. HT \<pi> (\<lambda>s. r c s \<and> P s) c Q"

subsubsection \<open>Deriving Parameter Frame Adjustment Rules\<close>

text \<open>The following rules can be used to derive Hoare-triples when adding
  prologue and epilogue code, and wrapping the command into a scope.

  This will be used to implement the local variables and parameter passing protocol
  of procedures.
\<close>

text \<open> Intuition:
  New precondition is weakest one we need to ensure \<open>P\<close> after prologue.
\<close>
lemma adjust_prologue:
  assumes "HT \<pi> P body Q"
  shows "HT \<pi> (wp \<pi> prologue P) (prologue;;body) (\<lambda>s\<^sub>0 s. wp \<pi> prologue (\<lambda>s\<^sub>0. Q s\<^sub>0 s) s\<^sub>0)"
  using assms
  unfolding HT_def
  apply (auto simp: wp_eq)
  using wp_def by fastforce

text \<open> Intuition:
  New postcondition is strongest one we can get from \<open>Q\<close> after epilogue.

  We have to be careful with non-terminating epilogue, though!
\<close>
lemma adjust_epilogue:
  assumes "HT \<pi> P body Q"
  assumes TERMINATES: "\<forall>s. \<exists>t. \<pi>: (epilogue,s) \<Rightarrow> t"
  shows "HT \<pi> P (body;;epilogue) (\<lambda>s\<^sub>0. sp \<pi> (Q s\<^sub>0) epilogue)"
  using assms
  unfolding HT_def
  apply (simp add: wp_eq)
  apply (force simp: sp_def wp_def)
  done

text \<open>Intuition:
  Scope can be seen as assignment of locals before and after inner command.
  Thus, this rule is a combined forward and backward assignment rule, for
  the epilogue \<open>locals:=<>\<close> and the prologue \<open>locals:=old_locals\<close>.
\<close>
lemma adjust_scope:
  assumes "HT \<pi> P body Q"
  shows "HT \<pi> (\<lambda>s. P <<>|s>) (SCOPE body) (\<lambda>s\<^sub>0 s. \<exists>l. Q (<<>|s\<^sub>0>) (<l|s>))"
  using assms unfolding HT_def
  apply (auto simp: wp_eq combine_nest)
  apply (auto simp: wp_def)
  by (metis combine_collapse)

subsubsection \<open>Proof for Recursive Specifications\<close>

text \<open>Prove correct any set of Hoare-triples, e.g., mutually recursive ones.\<close>
lemma HTsetI:
  assumes "wf R"
  assumes RL: "\<And>P c Q s\<^sub>0. \<lbrakk> HTset_r (\<lambda>c' s'. ((c',s'),(c,s\<^sub>0))\<in>R ) \<pi> \<Theta>; (P,c,Q)\<in>\<Theta>; P s\<^sub>0 \<rbrakk> \<Longrightarrow> wp \<pi> c (Q s\<^sub>0) s\<^sub>0"
  shows "HTset \<pi> \<Theta>"
  unfolding HTset_def HT_def
proof clarsimp
  fix P c Q s\<^sub>0
  assume "(P,c,Q)\<in>\<Theta>" "P s\<^sub>0"
  with \<open>wf R\<close> show "wp \<pi> c (Q s\<^sub>0) s\<^sub>0"
    apply (induction "(c,s\<^sub>0)" arbitrary: c s\<^sub>0 P Q)
    using RL unfolding HTset_r_def HT_def
    by blast

qed

lemma HT_simple_recursiveI:
  assumes "wf R"
  assumes "\<And>s. \<lbrakk>HT \<pi> (\<lambda>s'. (f s', f s)\<in>R \<and> P s') c Q; P s \<rbrakk> \<Longrightarrow> wp \<pi> c (Q s) s"
  shows "HT \<pi> P c Q"
  using HTsetI[where R="inv_image R (f o snd)" and \<pi>=\<pi> and \<Theta> = "{(P,c,Q)}"] assms
  by (auto simp: HTset_r_def HTset_def)

lemma HT_simple_recursive_procI:
  assumes "wf R"
  assumes "\<And>s. \<lbrakk>HT \<pi> (\<lambda>s'. (f s', f s)\<in>R \<and> P s') (PCall p) Q; P s \<rbrakk> \<Longrightarrow> wp \<pi> (PCall p) (Q s) s"
  shows "HT \<pi> P (PCall p) Q"
  using HTsetI[where R="inv_image R (f o snd)" and \<pi>=\<pi> and \<Theta> = "{(P,PCall p,Q)}"] assms
  by (auto simp: HTset_r_def HTset_def)

lemma
  assumes "wf R"
  assumes "\<And>s P p Q. \<lbrakk>
    \<And>P' p' Q'. (P',p',Q')\<in>\<Theta>
      \<Longrightarrow> HT \<pi> (\<lambda>s'. ((p',s'),(p,s))\<in>R \<and> P' s') (PCall p') Q';
    (P,p,Q)\<in>\<Theta>; P s
  \<rbrakk> \<Longrightarrow> wp \<pi> (PCall p) (Q s) s"
  shows "\<forall>(P,p,Q)\<in>\<Theta>. HT \<pi> P (PCall p) Q"
proof -

  have "HTset \<pi> {(P, PCall p, Q) |P p Q. (P, p, Q) \<in> \<Theta>}"
    apply (rule HTsetI[where R="inv_image R (\<lambda>x. case x of (PCall p,s) \<Rightarrow> (p,s))"])
    subgoal using \<open>wf R\<close> by simp
    subgoal for P c Q s
      apply clarsimp
      apply (rule assms(2)[where P=P])
        apply simp_all
      unfolding HTset_r_def
      proof goal_cases
        case (1 p P' p' Q')

        from "1"(1)[rule_format, of "(P',PCall p',Q')", simplified] "1"(2-)
          show ?case by auto
      qed
    done

  thus ?thesis by (auto simp: HTset_def)
qed

subsection \<open>Completeness of While-Rule\<close>

text \<open>Idea: Use \<open>wlp\<close> as invariant\<close>
lemma wlp_whileI'_complete:
  assumes "wlp \<pi> (WHILE b DO c) Q s\<^sub>0"
  obtains I where
    "I s\<^sub>0"
    "\<And>s. I s \<Longrightarrow> if bval b s then wlp \<pi> c I s else Q s"
proof
  let ?I = "wlp \<pi> (WHILE b DO c) Q"
  {
    show "?I s\<^sub>0" by fact
  next
    fix s
    assume "?I s"
    then show "if bval b s then wlp \<pi> c ?I s else Q s"
      apply (subst (asm) wlp_while_unfold)
      .
  }
qed

text \<open>Idea: Remaining loop iterations as variant\<close>

inductive count_it for \<pi> b c where
  "\<not>bval b s \<Longrightarrow> count_it \<pi> b c s 0"
| "\<lbrakk>bval b s; \<pi>: (c,s) \<Rightarrow> s'; count_it \<pi> b c s' n \<rbrakk> \<Longrightarrow> count_it \<pi> b c s (Suc n )"

lemma count_it_determ:
  "count_it \<pi> b c s n \<Longrightarrow> count_it \<pi> b c s n' \<Longrightarrow> n' = n"
  apply (induction arbitrary: n' rule: count_it.induct)
  subgoal using count_it.cases by blast
  subgoal by (metis big_step_determ count_it.cases)
  done

lemma count_it_ex:
  assumes "\<pi>: (WHILE b DO c,s) \<Rightarrow> t"
  shows "\<exists>n. count_it \<pi> b c s n"
  using assms
  apply (induction \<pi> "WHILE b DO c" s t arbitrary: b c)
   apply (auto intro: count_it.intros)
  done

definition "variant \<pi> b c s \<equiv> THE n. count_it \<pi> b c s n"

lemma variant_decreases:
  assumes STEPB: "bval b s"
  assumes STEPC: "\<pi>: (c,s) \<Rightarrow> s'"
  assumes TERM: "\<pi>: (WHILE b DO c,s') \<Rightarrow> t"
  shows "variant \<pi> b c s' < variant \<pi> b c s"
proof -
  from count_it_ex[OF TERM] obtain n' where CI': "count_it \<pi> b c s' n'" ..
  moreover from count_it.intros(2)[OF STEPB STEPC this] have "count_it \<pi> b c s (Suc n')" .
  ultimately have "variant \<pi> b c s' = n'" "variant \<pi> b c s = Suc n'"
    unfolding variant_def using count_it_determ by blast+
  thus ?thesis by simp
qed

lemma wp_whileI'_complete:
  fixes \<pi> b c
  defines "R\<equiv>measure (variant \<pi> b c)"
  assumes "wp \<pi> (WHILE b DO c) Q s\<^sub>0"
  obtains I where
    "wf R"
    "I s\<^sub>0"
    "\<And>s. I s \<Longrightarrow> if bval b s then wp \<pi> c (\<lambda>s'. I s' \<and> (s',s)\<in>R) s else Q s"
proof
  show \<open>wf R\<close> unfolding R_def by auto
  let ?I = "wp \<pi> (WHILE b DO c) Q"
  {
    show "?I s\<^sub>0" by fact
  next
    fix s
    assume "?I s"
    then show "if bval b s then wp \<pi> c (\<lambda>s'. ?I s' \<and> (s',s)\<in>R) s else Q s"
      apply (subst (asm) wp_while_unfold)
      apply clarsimp
      by (auto simp: wp_def R_def intro: variant_decreases)

  }
qed

end


(*<*)
theory LoweOntologicalArgument_3
imports QML
begin

nitpick_params[box=false, user_axioms=true, show_all, expect=genuine, format = 3,  atoms e = a b c d]
sledgehammer_params[verbose=true]

consts isActualized::"e\<Rightarrow>wo" (infix "actualizedAt" 70)

abbreviation forallAct::"(e\<Rightarrow>wo)\<Rightarrow>wo" ("\<^bold>\<forall>\<^sup>A")
  where "\<^bold>\<forall>\<^sup>A\<Phi> \<equiv> \<lambda>w.\<forall>x. (x actualizedAt w)\<longrightarrow>(\<Phi> x w)"
abbreviation existsAct::"(e\<Rightarrow>wo)\<Rightarrow>wo" ("\<^bold>\<exists>\<^sup>A")
  where "\<^bold>\<exists>\<^sup>A\<Phi> \<equiv> \<lambda>w.\<exists>x. (x actualizedAt w) \<and> (\<Phi> x w)"
abbreviation mforallActB::"(e\<Rightarrow>wo)\<Rightarrow>wo" (binder"\<^bold>\<forall>\<^sup>A"[8]9)
  where "\<^bold>\<forall>\<^sup>Ax. (\<phi> x) \<equiv> \<^bold>\<forall>\<^sup>A\<phi>"
abbreviation mexistsActB::"(e\<Rightarrow>wo)\<Rightarrow>wo" (binder"\<^bold>\<exists>\<^sup>A"[8]9)
  where "\<^bold>\<exists>\<^sup>Ax. (\<phi> x) \<equiv> \<^bold>\<exists>\<^sup>A\<phi>"

definition Existence::"e\<Rightarrow>wo" ("E!") where "E! x  \<equiv> \<^bold>\<exists>\<^sup>Ay. y\<^bold>\<approx>x"
definition Necessary::"e\<Rightarrow>wo" where "Necessary x \<equiv>  \<^bold>\<box>E! x"
definition Contingent::"e\<Rightarrow>wo" where "Contingent x \<equiv>  \<^bold>\<diamond>E! x \<^bold>\<and> \<^bold>\<not>(Necessary x)"

consts Concrete::"e\<Rightarrow>wo"
abbreviation Abstract::"e\<Rightarrow>wo" where "Abstract x \<equiv>  \<^bold>\<not>(Concrete x)"

abbreviation Godlike::"e\<Rightarrow>wo"  where "Godlike x \<equiv> Necessary x \<^bold>\<and> Concrete x"

consts dependence::"e\<Rightarrow>e\<Rightarrow>wo" (infix "dependsOn" 100)
definition Dependent::"e\<Rightarrow>wo" where "Dependent x \<equiv> \<^bold>\<exists>\<^sup>Ay. x dependsOn y"
abbreviation Independent::"e\<Rightarrow>wo" where "Independent x  \<equiv> \<^bold>\<not>(Dependent x)"

consts explanation::"e\<Rightarrow>e\<Rightarrow>wo" (infix "explains" 100)
definition Explained::"e\<Rightarrow>wo" where "Explained x \<equiv> \<^bold>\<exists>\<^sup>Ay. y explains x"

axiomatization where
  P2: "\<lfloor>\<^bold>\<exists>\<^sup>Ax. Necessary x \<^bold>\<and> Abstract x\<rfloor>" and
  P3: "\<lfloor>\<^bold>\<forall>\<^sup>Ax. Abstract x \<^bold>\<rightarrow> Dependent x\<rfloor>" and
  P4: "\<lfloor>\<^bold>\<forall>\<^sup>Ax. Dependent x \<^bold>\<rightarrow> (\<^bold>\<exists>\<^sup>Ay. Independent y \<^bold>\<and> x dependsOn y)\<rfloor>" and
  P5: "\<lfloor>\<^bold>\<not>(\<^bold>\<exists>\<^sup>Ax. \<^bold>\<exists>\<^sup>Ay. Contingent y \<^bold>\<and> Necessary x \<^bold>\<and> y explains x)\<rfloor>"
(*>*)

subsection \<open>Validating the Argument II\<close>

text\<open>\noindent{We present a slightly simplified version of the original argument (without the implicit premises stated in
the previous version). In this variant premises P1 to P5 remain unchanged
and none of the last three premises proposed by Lowe (P6 to P8) show up anymore.
Those last premises have been introduced in order to interrelate the concepts of explanation and dependence
in such a way that they play somewhat opposite roles.
Now we want to go all the way and simply assume that they are inverse relations,
for we want to understand how the interrelation of these two concepts affects the validity of the argument.}\<close>

axiomatization where
  dep_expl_inverse: "\<lfloor>\<^bold>\<forall>x y. y explains x \<^bold>\<leftrightarrow> x dependsOn y\<rfloor>"

text\<open>\noindent{We proceed to prove the relevant partial conclusions.}\<close>
theorem C1:  "\<lfloor>\<^bold>\<forall>\<^sup>Ax. Abstract x \<^bold>\<rightarrow> (\<^bold>\<exists>y. Concrete y \<^bold>\<and> x dependsOn y)\<rfloor>"
  using P3 P4 by blast

theorem C5: "\<lfloor>\<^bold>\<exists>\<^sup>Ax. Concrete x\<rfloor>"
  using P2 P3 P4 by blast

theorem C7: "\<lfloor>\<^bold>\<forall>\<^sup>Ax. (Necessary x \<^bold>\<and> Abstract x) \<^bold>\<rightarrow> Explained x\<rfloor>"
  using Explained_def P3 P4 dep_expl_inverse by meson

text\<open>\noindent{But the final conclusion C10 is still countersatisfiable, as shown by Nitpick:}\<close>
theorem C10:  "\<lfloor>\<^bold>\<exists>\<^sup>Ax. Godlike x\<rfloor>"
  nitpick[user_axioms] oops \<comment> \<open>Countermodel found\<close>

text\<open>\noindent{Next, we try assuming a stronger modal logic. We do this by postulating further axioms
using the \emph{Sahlqvist correspondence} and asking Sledgehammer to find a proof.
Sledgehammer is in fact able to find a proof for C10 which only relies on the modal axiom \emph{T}
(\<open>\<box>\<phi> \<^bold>\<rightarrow> \<phi>\<close>).}\<close>
axiomatization where
 T_axiom: "reflexive R" and \<comment> \<open>@{text "\<box>\<phi> \<rightarrow> \<phi>"}\<close>
 B_axiom: "symmetric R" and \<comment> \<open>@{text "\<phi> \<rightarrow>  \<box>\<diamond>\<phi>"}\<close>
 IV_axiom: "transitive R"   \<comment> \<open>@{text "\<box>\<phi> \<rightarrow> \<box>\<box>\<phi>"}\<close>

theorem C10: "\<lfloor>\<^bold>\<exists>\<^sup>Ax. Godlike x\<rfloor>" using Contingent_def Existence_def
     P2 P3 P4 P5 dep_expl_inverse T_axiom by meson

text\<open>\noindent{In this series of iterations we have verified a modified version of the original argument by Lowe.
Our understanding of the concepts of \emph{ontological dependence} and \emph{metaphysical explanation}
have changed after the introduction of an additional axiom constraining both:
they are now inverse relations.
Still, we want to carry on with our iterative process in order to further illuminate the meaning
of the concepts involved in this argument.}\<close>

(*<*)
(* We carry out our `sanity checks' as usual.*)
lemma True nitpick[satisfy, user_axioms] oops (* model found: axioms are consistent *)
lemma "\<lfloor>Necessary x\<rfloor>" nitpick[user_axioms] oops (* counter-model found: axioms do not trivialize argument *)
lemma "\<lfloor>\<phi> \<^bold>\<rightarrow> \<^bold>\<box>\<phi>\<rfloor>" nitpick[user_axioms] oops (* counter-model found: modal collapse is not valid *)

end
(*>*)


theory HF_Extras
  imports HereditarilyFinite.Rank
begin

lemma hcard_ord_of[simp]:
  "hcard (ord_of n) = n"
  unfolding hcard_def hfset_ord_of card_image[OF inj_ord_of]
  by simp

lemma hcard_HF: "finite A \<Longrightarrow> hcard (HF A) = card A"
  unfolding hcard_def using hfset_HF by simp

end


section \<open>\<open>Extra_Jordan_Normal_Form\<close> -- Additional results for \<^session>\<open>Jordan_Normal_Form\<close>\<close>
(*
Authors:
  Dominique Unruh, University of Tartu, unruh@ut.ee
  Jose Manuel Rodriguez Caballero, University of Tartu, jose.manuel.rodriguez.caballero@ut.ee
*)

theory Extra_Jordan_Normal_Form
  imports
    Jordan_Normal_Form.Matrix Jordan_Normal_Form.Schur_Decomposition
begin

text \<open>We define bundles to activate/deactivate the notation from \<^session>\<open>Jordan_Normal_Form\<close>.

Reactivate the notation locally via "@{theory_text \<open>includes jnf_notation\<close>}" in a lemma statement.
(Or sandwich a declaration using that notation between "@{theory_text \<open>unbundle jnf_notation ... unbundle no_jnf_notation\<close>}.)
\<close>

bundle jnf_notation begin
notation transpose_mat ("(_\<^sup>T)" [1000])
notation cscalar_prod (infix "\<bullet>c" 70)
notation vec_index (infixl "$" 100)
notation smult_vec (infixl "\<cdot>\<^sub>v" 70)
notation scalar_prod (infix "\<bullet>" 70)
notation index_mat (infixl "$$" 100)
notation smult_mat (infixl "\<cdot>\<^sub>m" 70)
notation mult_mat_vec (infixl "*\<^sub>v" 70)
notation pow_mat (infixr "^\<^sub>m" 75)
notation append_vec (infixr "@\<^sub>v" 65)
notation append_rows (infixr "@\<^sub>r" 65)
end

bundle no_jnf_notation begin
no_notation transpose_mat ("(_\<^sup>T)" [1000])
no_notation cscalar_prod (infix "\<bullet>c" 70)
no_notation vec_index (infixl "$" 100)
no_notation smult_vec (infixl "\<cdot>\<^sub>v" 70)
no_notation scalar_prod (infix "\<bullet>" 70)
no_notation index_mat (infixl "$$" 100)
no_notation smult_mat (infixl "\<cdot>\<^sub>m" 70)
no_notation mult_mat_vec (infixl "*\<^sub>v" 70)
no_notation pow_mat (infixr "^\<^sub>m" 75)
no_notation append_vec (infixr "@\<^sub>v" 65)
no_notation append_rows (infixr "@\<^sub>r" 65)
end

unbundle jnf_notation

lemma mat_entry_explicit:
  fixes M :: "'a::field mat"
  assumes "M \<in> carrier_mat m n" and "i < m" and "j < n"
  shows   "vec_index (M *\<^sub>v unit_vec n j) i = M $$ (i,j)"
  using assms by auto

lemma mat_adjoint_def': "mat_adjoint M = transpose_mat (map_mat conjugate M)"
  apply (rule mat_eq_iff[THEN iffD2])
  apply (auto simp: mat_adjoint_def transpose_mat_def)
  apply (subst mat_of_rows_index)
  by auto

lemma mat_adjoint_swap:
  fixes M ::"complex mat"
  assumes "M \<in> carrier_mat nB nA" and "iA < dim_row M" and "iB < dim_col M"
  shows "(mat_adjoint M)$$(iB,iA) = cnj (M$$(iA,iB))"
  unfolding transpose_mat_def map_mat_def
  by (simp add: assms(2) assms(3) mat_adjoint_def')

lemma cscalar_prod_adjoint:
  fixes M:: "complex mat"
  assumes "M \<in> carrier_mat nB nA"
    and "dim_vec v = nA"
    and "dim_vec u = nB"
  shows "v \<bullet>c ((mat_adjoint M) *\<^sub>v u) = (M *\<^sub>v v) \<bullet>c u"
  unfolding mat_adjoint_def using assms(1) assms(2,3)[symmetric]
  apply (simp add: scalar_prod_def sum_distrib_left field_simps)
  by (intro sum.swap)

lemma scaleC_minus1_left_vec: "-1 \<cdot>\<^sub>v v = - v" for v :: "_::ring_1 vec"
  unfolding smult_vec_def uminus_vec_def by auto

lemma square_nneg_complex:
  fixes x :: complex
  assumes "x \<in> \<real>" shows "x^2 \<ge> 0"
  apply (cases x) using assms unfolding Reals_def less_eq_complex_def by auto

definition "vec_is_zero n v = (\<forall>i<n. v $ i = 0)"

lemma vec_is_zero: "dim_vec v = n \<Longrightarrow> vec_is_zero n v \<longleftrightarrow> v = 0\<^sub>v n"
  unfolding vec_is_zero_def apply auto
  by (metis index_zero_vec(1))

fun gram_schmidt_sub0
  where "gram_schmidt_sub0 n us [] = us"
  | "gram_schmidt_sub0 n us (w # ws) =
     (let w' = adjuster n w us + w in
      if vec_is_zero n w' then gram_schmidt_sub0 n us ws
                          else gram_schmidt_sub0 n (w' # us) ws)"

lemma (in cof_vec_space) adjuster_already_in_span:
  assumes "w \<in> carrier_vec n"
  assumes us_carrier: "set us \<subseteq> carrier_vec n"
  assumes "corthogonal us"
  assumes "w \<in> span (set us)"
  shows "adjuster n w us + w = 0\<^sub>v n"
proof -
  define v U where "v = adjuster n w us + w" and "U = set us"
  have span: "v \<in> span U"
    unfolding v_def U_def
    apply (rule adjust_preserves_span[THEN iffD1])
    using assms corthogonal_distinct by simp_all
  have v_carrier: "v \<in> carrier_vec n"
    by (simp add: v_def assms corthogonal_distinct)
  have "v \<bullet>c us!i = 0" if "i < length us" for i
    unfolding v_def
    apply (rule adjust_zero)
    using that assms by simp_all
  hence "v \<bullet>c u = 0" if "u \<in> U" for u
    by (metis assms(3) U_def corthogonal_distinct distinct_Ex1 that)
  hence ortho: "u \<bullet>c v = 0" if "u \<in> U" for u
    apply (subst conjugate_zero_iff[symmetric])
    apply (subst conjugate_vec_sprod_comm)
    using that us_carrier v_carrier apply (auto simp: U_def)[2]
    apply (subst conjugate_conjugate_sprod)
    using that us_carrier v_carrier by (auto simp: U_def)
  from span obtain a where v: "lincomb a U = v"
    apply atomize_elim apply (rule finite_in_span[simplified])
    unfolding U_def using us_carrier by auto
  have "v \<bullet>c v = (\<Sum>u\<in>U. (a u \<cdot>\<^sub>v u) \<bullet>c v)"
    apply (subst v[symmetric])
    unfolding lincomb_def
    apply (subst finsum_scalar_prod_sum)
    using U_def span us_carrier by auto
  also have "\<dots> = (\<Sum>u\<in>U. a u * (u \<bullet>c v))"
    using U_def assms(1) in_mono us_carrier v_def by fastforce
  also have "\<dots> = (\<Sum>u\<in>U. a u * conjugate 0)"
    apply (rule sum.cong, simp)
    using span span_closed U_def us_carrier ortho by auto
  also have "\<dots> = 0"
    by auto
  finally have "v \<bullet>c v = 0"
    by -
  thus "v = 0\<^sub>v n"
    using U_def conjugate_square_eq_0_vec span span_closed us_carrier by blast
qed

lemma (in cof_vec_space) gram_schmidt_sub0_result:
  assumes "gram_schmidt_sub0 n us ws = us'"
    and "set ws \<subseteq> carrier_vec n"
    and "set us \<subseteq> carrier_vec n"
    and "distinct us"
    and "~ lin_dep (set us)"
    and "corthogonal us"
  shows "set us' \<subseteq> carrier_vec n \<and>
         distinct us' \<and>
         corthogonal us' \<and>
         span (set (us @ ws)) = span (set us')"
  using assms
proof (induct ws arbitrary: us us')
  case (Cons w ws)
  show ?case
  proof (cases "w \<in> span (set us)")
    case False
    let ?v = "adjuster n w us"
    have wW[simp]: "set (w#ws) \<subseteq> carrier_vec n" using Cons by simp
    hence W[simp]: "set ws \<subseteq> carrier_vec n"
      and w[simp]: "w : carrier_vec n" by auto
    have U[simp]: "set us \<subseteq> carrier_vec n" using Cons by simp
    have UW: "set (us@ws) \<subseteq> carrier_vec n" by simp
    have wU: "set (w#us) \<subseteq> carrier_vec n" by simp
    have dist_U: "distinct us" using Cons by simp
    have w_U: "w \<notin> set us" using False using span_mem by auto
    have ind_U: "~ lin_dep (set us)"
      using Cons by simp
    have ind_wU: "~ lin_dep (insert w (set us))"
      apply (subst lin_dep_iff_in_span[simplified, symmetric])
      using w_U ind_U False by auto
    thm lin_dep_iff_in_span[simplified, symmetric]
    have corth: "corthogonal us" using Cons by simp
    have "?v + w \<noteq> 0\<^sub>v n"
      by (simp add: False adjust_nonzero dist_U)
    hence "\<not> vec_is_zero n (?v + w)"
      by (simp add: vec_is_zero)
    hence U'def: "gram_schmidt_sub0 n ((?v + w)#us) ws = us'"
      using Cons by simp
    have v: "?v : carrier_vec n" using dist_U by auto
    hence vw: "?v + w : carrier_vec n" by auto
    hence vwU: "set ((?v + w) # us) \<subseteq> carrier_vec n" by auto
    have vsU: "?v : span (set us)"
      apply (rule adjuster_in_span[OF w])
      using Cons by simp_all
    hence vsUW: "?v : span (set (us @ ws))"
      using span_is_monotone[of "set us" "set (us@ws)"] by auto
    have wsU: "w \<notin> span (set us)"
      using lin_dep_iff_in_span[OF U ind_U w w_U] ind_wU by auto
    hence vwU: "?v + w \<notin> span (set us)" using adjust_not_in_span[OF w U dist_U] by auto

    have span: "?v + w \<notin> span (set us)"
      apply (subst span_add[symmetric])
      by (simp_all add: False vsU)
    hence vwUS: "?v + w \<notin> set us" using span_mem by auto

    have vwU: "set ((?v + w) # us) \<subseteq> carrier_vec n"
      using U w vw by simp
    have dist2: "distinct (((?v + w) # us))"
      using vwUS
      by (simp add: dist_U)

    have orth2: "corthogonal ((adjuster n w us + w) # us)"
      using adjust_orthogonal[OF U corth w wsU].

    have ind_vwU: "~ lin_dep (set ((adjuster n w us + w) # us))"
      apply simp
      apply (subst lin_dep_iff_in_span[simplified, symmetric])
      by (simp_all add: ind_U vw vwUS span)

    have span_UwW_U': "span (set (us @ w # ws)) = span (set us')"
      using Cons(1)[OF U'def W vwU dist2 ind_vwU orth2]
      using span_Un[OF vwU wU gram_schmidt_sub_span[OF w U dist_U] W W refl]
      by simp

    show ?thesis
      apply (intro conjI)
      using Cons(1)[OF U'def W vwU dist2 ind_vwU orth2] span_UwW_U' by simp_all
  next
    case True

    let ?v = "adjuster n w us"
    have "?v + w = 0\<^sub>v n"
      apply (rule adjuster_already_in_span)
      using True Cons by auto
    hence "vec_is_zero n (?v + w)"
      by (simp add: vec_is_zero)
    hence U'_def: "us' = gram_schmidt_sub0 n us ws"
      using Cons by simp
    have span: "span (set (us @ w # ws)) = span (set us')"
    proof -
      have wU_U: "span (set (w # us)) = span (set us)"
        apply (subst already_in_span[OF _ True, simplified])
        using Cons by auto
      have "span (set (us @ w # ws)) = span (set (w # us) \<union> set ws)"
        by simp
      also have "\<dots> = span (set us \<union> set ws)"
        apply (rule span_Un) using wU_U Cons by auto
      also have "\<dots> = local.span (set us')"
        using Cons U'_def by auto
      finally show ?thesis
        by -
    qed
    moreover have "set us' \<subseteq> carrier_vec n \<and> distinct us' \<and> corthogonal us'"
      unfolding U'_def using Cons by simp
    ultimately show ?thesis
      by auto
  qed
qed simp

text \<open>This is a variant of \<^term>\<open>Gram_Schmidt.gram_schmidt\<close> that does not require the input vectors
  \<^term>\<open>ws\<close> to be distinct or orthogonal. (In comparison to \<^term>\<open>Gram_Schmidt.gram_schmidt\<close>,
  our version also returns the result in reversed order.)\<close>
definition "gram_schmidt0 n ws = gram_schmidt_sub0 n [] ws"

lemma (in cof_vec_space) gram_schmidt0_result:
  fixes ws
  defines "us' \<equiv> gram_schmidt0 n ws"
  assumes ws: "set ws \<subseteq> carrier_vec n"
  shows "set us' \<subseteq> carrier_vec n"        (is ?thesis1)
    and "distinct us'"                    (is ?thesis2)
    and "corthogonal us'"                 (is ?thesis3)
    and "span (set ws) = span (set us')"  (is ?thesis4)
proof -
  have carrier_empty: "set [] \<subseteq> carrier_vec n" by auto
  have distinct_empty: "distinct []" by simp
  have indep_empty: "lin_indpt (set [])"
    using basis_def subset_li_is_li unit_vecs_basis by auto
  have ortho_empty: "corthogonal []" by auto
  note gram_schmidt_sub0_result' = gram_schmidt_sub0_result
    [OF us'_def[symmetric, THEN meta_eq_to_obj_eq, unfolded gram_schmidt0_def] ws
      carrier_empty distinct_empty indep_empty ortho_empty]
  thus ?thesis1 ?thesis2 ?thesis3 ?thesis4
    by auto
qed

locale complex_vec_space = cof_vec_space n "TYPE(complex)" for n :: nat

lemma gram_schmidt0_corthogonal:
  assumes a1: "corthogonal R"
    and a2: "\<And>x. x \<in> set R \<Longrightarrow> dim_vec x = d"
  shows "gram_schmidt0 d R = rev R"
proof -
  have "gram_schmidt_sub0 d U R = rev R @ U"
    if "corthogonal ((rev U) @ R)"
      and "\<And>x. x \<in> set U \<union> set R \<Longrightarrow> dim_vec x = d" for U
  proof (insert that, induction R arbitrary: U)
    case Nil
    show ?case
      by auto
  next
    case (Cons a R)
    have "a \<in> set (rev U @ a # R)"
      by simp
    moreover have uar: "corthogonal (rev U @ a # R)"
      by (simp add: Cons.prems(1))
    ultimately have \<open>a \<noteq> 0\<^sub>v d\<close>
      unfolding corthogonal_def
      by (metis conjugate_zero_vec in_set_conv_nth scalar_prod_right_zero zero_carrier_vec)
    then have nonzero_a: "\<not> vec_is_zero d a"
      by (simp add: Cons.prems(2) vec_is_zero)
    define T where "T = rev U @ a # R"
    have "T ! length (rev U) = a"
      unfolding T_def
      by (meson nth_append_length)
    moreover have "(T ! i \<bullet>c T ! j = 0) = (i \<noteq> j)" if "i<length T" and "j<length T" for i j
      using uar that
      unfolding corthogonal_def T_def
      by auto
    moreover have "length (rev U) < length T"
      by (simp add: T_def)
    ultimately have "(T ! (length (rev U)) \<bullet>c T ! j = 0) = (length (rev U) \<noteq> j)" if "j<length T" for j
      using that by blast
    hence "T ! (length (rev U)) \<bullet>c T ! j = 0"
      if  "j<length T" and "j \<noteq> length (rev U)" for j
      using that by blast
    hence "a \<bullet>c T ! j = 0" if "j < length (rev U)" for j
      using \<open>T ! length (rev U) = a\<close> that(1)
        \<open>length (rev U) < length T\<close> dual_order.strict_trans by blast
    moreover have "T ! j = (rev U) ! j" if "j < length (rev U)" for j
      by (smt T_def \<open>length (rev U) < length T\<close> dual_order.strict_trans list_update_append1
          list_update_id nth_list_update_eq that)
    ultimately have "a \<bullet>c u = 0" if "u \<in> set (rev U)" for u
      by (metis in_set_conv_nth that)
    hence "a \<bullet>c u = 0" if "u \<in> set U" for u
      by (simp add: that)
    moreover have "\<And>x. x \<in> set U \<Longrightarrow> dim_vec x = d"
      by (simp add: Cons.prems(2))
    ultimately have "adjuster d a U = 0\<^sub>v d"
    proof(induction U)
      case Nil
      then show ?case by simp
    next
      case (Cons u U)
      moreover have "0 \<cdot>\<^sub>v u + 0\<^sub>v d = 0\<^sub>v d"
      proof-
        have "dim_vec u = d"
          by (simp add: calculation(3))
        thus ?thesis
          by auto
      qed
      ultimately show ?case by auto
    qed
    hence adjuster_a: "adjuster d a U + a = a"
      by (simp add: Cons.prems(2) carrier_vecI)
    have "gram_schmidt_sub0 d U (a # R) = gram_schmidt_sub0 d (a # U) R"
      by (simp add: adjuster_a nonzero_a)
    also have "\<dots> = rev (a # R) @ U"
      apply (subst Cons.IH)
      using Cons.prems by simp_all
    finally show ?case
      by -
  qed
  from this[where U="[]"] show ?thesis
    unfolding gram_schmidt0_def using assms by auto
qed

lemma adjuster_carrier': (* Like adjuster_carrier but with one assm less *)
  assumes w: "(w :: 'a::conjugatable_field vec) : carrier_vec n"
    and us: "set (us :: 'a vec list) \<subseteq> carrier_vec n"
  shows "adjuster n w us \<in> carrier_vec n"
  by (insert us, induction us, auto)

lemma eq_mat_on_vecI:
  fixes M N :: \<open>'a::field mat\<close>
  assumes eq: \<open>\<And>v. v\<in>carrier_vec nA \<Longrightarrow> M *\<^sub>v v = N *\<^sub>v v\<close>
  assumes [simp]: \<open>M \<in> carrier_mat nB nA\<close> \<open>N \<in> carrier_mat nB nA\<close>
  shows \<open>M = N\<close>
proof (rule eq_matI)
  show [simp]: \<open>dim_row M = dim_row N\<close> \<open>dim_col M = dim_col N\<close>
    using assms(2) assms(3) by blast+
  fix i j
  assume [simp]: \<open>i < dim_row N\<close> \<open>j < dim_col N\<close>
  show \<open>M $$ (i, j) = N $$ (i, j)\<close>
    thm mat_entry_explicit[where M=M]
    apply (subst mat_entry_explicit[symmetric])
    using assms apply auto[3]
    apply (subst mat_entry_explicit[symmetric])
    using assms apply auto[3]
    apply (subst eq)
     apply auto using assms(3) unit_vec_carrier by blast
qed

lemma list_of_vec_plus:
  fixes v1 v2 :: \<open>complex vec\<close>
  assumes \<open>dim_vec v1 = dim_vec v2\<close>
  shows \<open>list_of_vec (v1 + v2) = map2 (+) (list_of_vec v1) (list_of_vec v2)\<close>
proof-
  have \<open>i < dim_vec v1 \<Longrightarrow> (list_of_vec (v1 + v2)) ! i = (map2 (+) (list_of_vec v1) (list_of_vec v2)) ! i\<close>
    for i
    by (simp add: assms)
  thus ?thesis
    by (metis assms index_add_vec(2) length_list_of_vec length_map map_fst_zip nth_equalityI)
qed

lemma list_of_vec_mult:
  fixes v :: \<open>complex vec\<close>
  shows \<open>list_of_vec (c \<cdot>\<^sub>v v) = map ((*) c) (list_of_vec v)\<close>
  by (metis (mono_tags, lifting) index_smult_vec(1) index_smult_vec(2) length_list_of_vec length_map nth_equalityI nth_list_of_vec nth_map)

unbundle no_jnf_notation

end


(*  Title:      HOL/TLA/Inc/Inc.thy
    Author:     Stephan Merz, University of Munich
*)

section \<open>Lamport's "increment" example\<close>

theory Inc
imports "../TLA"
begin

(* program counter as an enumeration type *)
datatype pcount = a | b | g

axiomatization
  (* program variables *)
  x :: "nat stfun" and
  y :: "nat stfun" and
  sem :: "nat stfun" and
  pc1 :: "pcount stfun" and
  pc2 :: "pcount stfun" and

  (* names of actions and predicates *)
  M1 :: action and
  M2 :: action and
  N1 :: action and
  N2 :: action and
  alpha1 :: action and
  alpha2 :: action and
  beta1 :: action and
  beta2 :: action and
  gamma1 :: action and
  gamma2 :: action and
  InitPhi :: stpred and
  InitPsi :: stpred and
  PsiInv :: stpred and
  PsiInv1 :: stpred and
  PsiInv2 :: stpred and
  PsiInv3 :: stpred and

  (* temporal formulas *)
  Phi :: temporal and
  Psi :: temporal
where
  (* the "base" variables, required to compute enabledness predicates *)
  Inc_base:      "basevars (x, y, sem, pc1, pc2)" and

  (* definitions for high-level program *)
  InitPhi_def:   "InitPhi == PRED x = # 0 \<and> y = # 0" and
  M1_def:        "M1      == ACT  x$ = Suc<$x> \<and> y$ = $y" and
  M2_def:        "M2      == ACT  y$ = Suc<$y> \<and> x$ = $x" and
  Phi_def:       "Phi     == TEMP Init InitPhi \<and> \<box>[M1 \<or> M2]_(x,y)
                                 \<and> WF(M1)_(x,y) \<and> WF(M2)_(x,y)" and

  (* definitions for low-level program *)
  InitPsi_def:   "InitPsi == PRED pc1 = #a \<and> pc2 = #a
                                 \<and> x = # 0 \<and> y = # 0 \<and> sem = # 1" and
  alpha1_def:    "alpha1  == ACT  $pc1 = #a \<and> pc1$ = #b \<and> $sem = Suc<sem$>
                                 \<and> unchanged(x,y,pc2)" and
  alpha2_def:    "alpha2  == ACT  $pc2 = #a \<and> pc2$ = #b \<and> $sem = Suc<sem$>
                                 \<and> unchanged(x,y,pc1)" and
  beta1_def:     "beta1   == ACT  $pc1 = #b \<and> pc1$ = #g \<and> x$ = Suc<$x>
                                 \<and> unchanged(y,sem,pc2)" and
  beta2_def:     "beta2   == ACT  $pc2 = #b \<and> pc2$ = #g \<and> y$ = Suc<$y>
                                 \<and> unchanged(x,sem,pc1)" and
  gamma1_def:    "gamma1  == ACT  $pc1 = #g \<and> pc1$ = #a \<and> sem$ = Suc<$sem>
                                 \<and> unchanged(x,y,pc2)" and
  gamma2_def:    "gamma2  == ACT  $pc2 = #g \<and> pc2$ = #a \<and> sem$ = Suc<$sem>
                                 \<and> unchanged(x,y,pc1)" and
  N1_def:        "N1      == ACT  (alpha1 \<or> beta1 \<or> gamma1)" and
  N2_def:        "N2      == ACT  (alpha2 \<or> beta2 \<or> gamma2)" and
  Psi_def:       "Psi     == TEMP Init InitPsi
                               \<and> \<box>[N1 \<or> N2]_(x,y,sem,pc1,pc2)
                               \<and> SF(N1)_(x,y,sem,pc1,pc2)
                               \<and> SF(N2)_(x,y,sem,pc1,pc2)" and

  PsiInv1_def:  "PsiInv1  == PRED sem = # 1 \<and> pc1 = #a \<and> pc2 = #a" and
  PsiInv2_def:  "PsiInv2  == PRED sem = # 0 \<and> pc1 = #a \<and> (pc2 = #b \<or> pc2 = #g)" and
  PsiInv3_def:  "PsiInv3  == PRED sem = # 0 \<and> pc2 = #a \<and> (pc1 = #b \<or> pc1 = #g)" and
  PsiInv_def:   "PsiInv   == PRED (PsiInv1 \<or> PsiInv2 \<or> PsiInv3)"

lemmas PsiInv_defs = PsiInv_def PsiInv1_def PsiInv2_def PsiInv3_def
lemmas Psi_defs = Psi_def InitPsi_def N1_def N2_def alpha1_def alpha2_def
  beta1_def beta2_def gamma1_def gamma2_def

(*** Invariant proof for Psi: "manual" proof proves individual lemmas ***)

lemma PsiInv_Init: "\<turnstile> InitPsi \<longrightarrow> PsiInv"
  by (auto simp: InitPsi_def PsiInv_defs)

lemma PsiInv_alpha1: "\<turnstile> alpha1 \<and> $PsiInv \<longrightarrow> PsiInv$"
  by (auto simp: alpha1_def PsiInv_defs)

lemma PsiInv_alpha2: "\<turnstile> alpha2 \<and> $PsiInv \<longrightarrow> PsiInv$"
  by (auto simp: alpha2_def PsiInv_defs)

lemma PsiInv_beta1: "\<turnstile> beta1 \<and> $PsiInv \<longrightarrow> PsiInv$"
  by (auto simp: beta1_def PsiInv_defs)

lemma PsiInv_beta2: "\<turnstile> beta2 \<and> $PsiInv \<longrightarrow> PsiInv$"
  by (auto simp: beta2_def PsiInv_defs)

lemma PsiInv_gamma1: "\<turnstile> gamma1 \<and> $PsiInv \<longrightarrow> PsiInv$"
  by (auto simp: gamma1_def PsiInv_defs)

lemma PsiInv_gamma2: "\<turnstile> gamma2 \<and> $PsiInv \<longrightarrow> PsiInv$"
  by (auto simp: gamma2_def PsiInv_defs)

lemma PsiInv_stutter: "\<turnstile> unchanged (x,y,sem,pc1,pc2) \<and> $PsiInv \<longrightarrow> PsiInv$"
  by (auto simp: PsiInv_defs)

lemma PsiInv: "\<turnstile> Psi \<longrightarrow> \<box>PsiInv"
  apply (invariant simp: Psi_def)
   apply (force simp: PsiInv_Init [try_rewrite] Init_def)
  apply (auto intro: PsiInv_alpha1 [try_rewrite] PsiInv_alpha2 [try_rewrite]
    PsiInv_beta1 [try_rewrite] PsiInv_beta2 [try_rewrite] PsiInv_gamma1 [try_rewrite]
    PsiInv_gamma2 [try_rewrite] PsiInv_stutter [try_rewrite]
    simp add: square_def N1_def N2_def)
  done

(* Automatic proof works too, but it make take a while on a slow machine.
   More realistic examples require user guidance anyway.
*)

lemma "\<turnstile> Psi \<longrightarrow> \<box>PsiInv"
  by (auto_invariant simp: PsiInv_defs Psi_defs)

(**** Step simulation ****)

lemma Init_sim: "\<turnstile> Psi \<longrightarrow> Init InitPhi"
  by (auto simp: InitPhi_def Psi_def InitPsi_def Init_def)

lemma Step_sim: "\<turnstile> Psi \<longrightarrow> \<box>[M1 \<or> M2]_(x,y)"
  by (auto simp: square_def M1_def M2_def Psi_defs elim!: STL4E [temp_use])

(**** Proof of fairness ****)

(*
   The goal is to prove Fair_M1 far below, which asserts
         \<turnstile> Psi \<longrightarrow> WF(M1)_(x,y)
   (the other fairness condition is symmetrical).

   The strategy is to use WF2 (with beta1 as the helpful action). Proving its
   temporal premise needs two auxiliary lemmas:
   1. Stuck_at_b: control can only proceed at pc1 = b by executing beta1
   2. N1_live: the first component will eventually reach b

   Lemma 1 is easy, lemma 2 relies on the invariant, the strong fairness
   of the semaphore, and needs auxiliary lemmas that ensure that the second
   component will eventually release the semaphore. Most of the proofs of
   the auxiliary lemmas are very similar.
*)

lemma Stuck_at_b: "\<turnstile> \<box>[(N1 \<or> N2) \<and> \<not> beta1]_(x,y,sem,pc1,pc2) \<longrightarrow> stable(pc1 = #b)"
  by (auto elim!: Stable squareE simp: Psi_defs)

lemma N1_enabled_at_g: "\<turnstile> pc1 = #g \<longrightarrow> Enabled (<N1>_(x,y,sem,pc1,pc2))"
  apply clarsimp
  apply (rule_tac F = gamma1 in enabled_mono)
   apply (enabled Inc_base)
  apply (force simp: gamma1_def)
  apply (force simp: angle_def gamma1_def N1_def)
  done

lemma g1_leadsto_a1:
  "\<turnstile> \<box>[(N1 \<or> N2) \<and> \<not>beta1]_(x,y,sem,pc1,pc2) \<and> SF(N1)_(x,y,sem,pc1,pc2) \<and> \<box>#True
    \<longrightarrow> (pc1 = #g \<leadsto> pc1 = #a)"
  apply (rule SF1)
    apply (tactic
      \<open>action_simp_tac (@{context} addsimps @{thms Psi_defs}) [] [@{thm squareE}] 1\<close>)
   apply (tactic
      \<open>action_simp_tac (@{context} addsimps @{thm angle_def} :: @{thms Psi_defs}) [] [] 1\<close>)
  (* reduce \<turnstile> \<box>A \<longrightarrow> \<diamond>Enabled B  to  \<turnstile> A \<longrightarrow> Enabled B *)
  apply (auto intro!: InitDmd_gen [temp_use] N1_enabled_at_g [temp_use]
    dest!: STL2_gen [temp_use] simp: Init_def)
  done

(* symmetrical for N2, and similar for beta2 *)
lemma N2_enabled_at_g: "\<turnstile> pc2 = #g \<longrightarrow> Enabled (<N2>_(x,y,sem,pc1,pc2))"
  apply clarsimp
  apply (rule_tac F = gamma2 in enabled_mono)
  apply (enabled Inc_base)
   apply (force simp: gamma2_def)
  apply (force simp: angle_def gamma2_def N2_def)
  done

lemma g2_leadsto_a2:
  "\<turnstile> \<box>[(N1 \<or> N2) \<and> \<not>beta1]_(x,y,sem,pc1,pc2) \<and> SF(N2)_(x,y,sem,pc1,pc2) \<and> \<box>#True
    \<longrightarrow> (pc2 = #g \<leadsto> pc2 = #a)"
  apply (rule SF1)
  apply (tactic \<open>action_simp_tac (@{context} addsimps @{thms Psi_defs}) [] [@{thm squareE}] 1\<close>)
  apply (tactic \<open>action_simp_tac (@{context} addsimps @{thm angle_def} :: @{thms Psi_defs})
    [] [] 1\<close>)
  apply (auto intro!: InitDmd_gen [temp_use] N2_enabled_at_g [temp_use]
    dest!: STL2_gen [temp_use] simp add: Init_def)
  done

lemma N2_enabled_at_b: "\<turnstile> pc2 = #b \<longrightarrow> Enabled (<N2>_(x,y,sem,pc1,pc2))"
  apply clarsimp
  apply (rule_tac F = beta2 in enabled_mono)
   apply (enabled Inc_base)
   apply (force simp: beta2_def)
  apply (force simp: angle_def beta2_def N2_def)
  done

lemma b2_leadsto_g2:
  "\<turnstile> \<box>[(N1 \<or> N2) \<and> \<not>beta1]_(x,y,sem,pc1,pc2) \<and> SF(N2)_(x,y,sem,pc1,pc2) \<and> \<box>#True
    \<longrightarrow> (pc2 = #b \<leadsto> pc2 = #g)"
  apply (rule SF1)
    apply (tactic
      \<open>action_simp_tac (@{context} addsimps @{thms Psi_defs}) [] [@{thm squareE}] 1\<close>)
   apply (tactic
     \<open>action_simp_tac (@{context} addsimps @{thm angle_def} :: @{thms Psi_defs}) [] [] 1\<close>)
  apply (auto intro!: InitDmd_gen [temp_use] N2_enabled_at_b [temp_use]
    dest!: STL2_gen [temp_use] simp: Init_def)
  done

(* Combine above lemmas: the second component will eventually reach pc2 = a *)
lemma N2_leadsto_a:
  "\<turnstile> \<box>[(N1 \<or> N2) \<and> \<not>beta1]_(x,y,sem,pc1,pc2) \<and> SF(N2)_(x,y,sem,pc1,pc2) \<and> \<box>#True
    \<longrightarrow> (pc2 = #a \<or> pc2 = #b \<or> pc2 = #g \<leadsto> pc2 = #a)"
  apply (auto intro!: LatticeDisjunctionIntro [temp_use])
    apply (rule LatticeReflexivity [temp_use])
   apply (rule LatticeTransitivity [temp_use])
  apply (auto intro!: b2_leadsto_g2 [temp_use] g2_leadsto_a2 [temp_use])
  done

(* Get rid of disjunction on the left-hand side of \<leadsto> above. *)
lemma N2_live:
  "\<turnstile> \<box>[(N1 \<or> N2) \<and> \<not>beta1]_(x,y,sem,pc1,pc2) \<and> SF(N2)_(x,y,sem,pc1,pc2)
    \<longrightarrow> \<diamond>(pc2 = #a)"
  apply (auto simp: Init_defs intro!: N2_leadsto_a [temp_use, THEN [2] leadsto_init [temp_use]])
  apply (case_tac "pc2 (st1 sigma)")
    apply auto
  done

(* Now prove that the first component will eventually reach pc1 = b from pc1 = a *)

lemma N1_enabled_at_both_a:
  "\<turnstile> pc2 = #a \<and> (PsiInv \<and> pc1 = #a) \<longrightarrow> Enabled (<N1>_(x,y,sem,pc1,pc2))"
  apply clarsimp
  apply (rule_tac F = alpha1 in enabled_mono)
  apply (enabled Inc_base)
   apply (force simp: alpha1_def PsiInv_defs)
  apply (force simp: angle_def alpha1_def N1_def)
  done

lemma a1_leadsto_b1:
  "\<turnstile> \<box>($PsiInv \<and> [(N1 \<or> N2) \<and> \<not>beta1]_(x,y,sem,pc1,pc2))
         \<and> SF(N1)_(x,y,sem,pc1,pc2) \<and> \<box> SF(N2)_(x,y,sem,pc1,pc2)
         \<longrightarrow> (pc1 = #a \<leadsto> pc1 = #b)"
  apply (rule SF1)
  apply (tactic \<open>action_simp_tac (@{context} addsimps @{thms Psi_defs}) [] [@{thm squareE}] 1\<close>)
  apply (tactic
    \<open>action_simp_tac (@{context} addsimps (@{thm angle_def} :: @{thms Psi_defs})) [] [] 1\<close>)
  apply (clarsimp intro!: N1_enabled_at_both_a [THEN DmdImpl [temp_use]])
  apply (auto intro!: BoxDmd2_simple [temp_use] N2_live [temp_use]
    simp: split_box_conj more_temp_simps)
  done

(* Combine the leadsto properties for N1: it will arrive at pc1 = b *)

lemma N1_leadsto_b: "\<turnstile> \<box>($PsiInv \<and> [(N1 \<or> N2) \<and> \<not>beta1]_(x,y,sem,pc1,pc2))
         \<and> SF(N1)_(x,y,sem,pc1,pc2) \<and> \<box> SF(N2)_(x,y,sem,pc1,pc2)
         \<longrightarrow> (pc1 = #b \<or> pc1 = #g \<or> pc1 = #a \<leadsto> pc1 = #b)"
  apply (auto intro!: LatticeDisjunctionIntro [temp_use])
    apply (rule LatticeReflexivity [temp_use])
   apply (rule LatticeTransitivity [temp_use])
    apply (auto intro!: a1_leadsto_b1 [temp_use] g1_leadsto_a1 [temp_use]
      simp: split_box_conj)
  done

lemma N1_live: "\<turnstile> \<box>($PsiInv \<and> [(N1 \<or> N2) \<and> \<not>beta1]_(x,y,sem,pc1,pc2))
         \<and> SF(N1)_(x,y,sem,pc1,pc2) \<and> \<box> SF(N2)_(x,y,sem,pc1,pc2)
         \<longrightarrow> \<diamond>(pc1 = #b)"
  apply (auto simp: Init_defs intro!: N1_leadsto_b [temp_use, THEN [2] leadsto_init [temp_use]])
  apply (case_tac "pc1 (st1 sigma)")
    apply auto
  done

lemma N1_enabled_at_b: "\<turnstile> pc1 = #b \<longrightarrow> Enabled (<N1>_(x,y,sem,pc1,pc2))"
  apply clarsimp
  apply (rule_tac F = beta1 in enabled_mono)
   apply (enabled Inc_base)
   apply (force simp: beta1_def)
  apply (force simp: angle_def beta1_def N1_def)
  done

(* Now assemble the bits and pieces to prove that Psi is fair. *)

lemma Fair_M1_lemma: "\<turnstile> \<box>($PsiInv \<and> [(N1 \<or> N2)]_(x,y,sem,pc1,pc2))
         \<and> SF(N1)_(x,y,sem,pc1,pc2) \<and> \<box>SF(N2)_(x,y,sem,pc1,pc2)
         \<longrightarrow> SF(M1)_(x,y)"
  apply (rule_tac B = beta1 and P = "PRED pc1 = #b" in SF2)
   (* action premises *)
     apply (force simp: angle_def M1_def beta1_def)
  apply (force simp: angle_def Psi_defs)
  apply (force elim!: N1_enabled_at_b [temp_use])
    (* temporal premise: use previous lemmas and simple TL *)
  apply (force intro!: DmdStable [temp_use] N1_live [temp_use] Stuck_at_b [temp_use]
    elim: STL4E [temp_use] simp: square_def)
  done

lemma Fair_M1: "\<turnstile> Psi \<longrightarrow> WF(M1)_(x,y)"
  by (auto intro!: SFImplWF [temp_use] Fair_M1_lemma [temp_use] PsiInv [temp_use]
    simp: Psi_def split_box_conj [temp_use] more_temp_simps)

end


(*  Title:      FOL/FOL.thy
    Author:     Lawrence C Paulson and Markus Wenzel
*)

section \<open>Classical first-order logic\<close>

theory FOL
  imports IFOL
  keywords "print_claset" "print_induct_rules" :: diag
begin

ML_file \<open>~~/src/Provers/classical.ML\<close>
ML_file \<open>~~/src/Provers/blast.ML\<close>
ML_file \<open>~~/src/Provers/clasimp.ML\<close>

subsection \<open>The classical axiom\<close>

axiomatization where
  classical: \<open>(\<not> P \<Longrightarrow> P) \<Longrightarrow> P\<close>

subsection \<open>Lemmas and proof tools\<close>

lemma ccontr: \<open>(\<not> P \<Longrightarrow> False) \<Longrightarrow> P\<close>
  by (erule FalseE [THEN classical])

subsubsection \<open>Classical introduction rules for \<open>\<or>\<close> and \<open>\<exists>\<close>\<close>

lemma disjCI: \<open>(\<not> Q \<Longrightarrow> P) \<Longrightarrow> P \<or> Q\<close>
  apply (rule classical)
  apply (assumption | erule meta_mp | rule disjI1 notI)+
  apply (erule notE disjI2)+
  done

text \<open>Introduction rule involving only \<open>\<exists>\<close>\<close>
lemma ex_classical:
  assumes r: \<open>\<not> (\<exists>x. P(x)) \<Longrightarrow> P(a)\<close>
  shows \<open>\<exists>x. P(x)\<close>
  apply (rule classical)
  apply (rule exI, erule r)
  done

text \<open>Version of above, simplifying \<open>\<not>\<exists>\<close> to \<open>\<forall>\<not>\<close>.\<close>
lemma exCI:
  assumes r: \<open>\<forall>x. \<not> P(x) \<Longrightarrow> P(a)\<close>
  shows \<open>\<exists>x. P(x)\<close>
  apply (rule ex_classical)
  apply (rule notI [THEN allI, THEN r])
  apply (erule notE)
  apply (erule exI)
  done

lemma excluded_middle: \<open>\<not> P \<or> P\<close>
  apply (rule disjCI)
  apply assumption
  done

lemma case_split [case_names True False]:
  assumes r1: \<open>P \<Longrightarrow> Q\<close>
    and r2: \<open>\<not> P \<Longrightarrow> Q\<close>
  shows \<open>Q\<close>
  apply (rule excluded_middle [THEN disjE])
  apply (erule r2)
  apply (erule r1)
  done

ML \<open>
  fun case_tac ctxt a fixes =
    Rule_Insts.res_inst_tac ctxt [((("P", 0), Position.none), a)] fixes @{thm case_split};
\<close>

method_setup case_tac = \<open>
  Args.goal_spec -- Scan.lift (Parse.embedded_inner_syntax -- Parse.for_fixes) >>
    (fn (quant, (s, fixes)) => fn ctxt => SIMPLE_METHOD'' quant (case_tac ctxt s fixes))
\<close> "case_tac emulation (dynamic instantiation!)"

subsection \<open>Special elimination rules\<close>

text \<open>Classical implies (\<open>\<longrightarrow>\<close>) elimination.\<close>
lemma impCE:
  assumes major: \<open>P \<longrightarrow> Q\<close>
    and r1: \<open>\<not> P \<Longrightarrow> R\<close>
    and r2: \<open>Q \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  apply (rule excluded_middle [THEN disjE])
   apply (erule r1)
  apply (rule r2)
  apply (erule major [THEN mp])
  done

text \<open>
  This version of \<open>\<longrightarrow>\<close> elimination works on \<open>Q\<close> before \<open>P\<close>. It works best for those cases in which P holds ``almost everywhere''.
  Can't install as default: would break old proofs.
\<close>
lemma impCE':
  assumes major: \<open>P \<longrightarrow> Q\<close>
    and r1: \<open>Q \<Longrightarrow> R\<close>
    and r2: \<open>\<not> P \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  apply (rule excluded_middle [THEN disjE])
   apply (erule r2)
  apply (rule r1)
  apply (erule major [THEN mp])
  done

text \<open>Double negation law.\<close>
lemma notnotD: \<open>\<not> \<not> P \<Longrightarrow> P\<close>
  apply (rule classical)
  apply (erule notE)
  apply assumption
  done

lemma contrapos2:  \<open>\<lbrakk>Q; \<not> P \<Longrightarrow> \<not> Q\<rbrakk> \<Longrightarrow> P\<close>
  apply (rule classical)
  apply (drule (1) meta_mp)
  apply (erule (1) notE)
  done

subsubsection \<open>Tactics for implication and contradiction\<close>

text \<open>
  Classical \<open>\<longleftrightarrow>\<close> elimination. Proof substitutes \<open>P = Q\<close> in
  \<open>\<not> P \<Longrightarrow> \<not> Q\<close> and \<open>P \<Longrightarrow> Q\<close>.
\<close>
lemma iffCE:
  assumes major: \<open>P \<longleftrightarrow> Q\<close>
    and r1: \<open>\<lbrakk>P; Q\<rbrakk> \<Longrightarrow> R\<close>
    and r2: \<open>\<lbrakk>\<not> P; \<not> Q\<rbrakk> \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  apply (rule major [unfolded iff_def, THEN conjE])
  apply (elim impCE)
     apply (erule (1) r2)
    apply (erule (1) notE)+
  apply (erule (1) r1)
  done

(*Better for fast_tac: needs no quantifier duplication!*)
lemma alt_ex1E:
  assumes major: \<open>\<exists>! x. P(x)\<close>
    and r: \<open>\<And>x. \<lbrakk>P(x);  \<forall>y y'. P(y) \<and> P(y') \<longrightarrow> y = y'\<rbrakk> \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  using major
proof (rule ex1E)
  fix x
  assume * : \<open>\<forall>y. P(y) \<longrightarrow> y = x\<close>
  assume \<open>P(x)\<close>
  then show \<open>R\<close>
  proof (rule r)
    {
      fix y y'
      assume \<open>P(y)\<close> and \<open>P(y')\<close>
      with * have \<open>x = y\<close> and \<open>x = y'\<close>
        by - (tactic "IntPr.fast_tac \<^context> 1")+
      then have \<open>y = y'\<close> by (rule subst)
    } note r' = this
    show \<open>\<forall>y y'. P(y) \<and> P(y') \<longrightarrow> y = y'\<close>
      by (intro strip, elim conjE) (rule r')
  qed
qed

lemma imp_elim: \<open>P \<longrightarrow> Q \<Longrightarrow> (\<not> R \<Longrightarrow> P) \<Longrightarrow> (Q \<Longrightarrow> R) \<Longrightarrow> R\<close>
  by (rule classical) iprover

lemma swap: \<open>\<not> P \<Longrightarrow> (\<not> R \<Longrightarrow> P) \<Longrightarrow> R\<close>
  by (rule classical) iprover

section \<open>Classical Reasoner\<close>

ML \<open>
structure Cla = Classical
(
  val imp_elim = @{thm imp_elim}
  val not_elim = @{thm notE}
  val swap = @{thm swap}
  val classical = @{thm classical}
  val sizef = size_of_thm
  val hyp_subst_tacs = [hyp_subst_tac]
);

structure Basic_Classical: BASIC_CLASSICAL = Cla;
open Basic_Classical;
\<close>

(*Propositional rules*)
lemmas [intro!] = refl TrueI conjI disjCI impI notI iffI
  and [elim!] = conjE disjE impCE FalseE iffCE
ML \<open>val prop_cs = claset_of \<^context>\<close>

(*Quantifier rules*)
lemmas [intro!] = allI ex_ex1I
  and [intro] = exI
  and [elim!] = exE alt_ex1E
  and [elim] = allE
ML \<open>val FOL_cs = claset_of \<^context>\<close>

ML \<open>
  structure Blast = Blast
  (
    structure Classical = Cla
    val Trueprop_const = dest_Const \<^Const>\<open>Trueprop\<close>
    val equality_name = \<^const_name>\<open>eq\<close>
    val not_name = \<^const_name>\<open>Not\<close>
    val notE = @{thm notE}
    val ccontr = @{thm ccontr}
    val hyp_subst_tac = Hypsubst.blast_hyp_subst_tac
  );
  val blast_tac = Blast.blast_tac;
\<close>

lemma ex1_functional: \<open>\<lbrakk>\<exists>! z. P(a,z); P(a,b); P(a,c)\<rbrakk> \<Longrightarrow> b = c\<close>
  by blast

text \<open>Elimination of \<open>True\<close> from assumptions:\<close>
lemma True_implies_equals: \<open>(True \<Longrightarrow> PROP P) \<equiv> PROP P\<close>
proof
  assume \<open>True \<Longrightarrow> PROP P\<close>
  from this and TrueI show \<open>PROP P\<close> .
next
  assume \<open>PROP P\<close>
  then show \<open>PROP P\<close> .
qed

lemma uncurry: \<open>P \<longrightarrow> Q \<longrightarrow> R \<Longrightarrow> P \<and> Q \<longrightarrow> R\<close>
  by blast

lemma iff_allI: \<open>(\<And>x. P(x) \<longleftrightarrow> Q(x)) \<Longrightarrow> (\<forall>x. P(x)) \<longleftrightarrow> (\<forall>x. Q(x))\<close>
  by blast

lemma iff_exI: \<open>(\<And>x. P(x) \<longleftrightarrow> Q(x)) \<Longrightarrow> (\<exists>x. P(x)) \<longleftrightarrow> (\<exists>x. Q(x))\<close>
  by blast

lemma all_comm: \<open>(\<forall>x y. P(x,y)) \<longleftrightarrow> (\<forall>y x. P(x,y))\<close>
  by blast

lemma ex_comm: \<open>(\<exists>x y. P(x,y)) \<longleftrightarrow> (\<exists>y x. P(x,y))\<close>
  by blast

subsection \<open>Classical simplification rules\<close>

text \<open>
  Avoids duplication of subgoals after \<open>expand_if\<close>, when the true and
  false cases boil down to the same thing.
\<close>

lemma cases_simp: \<open>(P \<longrightarrow> Q) \<and> (\<not> P \<longrightarrow> Q) \<longleftrightarrow> Q\<close>
  by blast

subsubsection \<open>Miniscoping: pushing quantifiers in\<close>

text \<open>
  We do NOT distribute of \<open>\<forall>\<close> over \<open>\<and>\<close>, or dually that of
  \<open>\<exists>\<close> over \<open>\<or>\<close>.

  Baaz and Leitsch, On Skolemization and Proof Complexity (1994) show that
  this step can increase proof length!
\<close>

text \<open>Existential miniscoping.\<close>
lemma int_ex_simps:
  \<open>\<And>P Q. (\<exists>x. P(x) \<and> Q) \<longleftrightarrow> (\<exists>x. P(x)) \<and> Q\<close>
  \<open>\<And>P Q. (\<exists>x. P \<and> Q(x)) \<longleftrightarrow> P \<and> (\<exists>x. Q(x))\<close>
  \<open>\<And>P Q. (\<exists>x. P(x) \<or> Q) \<longleftrightarrow> (\<exists>x. P(x)) \<or> Q\<close>
  \<open>\<And>P Q. (\<exists>x. P \<or> Q(x)) \<longleftrightarrow> P \<or> (\<exists>x. Q(x))\<close>
  by iprover+

text \<open>Classical rules.\<close>
lemma cla_ex_simps:
  \<open>\<And>P Q. (\<exists>x. P(x) \<longrightarrow> Q) \<longleftrightarrow> (\<forall>x. P(x)) \<longrightarrow> Q\<close>
  \<open>\<And>P Q. (\<exists>x. P \<longrightarrow> Q(x)) \<longleftrightarrow> P \<longrightarrow> (\<exists>x. Q(x))\<close>
  by blast+

lemmas ex_simps = int_ex_simps cla_ex_simps

text \<open>Universal miniscoping.\<close>
lemma int_all_simps:
  \<open>\<And>P Q. (\<forall>x. P(x) \<and> Q) \<longleftrightarrow> (\<forall>x. P(x)) \<and> Q\<close>
  \<open>\<And>P Q. (\<forall>x. P \<and> Q(x)) \<longleftrightarrow> P \<and> (\<forall>x. Q(x))\<close>
  \<open>\<And>P Q. (\<forall>x. P(x) \<longrightarrow> Q) \<longleftrightarrow> (\<exists> x. P(x)) \<longrightarrow> Q\<close>
  \<open>\<And>P Q. (\<forall>x. P \<longrightarrow> Q(x)) \<longleftrightarrow> P \<longrightarrow> (\<forall>x. Q(x))\<close>
  by iprover+

text \<open>Classical rules.\<close>
lemma cla_all_simps:
  \<open>\<And>P Q. (\<forall>x. P(x) \<or> Q) \<longleftrightarrow> (\<forall>x. P(x)) \<or> Q\<close>
  \<open>\<And>P Q. (\<forall>x. P \<or> Q(x)) \<longleftrightarrow> P \<or> (\<forall>x. Q(x))\<close>
  by blast+

lemmas all_simps = int_all_simps cla_all_simps

subsubsection \<open>Named rewrite rules proved for IFOL\<close>

lemma imp_disj1: \<open>(P \<longrightarrow> Q) \<or> R \<longleftrightarrow> (P \<longrightarrow> Q \<or> R)\<close> by blast
lemma imp_disj2: \<open>Q \<or> (P \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> Q \<or> R)\<close> by blast

lemma de_Morgan_conj: \<open>(\<not> (P \<and> Q)) \<longleftrightarrow> (\<not> P \<or> \<not> Q)\<close> by blast

lemma not_imp: \<open>\<not> (P \<longrightarrow> Q) \<longleftrightarrow> (P \<and> \<not> Q)\<close> by blast
lemma not_iff: \<open>\<not> (P \<longleftrightarrow> Q) \<longleftrightarrow> (P \<longleftrightarrow> \<not> Q)\<close> by blast

lemma not_all: \<open>(\<not> (\<forall>x. P(x))) \<longleftrightarrow> (\<exists>x. \<not> P(x))\<close> by blast
lemma imp_all: \<open>((\<forall>x. P(x)) \<longrightarrow> Q) \<longleftrightarrow> (\<exists>x. P(x) \<longrightarrow> Q)\<close> by blast

lemmas meta_simps =
  triv_forall_equality  \<comment> \<open>prunes params\<close>
  True_implies_equals  \<comment> \<open>prune asms \<open>True\<close>\<close>

lemmas IFOL_simps =
  refl [THEN P_iff_T] conj_simps disj_simps not_simps
  imp_simps iff_simps quant_simps

lemma notFalseI: \<open>\<not> False\<close> by iprover

lemma cla_simps_misc:
  \<open>\<not> (P \<and> Q) \<longleftrightarrow> \<not> P \<or> \<not> Q\<close>
  \<open>P \<or> \<not> P\<close>
  \<open>\<not> P \<or> P\<close>
  \<open>\<not> \<not> P \<longleftrightarrow> P\<close>
  \<open>(\<not> P \<longrightarrow> P) \<longleftrightarrow> P\<close>
  \<open>(\<not> P \<longleftrightarrow> \<not> Q) \<longleftrightarrow> (P \<longleftrightarrow> Q)\<close> by blast+

lemmas cla_simps =
  de_Morgan_conj de_Morgan_disj imp_disj1 imp_disj2
  not_imp not_all not_ex cases_simp cla_simps_misc

ML_file \<open>simpdata.ML\<close>

simproc_setup defined_Ex (\<open>\<exists>x. P(x)\<close>) = \<open>K Quantifier1.rearrange_Ex\<close>
simproc_setup defined_All (\<open>\<forall>x. P(x)\<close>) = \<open>K Quantifier1.rearrange_All\<close>
simproc_setup defined_all("\<And>x. PROP P(x)") = \<open>K Quantifier1.rearrange_all\<close>

ML \<open>
(*intuitionistic simprules only*)
val IFOL_ss =
  put_simpset FOL_basic_ss \<^context>
  addsimps @{thms meta_simps IFOL_simps int_ex_simps int_all_simps subst_all}
  addsimprocs [\<^simproc>\<open>defined_All\<close>, \<^simproc>\<open>defined_Ex\<close>]
  |> Simplifier.add_cong @{thm imp_cong}
  |> simpset_of;

(*classical simprules too*)
val FOL_ss =
  put_simpset IFOL_ss \<^context>
  addsimps @{thms cla_simps cla_ex_simps cla_all_simps}
  |> simpset_of;
\<close>

setup \<open>
  map_theory_simpset (put_simpset FOL_ss) #>
  Simplifier.method_setup Splitter.split_modifiers
\<close>

ML_file \<open>~~/src/Tools/eqsubst.ML\<close>

subsection \<open>Other simple lemmas\<close>

lemma [simp]: \<open>((P \<longrightarrow> Q) \<longleftrightarrow> (P \<longrightarrow> R)) \<longleftrightarrow> (P \<longrightarrow> (Q \<longleftrightarrow> R))\<close>
  by blast

lemma not_disj_iff_imp: \<open>\<not> P \<or> Q \<longleftrightarrow> (P \<longrightarrow> Q)\<close>
  by blast

subsubsection \<open>Monotonicity of implications\<close>

lemma conj_mono: \<open>\<lbrakk>P1 \<longrightarrow> Q1; P2 \<longrightarrow> Q2\<rbrakk> \<Longrightarrow> (P1 \<and> P2) \<longrightarrow> (Q1 \<and> Q2)\<close>
  by fast (*or (IntPr.fast_tac 1)*)

lemma disj_mono: \<open>\<lbrakk>P1 \<longrightarrow> Q1; P2 \<longrightarrow> Q2\<rbrakk> \<Longrightarrow> (P1 \<or> P2) \<longrightarrow> (Q1 \<or> Q2)\<close>
  by fast (*or (IntPr.fast_tac 1)*)

lemma imp_mono: \<open>\<lbrakk>Q1 \<longrightarrow> P1; P2 \<longrightarrow> Q2\<rbrakk> \<Longrightarrow> (P1 \<longrightarrow> P2) \<longrightarrow> (Q1 \<longrightarrow> Q2)\<close>
  by fast (*or (IntPr.fast_tac 1)*)

lemma imp_refl: \<open>P \<longrightarrow> P\<close>
  by (rule impI)

text \<open>The quantifier monotonicity rules are also intuitionistically valid.\<close>
lemma ex_mono: \<open>(\<And>x. P(x) \<longrightarrow> Q(x)) \<Longrightarrow> (\<exists>x. P(x)) \<longrightarrow> (\<exists>x. Q(x))\<close>
  by blast

lemma all_mono: \<open>(\<And>x. P(x) \<longrightarrow> Q(x)) \<Longrightarrow> (\<forall>x. P(x)) \<longrightarrow> (\<forall>x. Q(x))\<close>
  by blast

subsection \<open>Proof by cases and induction\<close>

text \<open>Proper handling of non-atomic rule statements.\<close>

context
begin

qualified definition \<open>induct_forall(P) \<equiv> \<forall>x. P(x)\<close>
qualified definition \<open>induct_implies(A, B) \<equiv> A \<longrightarrow> B\<close>
qualified definition \<open>induct_equal(x, y) \<equiv> x = y\<close>
qualified definition \<open>induct_conj(A, B) \<equiv> A \<and> B\<close>

lemma induct_forall_eq: \<open>(\<And>x. P(x)) \<equiv> Trueprop(induct_forall(\<lambda>x. P(x)))\<close>
  unfolding atomize_all induct_forall_def .

lemma induct_implies_eq: \<open>(A \<Longrightarrow> B) \<equiv> Trueprop(induct_implies(A, B))\<close>
  unfolding atomize_imp induct_implies_def .

lemma induct_equal_eq: \<open>(x \<equiv> y) \<equiv> Trueprop(induct_equal(x, y))\<close>
  unfolding atomize_eq induct_equal_def .

lemma induct_conj_eq: \<open>(A &&& B) \<equiv> Trueprop(induct_conj(A, B))\<close>
  unfolding atomize_conj induct_conj_def .

lemmas induct_atomize = induct_forall_eq induct_implies_eq induct_equal_eq induct_conj_eq
lemmas induct_rulify [symmetric] = induct_atomize
lemmas induct_rulify_fallback =
  induct_forall_def induct_implies_def induct_equal_def induct_conj_def

text \<open>Method setup.\<close>

ML_file \<open>~~/src/Tools/induct.ML\<close>
ML \<open>
  structure Induct = Induct
  (
    val cases_default = @{thm case_split}
    val atomize = @{thms induct_atomize}
    val rulify = @{thms induct_rulify}
    val rulify_fallback = @{thms induct_rulify_fallback}
    val equal_def = @{thm induct_equal_def}
    fun dest_def _ = NONE
    fun trivial_tac _ _ = no_tac
  );
\<close>

declare case_split [cases type: o]

end

ML_file \<open>~~/src/Tools/case_product.ML\<close>

hide_const (open) eq

end