section \<open>Simulations Between Dynamic Executions\<close>

theory Simulation
  imports Semantics Inf Well_founded
begin

subsection \<open>Backward simulation\<close>

locale backward_simulation =
  L1: semantics step1 final1 +
  L2: semantics step2 final2 +
  well_founded "(\<sqsubset>)"
  for
    step1 :: "'state1 \<Rightarrow> 'state1 \<Rightarrow> bool" and
    step2 :: "'state2 \<Rightarrow> 'state2 \<Rightarrow> bool" and
    final1 :: "'state1 \<Rightarrow> bool" and
    final2 :: "'state2 \<Rightarrow> bool" and
    order :: "'index \<Rightarrow> 'index \<Rightarrow> bool" (infix "\<sqsubset>" 70) +
  fixes
    match :: "'index \<Rightarrow> 'state1 \<Rightarrow> 'state2 \<Rightarrow> bool"
  assumes
    match_final:
      "match i s1 s2 \<Longrightarrow> final2 s2 \<Longrightarrow> final1 s1" and
    simulation:
      "match i1 s1 s2 \<Longrightarrow> step2 s2 s2' \<Longrightarrow>
        (\<exists>i2 s1'. step1\<^sup>+\<^sup>+ s1 s1' \<and> match i2 s1' s2') \<or> (\<exists>i2. match i2 s1 s2' \<and> i2 \<sqsubset> i1)"
begin

text \<open>
A simulation is defined between two @{locale semantics} L1 and L2.
A @{term match} predicate expresses that two states from L1 and L2 are equivalent.
The @{term match} predicate is also parameterized with an ordering used to avoid stuttering.
The only two assumptions of a backward simulation are that a final state in L2 will also be a final in L1,and that a step in L2 will either represent a non-empty sequence of steps in L1 or will result in an equivalent state.
Stuttering is ruled out by the requirement that the index on the @{term match} predicate decreases with respect to the well-founded @{term order} ordering.
\<close>

lemma lift_simulation_plus:
  "step2\<^sup>+\<^sup>+ s2 s2' \<Longrightarrow> match i1 s1 s2 \<Longrightarrow>
    (\<exists>i2 s1'. step1\<^sup>+\<^sup>+ s1 s1' \<and> match i2 s1' s2') \<or>
    (\<exists>i2. match i2 s1 s2' \<and> order\<^sup>+\<^sup>+ i2 i1)"
  thm tranclp_induct
proof(induction s2' arbitrary: i1 s1 rule: tranclp_induct)
  case (base s2')
  from simulation[OF base.prems(1) base.hyps(1)] show ?case
    by auto
next
  case (step s2' s2'')
  show ?case
    using step.IH[OF \<open>match i1 s1 s2\<close>]
  proof
    assume "\<exists>i2 s1'. step1\<^sup>+\<^sup>+ s1 s1' \<and> match i2 s1' s2'"
    then obtain i2 s1' where "step1\<^sup>+\<^sup>+ s1 s1'" and "match i2 s1' s2'" by auto
    from simulation[OF \<open>match i2 s1' s2'\<close> \<open>step2 s2' s2''\<close>] show ?thesis
    proof
      assume "\<exists>i3 s1''. step1\<^sup>+\<^sup>+ s1' s1'' \<and> match i3 s1'' s2''"
      then obtain i3 s1'' where "step1\<^sup>+\<^sup>+ s1' s1''" and "match i3 s1'' s2''" by auto
      then show ?thesis
        using tranclp_trans[OF \<open>step1\<^sup>+\<^sup>+ s1 s1'\<close>] by auto
    next
      assume "\<exists>i3. match i3 s1' s2'' \<and> i3 \<sqsubset> i2"
      then obtain i3 where "match i3 s1' s2''" and "i3 \<sqsubset> i2" by auto
      then show ?thesis
        using \<open>step1\<^sup>+\<^sup>+ s1 s1'\<close> by auto
    qed
  next
    assume "\<exists>i2. match i2 s1 s2' \<and> (\<sqsubset>)\<^sup>+\<^sup>+ i2 i1"
    then obtain i3 where "match i3 s1 s2'" and "(\<sqsubset>)\<^sup>+\<^sup>+ i3 i1" by auto
    then show ?thesis
      using simulation[OF \<open>match i3 s1 s2'\<close> \<open>step2 s2' s2''\<close>] by auto
  qed
qed

lemma lift_simulation_eval:
  "L2.eval s2 s2' \<Longrightarrow> match i1 s1 s2 \<Longrightarrow> \<exists>i2 s1'. L1.eval s1 s1' \<and> match i2 s1' s2'"
proof(induction s2 arbitrary: i1 s1 rule: converse_rtranclp_induct)
  case (base s2)
  thus ?case by auto
next
  case (step s2 s2'')
  from simulation[OF \<open>match i1 s1 s2\<close> \<open>step2 s2 s2''\<close>] show ?case
  proof
    assume "\<exists>i2 s1'. step1\<^sup>+\<^sup>+ s1 s1' \<and> match i2 s1' s2''"
    thus ?thesis
      by (meson rtranclp_trans step.IH tranclp_into_rtranclp)
  next
    assume "\<exists>i2. match i2 s1 s2'' \<and> i2 \<sqsubset> i1"
    thus ?thesis
      by (auto intro: step.IH)
  qed
qed

lemma match_inf:
  assumes
    "match i s1 s2" and
    "inf step2 s2"
  shows "inf step1 s1"
proof -
  from assms have "inf_wf step1 order i s1"
  proof (coinduction arbitrary: i s1 s2)
    case inf_wf
    obtain s2' where "step2 s2 s2'" and "inf step2 s2'"
      using inf_wf(2) by (auto elim: inf.cases)
    from simulation[OF \<open>match i s1 s2\<close> \<open>step2 s2 s2'\<close>] show ?case
      using \<open>inf step2 s2'\<close> by auto
  qed
  thus ?thesis using inf_wf_to_inf
    by (auto intro: inf_wf_to_inf well_founded_axioms)
qed

subsubsection \<open>Preservation of behaviour\<close>

text \<open>
The main correctness theorem states that, for any two matching programs, any not wrong behaviour of the later is also a behaviour of the former.
In other words, if the compiled program does not crash, then its behaviour, whether it terminates or not, is a also a valid behaviour of the source program.
\<close>

lemma simulation_behaviour :
  "L2.state_behaves s\<^sub>2 b\<^sub>2 \<Longrightarrow> \<not>is_wrong b\<^sub>2 \<Longrightarrow> match i s\<^sub>1 s\<^sub>2 \<Longrightarrow>
    \<exists>b\<^sub>1 i'. L1.state_behaves s\<^sub>1 b\<^sub>1 \<and> rel_behaviour (match i') b\<^sub>1 b\<^sub>2"
proof(induction rule: L2.state_behaves.cases)
  case (state_terminates s2 s2')
  then obtain i' s1' where "L1.eval s\<^sub>1 s1'" and "match i' s1' s2'"
    using lift_simulation_eval by blast
  hence "final1 s1'"
    by (auto intro: state_terminates.hyps match_final)
  hence "L1.state_behaves s\<^sub>1 (Terminates s1')"
    using L1.final_finished
    by (simp add: L1.state_terminates \<open>L1.eval s\<^sub>1 s1'\<close>)
  moreover have "rel_behaviour (match i') (Terminates s1') b\<^sub>2"
    by (simp add: \<open>match i' s1' s2'\<close> state_terminates.hyps)
  ultimately show ?case by blast
next
  case (state_diverges s2)
  then show ?case
    using match_inf L1.state_diverges by fastforce
next
  case (state_goes_wrong s2 s2')
  then show ?case using \<open>\<not>is_wrong b\<^sub>2\<close> by simp
qed

end

subsection \<open>Forward simulation\<close>

locale forward_simulation =
  L1: semantics step1 final1 +
  L2: semantics step2 final2 +
  well_founded "(\<sqsubset>)"
  for
    step1 :: "'state1 \<Rightarrow> 'state1 \<Rightarrow> bool" and
    step2 :: "'state2 \<Rightarrow> 'state2 \<Rightarrow> bool" and
    final1 :: "'state1 \<Rightarrow> bool" and
    final2 :: "'state2 \<Rightarrow> bool" and
    order :: "'index \<Rightarrow> 'index \<Rightarrow> bool" (infix "\<sqsubset>" 70) +
  fixes
    match :: "'index \<Rightarrow> 'state1 \<Rightarrow> 'state2 \<Rightarrow> bool"
  assumes
    match_final:
      "match i s1 s2 \<Longrightarrow> final1 s1 \<Longrightarrow> final2 s2" and
    simulation:
      "match i s1 s2 \<Longrightarrow> step1 s1 s1' \<Longrightarrow>
        (\<exists>i' s2'. step2\<^sup>+\<^sup>+ s2 s2' \<and> match i' s1' s2') \<or> (\<exists>i'. match i' s1' s2 \<and> i' \<sqsubset> i)"
begin

lemma lift_simulation_eval:
  "L1.eval s1 s1' \<Longrightarrow> match i s1 s2 \<Longrightarrow> \<exists>i' s2'. L2.eval s2 s2' \<and> match i' s1' s2'"
proof(induction s1 arbitrary: i s2 rule: converse_rtranclp_induct)
  case (base s2)
  thus ?case by auto
next
  case (step s1 s1'')
  show ?case
    using simulation[OF \<open>match i s1 s2\<close> \<open>step1 s1 s1''\<close>]
  proof (elim disjE exE conjE)
    fix i' s2'
    assume "step2\<^sup>+\<^sup>+ s2 s2'" and "match i' s1'' s2'"
    thus ?thesis
      by (auto intro: rtranclp_trans dest!: tranclp_into_rtranclp step.IH)
  next
    fix i'
    assume "match i' s1'' s2" and "i' \<sqsubset> i"
    thus ?thesis
      by (auto intro: step.IH)
  qed
qed

lemma match_inf:
  assumes "match i s1 s2" and "inf step1 s1"
  shows "inf step2 s2"
proof -
  from assms have "inf_wf step2 order i s2"
  proof (coinduction arbitrary: i s1 s2)
    case inf_wf
    obtain s1' where step_s1: "step1 s1 s1'" and inf_s1': "inf step1 s1'"
      using inf_wf(2) by (auto elim: inf.cases)
    from simulation[OF \<open>match i s1 s2\<close> step_s1] show ?case
      using inf_s1' by auto
  qed
  thus ?thesis using inf_wf_to_inf
    by (auto intro: inf_wf_to_inf well_founded_axioms)
qed

subsubsection \<open>Preservation of behaviour\<close>

lemma simulation_behaviour :
  "L1.state_behaves s1 b1 \<Longrightarrow> \<not> is_wrong b1 \<Longrightarrow> match i s1 s2 \<Longrightarrow>
    \<exists>b2 i'. L2.state_behaves s2 b2 \<and> rel_behaviour (match i') b1 b2"
proof(induction rule: L1.state_behaves.cases)
  case (state_terminates s1 s1')
  then obtain i' s2' where steps_s2: "L2.eval s2 s2'" and match_s1'_s2': "match i' s1' s2'"
    using lift_simulation_eval by blast
  hence "final2 s2'"
    by (auto intro: state_terminates.hyps match_final)
  hence "L2.state_behaves s2 (Terminates s2')"
    using L2.final_finished L2.state_terminates[OF steps_s2]
    by simp
  moreover have "rel_behaviour (match i') b1 (Terminates s2')"
    by (simp add: \<open>match i' s1' s2'\<close> state_terminates.hyps)
  ultimately show ?case by blast
next
  case (state_diverges s2)
  then show ?case
    using match_inf[THEN L2.state_diverges] by fastforce
next
  case (state_goes_wrong s2 s2')
  then show ?case using \<open>\<not>is_wrong b1\<close> by simp
qed

subsubsection \<open>Forward to backward\<close>

lemma state_behaves_forward_to_backward:
  assumes
    match_s1_s2: "match i s1 s2" and
    safe_s1: "L1.safe s1" and
    behaves_s2: "L2.state_behaves s2 b2" and
    right_unique2: "right_unique step2"
  shows "\<exists>b1 i. L1.state_behaves s1 b1 \<and> rel_behaviour (match i) b1 b2"
proof -
  obtain b1 where behaves_s1: "L1.state_behaves s1 b1"
    using L1.left_total_state_behaves
    by (auto elim: left_totalE)

  have not_wrong_b1: "\<not> is_wrong b1"
    by (rule L1.safe_state_behaves_not_wrong[OF safe_s1 behaves_s1])

  obtain i' where "L2.state_behaves s2 b2" and rel_b1_B2: "rel_behaviour (match i') b1 b2"
    using simulation_behaviour[OF behaves_s1 not_wrong_b1 match_s1_s2]
    using L2.right_unique_state_behaves[OF right_unique2, THEN right_uniqueD]
    using behaves_s2
    by auto

  show ?thesis
    using behaves_s1 rel_b1_B2 by auto
qed

end

subsection \<open>Bisimulation\<close>

locale bisimulation =
  forward_simulation step1 step2 final1 final2 order match +
  backward_simulation step1 step2 final1 final2 order match
  for
    step1 :: "'state1 \<Rightarrow> 'state1 \<Rightarrow> bool" and
    step2 :: "'state2 \<Rightarrow> 'state2 \<Rightarrow> bool" and
    final1 :: "'state1 \<Rightarrow> bool" and
    final2 :: "'state2 \<Rightarrow> bool" and
    order :: "'index \<Rightarrow> 'index \<Rightarrow> bool" and
    match :: "'index \<Rightarrow> 'state1 \<Rightarrow> 'state2 \<Rightarrow> bool"

subsection \<open>Composition of backward simulations\<close>

definition rel_comp ::
  "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('d \<Rightarrow> 'c \<Rightarrow> 'e \<Rightarrow> bool) \<Rightarrow> ('a \<times> 'd) \<Rightarrow> 'b \<Rightarrow> 'e \<Rightarrow> bool" where
  "rel_comp r1 r2 i \<equiv> (r1 (fst i) OO r2 (snd i))"

lemma backward_simulation_composition:
  assumes
    "backward_simulation step1 step2 final1 final2 order1 match1"
    "backward_simulation step2 step3 final2 final3 order2 match2"
  shows
    "backward_simulation step1 step3 final1 final3
      (lex_prodp order1\<^sup>+\<^sup>+ order2) (rel_comp match1 match2)"
proof intro_locales
  show "semantics step1 final1"
    by (auto intro: backward_simulation.axioms assms)
next
  show "semantics step3 final3"
    by (auto intro: backward_simulation.axioms assms)
next
  show "well_founded (lex_prodp order1\<^sup>+\<^sup>+ order2)"
    using assms[THEN backward_simulation.axioms(3)]
    by (simp add: lex_prodp_well_founded well_founded.intro well_founded.wf wfP_trancl)
next
  show "backward_simulation_axioms step1 step3 final1 final3
    (lex_prodp order1\<^sup>+\<^sup>+ order2) (rel_comp match1 match2)"
  proof
    fix i s1 s3
    assume
      match: "rel_comp match1 match2 i s1 s3" and
      final: "final3 s3"
    obtain i1 i2 s2 where "match1 i1 s1 s2" and "match2 i2 s2 s3" and "i = (i1, i2)"
      using match unfolding rel_comp_def by auto
    thus "final1 s1"
      using final assms[THEN backward_simulation.match_final]
      by simp
  next
    fix i s1 s3 s3'
    assume
      match: "rel_comp match1 match2 i s1 s3" and
      step: "step3 s3 s3'"
    obtain i1 i2 s2 where "match1 i1 s1 s2" and "match2 i2 s2 s3" and i_def: "i = (i1, i2)"
      using match unfolding rel_comp_def by auto
    from backward_simulation.simulation[OF assms(2) \<open>match2 i2 s2 s3\<close> step]
    show "(\<exists>i' s1'. step1\<^sup>+\<^sup>+ s1 s1' \<and> rel_comp match1 match2 i' s1' s3') \<or>
       (\<exists>i'. rel_comp match1 match2 i' s1 s3' \<and> lex_prodp order1\<^sup>+\<^sup>+ order2 i' i)"
      (is "(\<exists>i' s1'. ?STEPS i' s1') \<or> ?STALL")
    proof
      assume "\<exists>i2' s2'. step2\<^sup>+\<^sup>+ s2 s2' \<and> match2 i2' s2' s3'"
      then obtain i2' s2' where "step2\<^sup>+\<^sup>+ s2 s2'" and "match2 i2' s2' s3'" by auto
      from backward_simulation.lift_simulation_plus[OF assms(1) \<open>step2\<^sup>+\<^sup>+ s2 s2'\<close> \<open>match1 i1 s1 s2\<close>]
      show ?thesis
      proof
        assume "\<exists>i2 s1'. step1\<^sup>+\<^sup>+ s1 s1' \<and> match1 i2 s1' s2'"
        then obtain i2 s1' where "step1\<^sup>+\<^sup>+ s1 s1'" and "match1 i2 s1' s2'" by auto
        hence "?STEPS (i2, i2') s1'"
          by (auto intro: \<open>match2 i2' s2' s3'\<close> simp: rel_comp_def)
        thus ?thesis by auto
      next
        assume "\<exists>i2. match1 i2 s1 s2' \<and> order1\<^sup>+\<^sup>+ i2 i1"
        then obtain i2'' where "match1 i2'' s1 s2'" and "order1\<^sup>+\<^sup>+ i2'' i1" by auto
        hence ?STALL
          unfolding rel_comp_def i_def lex_prodp_def
          using \<open>match2 i2' s2' s3'\<close> by auto
        thus ?thesis by simp
      qed
    next
      assume "\<exists>i2'. match2 i2' s2 s3' \<and> order2 i2' i2"
      then obtain i2' where "match2 i2' s2 s3'" and "order2 i2' i2" by auto
      hence ?STALL
        unfolding rel_comp_def i_def lex_prodp_def
        using \<open>match1 i1 s1 s2\<close> by auto
      thus ?thesis by simp
    qed
  qed
qed

context
  fixes r :: "'i \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

fun rel_comp_pow where
  "rel_comp_pow [] x y = False" |
  "rel_comp_pow [i] x y = r i x y" |
  "rel_comp_pow (i # is) x z = (\<exists>y. r i x y \<and> rel_comp_pow is y z)"

end

lemma backward_simulation_pow:
  assumes
    "backward_simulation step step final final order match"
  shows
    "backward_simulation step step final final (lexp order\<^sup>+\<^sup>+) (rel_comp_pow match)"
proof intro_locales
  show "semantics step final"
    by (auto intro: backward_simulation.axioms assms)
next
  show "well_founded (lexp order\<^sup>+\<^sup>+)"
    using backward_simulation.axioms(3)[OF assms] lex_list_well_founded
    using well_founded.intro well_founded.wf wfP_trancl by blast
next
  show "backward_simulation_axioms step step final final (lexp order\<^sup>+\<^sup>+) (rel_comp_pow match)"
  proof unfold_locales
    fix "is" s1 s2
    assume "rel_comp_pow match is s1 s2" and "final s2"
    thus "final s1" thm rel_comp_pow.induct
    proof (induction "is" s1 s2 rule: rel_comp_pow.induct)
      case (1 x y)
      then show ?case by simp
    next
      case (2 i x y)
      then show ?case
        using backward_simulation.match_final[OF assms(1)] by simp
    next
      case (3 i1 i2 "is" x z)
      from "3.prems"[simplified] obtain y where
        match: "match i1 x y" and "rel_comp_pow match (i2 # is) y z"
        by auto
      hence "final y" using "3.IH" "3.prems" by simp
      thus ?case
        using "3.prems" match backward_simulation.match_final[OF assms(1)] by auto
    qed
  next
    fix "is" s1 s3 s3'
    assume "rel_comp_pow match is s1 s3" and "step s3 s3'"
    hence "(\<exists>is' s1'. step\<^sup>+\<^sup>+ s1 s1' \<and> length is' = length is \<and> rel_comp_pow match is' s1' s3') \<or>
      (\<exists>is'. rel_comp_pow match is' s1 s3' \<and> lexp order\<^sup>+\<^sup>+ is' is)"
    proof (induction "is" s1 s3 arbitrary: s3' rule: rel_comp_pow.induct)
      case 1
      then show ?case by simp
    next
      case (2 i s1 s3)
      from backward_simulation.simulation[OF assms(1) "2.prems"[simplified]] show ?case
      proof
        assume "\<exists>i' s1'. step\<^sup>+\<^sup>+ s1 s1' \<and> match i' s1' s3'"
        then obtain i' s1' where "step\<^sup>+\<^sup>+ s1 s1'" and "match i' s1' s3'" by auto
        hence "step\<^sup>+\<^sup>+ s1 s1' \<and> rel_comp_pow match [i'] s1' s3'" by simp
        thus ?thesis
          by (metis length_Cons)
      next
        assume "\<exists>i'. match i' s1 s3' \<and> order i' i"
        then obtain i' where "match i' s1 s3'" and "order i' i" by auto
        hence "rel_comp_pow match [i'] s1 s3' \<and> lexp order\<^sup>+\<^sup>+ [i'] [i]"
          by (simp add: lexp_head tranclp.r_into_trancl)
        thus ?thesis by blast
      qed
    next
      case (3 i1 i2 "is" s1 s3)
      from "3.prems"[simplified] obtain s2 where
        "match i1 s1 s2" and 0: "rel_comp_pow match (i2 # is) s2 s3"
        by auto
      from "3.IH"[OF 0 "3.prems"(2)] show ?case
      proof
        assume "\<exists>is' s2'. step\<^sup>+\<^sup>+ s2 s2' \<and> length is' = length (i2 # is) \<and>
          rel_comp_pow match is' s2' s3'"
        then obtain i2' is' s2' where
          "step\<^sup>+\<^sup>+ s2 s2'" and "length is' = length is" and "rel_comp_pow match (i2' # is') s2' s3'"
          by (metis Suc_length_conv)
        from backward_simulation.lift_simulation_plus[OF assms(1) \<open>step\<^sup>+\<^sup>+ s2 s2'\<close> \<open>match i1 s1 s2\<close>]
        show ?thesis
        proof
          assume "\<exists>i2 s1'. step\<^sup>+\<^sup>+ s1 s1' \<and> match i2 s1' s2'"
          thus ?thesis
            using \<open>rel_comp_pow match (i2' # is') s2' s3'\<close>
            by (metis \<open>length is' = length is\<close> length_Cons rel_comp_pow.simps(3))
        next
          assume "\<exists>i2. match i2 s1 s2' \<and> order\<^sup>+\<^sup>+ i2 i1"
          then obtain i1' where "match i1' s1 s2'" and "order\<^sup>+\<^sup>+ i1' i1" by auto
          hence "rel_comp_pow match (i1' # i2' # is') s1 s3'"
            using \<open>rel_comp_pow match (i2' # is') s2' s3'\<close> by auto
          moreover have "lexp order\<^sup>+\<^sup>+ (i1' # i2' # is') (i1 # i2 # is)"
            using \<open>order\<^sup>+\<^sup>+ i1' i1\<close> \<open>length is' = length is\<close>
            by (auto intro: lexp_head)
          ultimately show ?thesis by fast
        qed
      next
        assume "\<exists>i'. rel_comp_pow match i' s2 s3' \<and> lexp order\<^sup>+\<^sup>+ i' (i2 # is)"
        then obtain i2' is' where
          "rel_comp_pow match (i2' # is') s2 s3'" and "lexp order\<^sup>+\<^sup>+ (i2' # is') (i2 # is)"
          by (metis lexp.simps)
        thus ?thesis
          by (metis \<open>match i1 s1 s2\<close> lexp.simps(1) rel_comp_pow.simps(3))
      qed
    qed
    thus "(\<exists>is' s1'. step\<^sup>+\<^sup>+ s1 s1' \<and> rel_comp_pow match is' s1' s3') \<or>
      (\<exists>is'. rel_comp_pow match is' s1 s3' \<and> lexp order\<^sup>+\<^sup>+ is' is)"
      by auto
  qed
qed

definition lockstep_backward_simulation where
  "lockstep_backward_simulation step1 step2 match \<equiv>
    \<forall>s1 s2 s2'. match s1 s2 \<longrightarrow> step2 s2 s2' \<longrightarrow> (\<exists>s1'. step1 s1 s1' \<and> match s1' s2')"

definition plus_backward_simulation where
  "plus_backward_simulation step1 step2 match \<equiv>
    \<forall>s1 s2 s2'. match s1 s2 \<longrightarrow> step2 s2 s2' \<longrightarrow> (\<exists>s1'. step1\<^sup>+\<^sup>+ s1 s1' \<and> match s1' s2')"

lemma
  assumes "lockstep_backward_simulation step1 step2 match"
  shows "plus_backward_simulation step1 step2 match"
unfolding plus_backward_simulation_def
proof safe
  fix s1 s2 s2'
  assume "match s1 s2" and "step2 s2 s2'"
  then obtain s1' where "step1 s1 s1'" and "match s1' s2'"
    using assms(1) unfolding lockstep_backward_simulation_def by blast
  then show "\<exists>s1'. step1\<^sup>+\<^sup>+ s1 s1' \<and> match s1' s2'"
    by auto
qed

lemma lockstep_to_plus_backward_simulation:
  fixes
    match :: "'state1 \<Rightarrow> 'state2 \<Rightarrow> bool" and
    step1 :: "'state1 \<Rightarrow> 'state1 \<Rightarrow> bool" and
    step2 :: "'state2 \<Rightarrow> 'state2 \<Rightarrow> bool"
  assumes
    lockstep_simulation: "\<And>s1 s2 s2'. match s1 s2 \<Longrightarrow> step2 s2 s2' \<Longrightarrow> (\<exists>s1'. step1 s1 s1' \<and> match s1' s2')" and
    match: "match s1 s2" and
    step: "step2 s2 s2'"
  shows "\<exists>s1'. step1\<^sup>+\<^sup>+ s1 s1' \<and> match s1' s2'"
proof -
  obtain s1' where "step1 s1 s1'" and "match s1' s2'"
    using lockstep_simulation[OF match step] by auto
  thus ?thesis by auto
qed

lemma lockstep_to_option_backward_simulation:
  fixes
    match :: "'state1 \<Rightarrow> 'state2 \<Rightarrow> bool" and
    step1 :: "'state1 \<Rightarrow> 'state1 \<Rightarrow> bool" and
    step2 :: "'state2 \<Rightarrow> 'state2 \<Rightarrow> bool" and
    measure :: "'state2 \<Rightarrow> nat"
  assumes
    lockstep_simulation: "\<And>s1 s2 s2'. match s1 s2 \<Longrightarrow> step2 s2 s2' \<Longrightarrow> (\<exists>s1'. step1 s1 s1' \<and> match s1' s2')" and
    match: "match s1 s2" and
    step: "step2 s2 s2'"
  shows "(\<exists>s1'. step1 s1 s1' \<and> match s1' s2') \<or> match s1 s2' \<and> measure s2' < measure s2"
  using lockstep_simulation[OF match step] ..

lemma plus_to_star_backward_simulation:
  fixes
    match :: "'state1 \<Rightarrow> 'state2 \<Rightarrow> bool" and
    step1 :: "'state1 \<Rightarrow> 'state1 \<Rightarrow> bool" and
    step2 :: "'state2 \<Rightarrow> 'state2 \<Rightarrow> bool" and
    measure :: "'state2 \<Rightarrow> nat"
  assumes
    star_simulation: "\<And>s1 s2 s2'. match s1 s2 \<Longrightarrow> step2 s2 s2' \<Longrightarrow> (\<exists>s1'. step1\<^sup>+\<^sup>+ s1 s1' \<and> match s1' s2')" and
    match: "match s1 s2" and
    step: "step2 s2 s2'"
  shows "(\<exists>s1'. step1\<^sup>+\<^sup>+ s1 s1' \<and> match s1' s2') \<or> match s1 s2' \<and> measure s2' < measure s2"
  using star_simulation[OF match step] ..

lemma lockstep_to_plus_forward_simulation:
  fixes
    match :: "'state1 \<Rightarrow> 'state2 \<Rightarrow> bool" and
    step1 :: "'state1 \<Rightarrow> 'state1 \<Rightarrow> bool" and
    step2 :: "'state2 \<Rightarrow> 'state2 \<Rightarrow> bool"
  assumes
    lockstep_simulation: "\<And>s1 s2 s2'. match s1 s2 \<Longrightarrow> step1 s1 s1' \<Longrightarrow> (\<exists>s2'. step2 s2 s2' \<and> match s1' s2')" and
    match: "match s1 s2" and
    step: "step1 s1 s1'"
  shows "\<exists>s2'. step2\<^sup>+\<^sup>+ s2 s2' \<and> match s1' s2'"
proof -
  obtain s2' where "step2 s2 s2'" and "match s1' s2'"
    using lockstep_simulation[OF match step] by auto
  thus ?thesis by auto
qed

end


(* Title: thys/Recs_alt_Def.thy
   Author: Christian Urban
 *)

chapter \<open>An alternative modelling of Recursive Functions\<close>

theory Recs_alt_Def
  imports Main
    "HOL-Library.Nat_Bijection"
    "HOL-Library.Discrete"
begin

text\<open>
  A more streamlined and cleaned-up version of Recursive
  Functions following

    A Course in Formal Languages, Automata and Groups
    I. M. Chiswell

  and

    Lecture on Undecidability
    Michael M. Wolf
\<close>

declare One_nat_def[simp del]

lemma if_zero_one [simp]:
  "(if P then 1 else 0) = (0::nat) \<longleftrightarrow> \<not> P"
  "(0::nat) < (if P then 1 else 0) = P"
  "(if P then 0 else 1) = (if \<not>P then 1 else (0::nat))"
  by (simp_all)

lemma nth:
  "(x # xs) ! 0 = x"
  "(x # y # xs) ! 1 = y"
  "(x # y # z # xs) ! 2 = z"
  "(x # y # z # u # xs) ! 3 = u"
  by (simp_all)

section \<open>Some auxiliary lemmas about the Recursive Functions Sigma and Pi\<close>

lemma setprod_atMost_Suc[simp]:
  "(\<Prod>i \<le> Suc n. f i) = (\<Prod>i \<le> n. f i) * f(Suc n)"
  by(simp add:atMost_Suc mult_ac)

lemma setprod_lessThan_Suc[simp]:
  "(\<Prod>i < Suc n. f i) = (\<Prod>i < n. f i) * f n"
  by (simp add:lessThan_Suc mult_ac)

lemma setsum_add_nat_ivl2: "n \<le> p  \<Longrightarrow>
  sum f {..<n} + sum f {n..p} = sum f {..p::nat}"
  apply(subst sum.union_disjoint[symmetric])
     apply(auto simp add: ivl_disj_un_one)
  done

lemma setsum_eq_zero [simp]:
  fixes f::"nat \<Rightarrow> nat"
  shows "(\<Sum>i < n. f i) = 0 \<longleftrightarrow> (\<forall>i < n. f i = 0)"
    "(\<Sum>i \<le> n. f i) = 0 \<longleftrightarrow> (\<forall>i \<le> n. f i = 0)"
  by (auto)

lemma setprod_eq_zero [simp]:
  fixes f::"nat \<Rightarrow> nat"
  shows "(\<Prod>i < n. f i) = 0 \<longleftrightarrow> (\<exists>i < n. f i = 0)"
    "(\<Prod>i \<le> n. f i) = 0 \<longleftrightarrow> (\<exists>i \<le> n. f i = 0)"
  by (auto)

lemma setsum_one_less:
  fixes n::nat
  assumes "\<forall>i < n. f i \<le> 1"
  shows "(\<Sum>i < n. f i) \<le> n"
  using assms
  by (induct n) (auto)

lemma setsum_one_le:
  fixes n::nat
  assumes "\<forall>i \<le> n. f i \<le> 1"
  shows "(\<Sum>i \<le> n. f i) \<le> Suc n"
  using assms
  by (induct n) (auto)

lemma setsum_eq_one_le:
  fixes n::nat
  assumes "\<forall>i \<le> n. f i = 1"
  shows "(\<Sum>i \<le> n. f i) = Suc n"
  using assms
  by (induct n) (auto)

lemma setsum_least_eq:
  fixes f::"nat \<Rightarrow> nat"
  assumes h0: "p \<le> n"
  assumes h1: "\<forall>i \<in> {..<p}. f i = 1"
  assumes h2: "\<forall>i \<in> {p..n}. f i = 0"
  shows "(\<Sum>i \<le> n. f i) = p"
proof -
  have eq_p: "(\<Sum>i \<in> {..<p}. f i) = p"
    using h1 by (induct p) (simp_all)
  have eq_zero: "(\<Sum>i \<in> {p..n}. f i) = 0"
    using h2 by auto
  have "(\<Sum>i \<le> n. f i) = (\<Sum>i \<in> {..<p}. f i) + (\<Sum>i \<in> {p..n}. f i)"
    using h0 by (simp add: setsum_add_nat_ivl2)
  also have "... = (\<Sum>i \<in> {..<p}. f i)" using eq_zero by simp
  finally show "(\<Sum>i \<le> n. f i) = p" using eq_p by simp
qed

lemma nat_mult_le_one:
  fixes m n::nat
  assumes "m \<le> 1" "n \<le> 1"
  shows "m * n \<le> 1"
  using assms by (induct n) (auto)

lemma setprod_one_le:
  fixes f::"nat \<Rightarrow> nat"
  assumes "\<forall>i \<le> n. f i \<le> 1"
  shows "(\<Prod>i \<le> n. f i) \<le> 1"
  using assms
  by (induct n) (auto intro: nat_mult_le_one)

lemma setprod_greater_zero:
  fixes f::"nat \<Rightarrow> nat"
  assumes "\<forall>i \<le> n. f i \<ge> 0"
  shows "(\<Prod>i \<le> n. f i) \<ge> 0"
  using assms by (induct n) (auto)

lemma setprod_eq_one:
  fixes f::"nat \<Rightarrow> nat"
  assumes "\<forall>i \<le> n. f i = Suc 0"
  shows "(\<Prod>i \<le> n. f i) = Suc 0"
  using assms by (induct n) (auto)

lemma setsum_cut_off_less:
  fixes f::"nat \<Rightarrow> nat"
  assumes h1: "m \<le> n"
    and     h2: "\<forall>i \<in> {m..<n}. f i = 0"
  shows "(\<Sum>i < n. f i) = (\<Sum>i < m. f i)"
proof -
  have eq_zero: "(\<Sum>i \<in> {m..<n}. f i) = 0"
    using h2 by auto
  have "(\<Sum>i < n. f i) = (\<Sum>i \<in> {..<m}. f i) + (\<Sum>i \<in> {m..<n}. f i)"
    using h1 by (metis atLeast0LessThan le0 sum.atLeastLessThan_concat)
  also have "... = (\<Sum>i \<in> {..<m}. f i)" using eq_zero by simp
  finally show "(\<Sum>i < n. f i) = (\<Sum>i < m. f i)" by simp
qed

lemma setsum_cut_off_le:
  fixes f::"nat \<Rightarrow> nat"
  assumes h1: "m \<le> n"
    and     h2: "\<forall>i \<in> {m..n}. f i = 0"
  shows "(\<Sum>i \<le> n. f i) = (\<Sum>i < m. f i)"
proof -
  have eq_zero: "(\<Sum>i \<in> {m..n}. f i) = 0"
    using h2 by auto
  have "(\<Sum>i \<le> n. f i) = (\<Sum>i \<in> {..<m}. f i) + (\<Sum>i \<in> {m..n}. f i)"
    using h1 by (simp add: setsum_add_nat_ivl2)
  also have "... = (\<Sum>i \<in> {..<m}. f i)" using eq_zero by simp
  finally show "(\<Sum>i \<le> n. f i) = (\<Sum>i < m. f i)" by simp
qed

lemma setprod_one [simp]:
  fixes n::nat
  shows "(\<Prod>i < n. Suc 0) = Suc 0"
    "(\<Prod>i \<le> n. Suc 0) = Suc 0"
  by (induct n) (simp_all)

section \<open>Recursive Functions\<close>

datatype recf =  Z
  |  S
  |  Id nat nat
  |  Cn nat recf "recf list"
  |  Pr nat recf recf
  |  Mn nat recf

fun arity :: "recf \<Rightarrow> nat"
  where
    "arity Z = 1"
  | "arity S = 1"
  | "arity (Id m n) = m"
  | "arity (Cn n f gs) = n"
  | "arity (Pr n f g) = Suc n"
  | "arity (Mn n f) = n"

text \<open>Abbreviations for calculating the arity of the constructors\<close>

abbreviation
  "CN f gs \<equiv> Cn (arity (hd gs)) f gs"

abbreviation
  "PR f g \<equiv> Pr (arity f) f g"

abbreviation
  "MN f \<equiv> Mn (arity f - 1) f"

text \<open>the evaluation function and termination relation\<close>

fun rec_eval :: "recf \<Rightarrow> nat list \<Rightarrow> nat"
  where
    "rec_eval Z xs = 0"
  | "rec_eval S xs = Suc (xs ! 0)"
  | "rec_eval (Id m n) xs = xs ! n"
  | "rec_eval (Cn n f gs) xs = rec_eval f (map (\<lambda>x. rec_eval x xs) gs)"
  | "rec_eval (Pr n f g) [] = undefined"     (* added by FABR *)
  | "rec_eval (Pr n f g) (0 # xs) = rec_eval f xs"
  | "rec_eval (Pr n f g) (Suc x # xs) =
         rec_eval g (x # (rec_eval (Pr n f g) (x # xs)) # xs)"
  | "rec_eval (Mn n f) xs = (LEAST x. rec_eval f (x # xs) = 0)"

inductive
  terminates :: "recf \<Rightarrow> nat list \<Rightarrow> bool"
  where
    termi_z: "terminates Z [n]"
  | termi_s: "terminates S [n]"
  | termi_id: "\<lbrakk>n < m; length xs = m\<rbrakk> \<Longrightarrow> terminates (Id m n) xs"
  | termi_cn: "\<lbrakk>terminates f (map (\<lambda>g. rec_eval g xs) gs);
              \<forall>g \<in> set gs. terminates g xs; length xs = n\<rbrakk> \<Longrightarrow> terminates (Cn n f gs) xs"
  | termi_pr: "\<lbrakk>\<forall> y < x. terminates g (y # (rec_eval (Pr n f g) (y # xs) # xs));
              terminates f xs;
              length xs = n\<rbrakk>
              \<Longrightarrow> terminates (Pr n f g) (x # xs)"
  | termi_mn: "\<lbrakk>length xs = n; terminates f (r # xs);
              rec_eval f (r # xs) = 0;
              \<forall> i < r. terminates f (i # xs) \<and> rec_eval f (i # xs) > 0\<rbrakk> \<Longrightarrow> terminates (Mn n f) xs"

section \<open>Arithmetic Functions\<close>

text \<open>
  \<open>constn n\<close> is the recursive function which computes
  natural number \<open>n\<close>.
\<close>
fun constn :: "nat \<Rightarrow> recf"
  where
    "constn 0 = Z"  |
    "constn (Suc n) = CN S [constn n]"

definition
  "rec_swap f = CN f [Id 2 1, Id 2 0]"

definition
  "rec_add = PR (Id 1 0) (CN S [Id 3 1])"

definition
  "rec_mult = PR Z (CN rec_add [Id 3 1, Id 3 2])"

definition
  "rec_power = rec_swap (PR (constn 1) (CN rec_mult [Id 3 1, Id 3 2]))"

definition
  "rec_fact_aux = PR (constn 1) (CN rec_mult [CN S [Id 3 0], Id 3 1])"

definition
  "rec_fact = CN rec_fact_aux [Id 1 0, Id 1 0]"

definition
  "rec_predecessor = CN (PR Z (Id 3 0)) [Id 1 0, Id 1 0]"

definition
  "rec_minus = rec_swap (PR (Id 1 0) (CN rec_predecessor [Id 3 1]))"

lemma constn_

lemma swap_lemma [simp]:
  "rec_eval (rec_swap f) [x, y] = rec_eval f [y, x]"
  by (simp add: rec_swap_def)

lemma add_lemma [simp]:
  "rec_eval rec_add [x, y] =  x + y"
  by (induct x) (simp_all add: rec_add_def)

lemma mult_lemma [simp]:
  "rec_eval rec_mult [x, y] = x * y"
  by (induct x) (simp_all add: rec_mult_def)

lemma power_lemma [simp]:
  "rec_eval rec_power [x, y] = x ^ y"
  by (induct y) (simp_all add: rec_power_def)

lemma fact_aux_lemma [simp]:
  "rec_eval rec_fact_aux [x, y] = fact x"
  by (induct x) (simp_all add: rec_fact_aux_def)

lemma fact_lemma [simp]:
  "rec_eval rec_fact [x] = fact x"
  by (simp add: rec_fact_def)

lemma pred_lemma [simp]:
  "rec_eval rec_predecessor [x] =  x - 1"
  by (induct x) (simp_all add: rec_predecessor_def)

lemma minus_lemma [simp]:
  "rec_eval rec_minus [x, y] = x - y"
  by (induct y) (simp_all add: rec_minus_def)

section \<open>Logical functions\<close>

text \<open>
  The \<open>sign\<close> function returns 1 when the input argument
  is greater than \<open>0\<close>.\<close>

definition
  "rec_sign = CN rec_minus [constn 1, CN rec_minus [constn 1, Id 1 0]]"

definition
  "rec_not = CN rec_minus [constn 1, Id 1 0]"

text \<open>
  \<open>rec_eq\<close> compares two arguments: returns \<open>1\<close>
  if they are equal; \<open>0\<close> otherwise.\<close>
definition
  "rec_eq = CN rec_minus [CN (constn 1) [Id 2 0], CN rec_add [rec_minus, rec_swap rec_minus]]"

definition
  "rec_noteq = CN rec_not [rec_eq]"

definition
  "rec_conj = CN rec_sign [rec_mult]"

definition
  "rec_disj = CN rec_sign [rec_add]"

definition
  "rec_imp = CN rec_disj [CN rec_not [Id 2 0], Id 2 1]"

text \<open>@{term "rec_ifz [z, x, y]"} returns x if z is zero,
  y otherwise;  @{term "rec_if [z, x, y]"} returns x if z is *not*
  zero, y otherwise\<close>

definition
  "rec_ifz = PR (Id 2 0) (Id 4 3)"

definition
  "rec_if = CN rec_ifz [CN rec_not [Id 3 0], Id 3 1, Id 3 2]"

lemma sign_lemma [simp]:
  "rec_eval rec_sign [x] = (if x = 0 then 0 else 1)"
  by (simp add: rec_sign_def)

lemma not_lemma [simp]:
  "rec_eval rec_not [x] = (if x = 0 then 1 else 0)"
  by (simp add: rec_not_def)

lemma eq_lemma [simp]:
  "rec_eval rec_eq [x, y] = (if x = y then 1 else 0)"
  by (simp add: rec_eq_def)

lemma noteq_lemma [simp]:
  "rec_eval rec_noteq [x, y] = (if x \<noteq> y then 1 else 0)"
  by (simp add: rec_noteq_def)

lemma conj_lemma [simp]:
  "rec_eval rec_conj [x, y] = (if x = 0 \<or> y = 0 then 0 else 1)"
  by (simp add: rec_conj_def)

lemma disj_lemma [simp]:
  "rec_eval rec_disj [x, y] = (if x = 0 \<and> y = 0 then 0 else 1)"
  by (simp add: rec_disj_def)

lemma imp_lemma [simp]:
  "rec_eval rec_imp [x, y] = (if 0 < x \<and> y = 0 then 0 else 1)"
  by (simp add: rec_imp_def)

lemma ifz_lemma [simp]:
  "rec_eval rec_ifz [z, x, y] = (if z = 0 then x else y)"
  by (cases z) (simp_all add: rec_ifz_def)

lemma if_lemma [simp]:
  "rec_eval rec_if [z, x, y] = (if 0 < z then x else y)"
  by (simp add: rec_if_def)

section \<open>Less and Le Relations\<close>

text \<open>
  \<open>rec_less\<close> compares two arguments and returns \<open>1\<close> if
  the first is less than the second; otherwise returns \<open>0\<close>.\<close>

definition
  "rec_less = CN rec_sign [rec_swap rec_minus]"

definition
  "rec_le = CN rec_disj [rec_less, rec_eq]"

lemma less_lemma [simp]:
  "rec_eval rec_less [x, y] = (if x < y then 1 else 0)"
  by (simp add: rec_less_def)

lemma le_lemma [simp]:
  "rec_eval rec_le [x, y] = (if (x \<le> y) then 1 else 0)"
  by(simp add: rec_le_def)

section \<open>Summation and Product Functions\<close>

definition
  "rec_sigma1 f = PR (CN f [CN Z [Id 1 0], Id 1 0])
                     (CN rec_add [Id 3 1, CN f [CN S [Id 3 0], Id 3 2]])"

definition
  "rec_sigma2 f = PR (CN f [CN Z [Id 2 0], Id 2 0, Id 2 1])
                     (CN rec_add [Id 4 1, CN f [CN S [Id 4 0], Id 4 2, Id 4 3]])"

definition
  "rec_accum1 f = PR (CN f [CN Z [Id 1 0], Id 1 0])
                     (CN rec_mult [Id 3 1, CN f [CN S [Id 3 0], Id 3 2]])"

definition
  "rec_accum2 f = PR (CN f [CN Z [Id 2 0], Id 2 0, Id 2 1])
                     (CN rec_mult [Id 4 1, CN f [CN S [Id 4 0], Id 4 2, Id 4 3]])"

definition
  "rec_accum3 f = PR (CN f [CN Z [Id 3 0], Id 3 0, Id 3 1, Id 3 2])
                     (CN rec_mult [Id 5 1, CN f [CN S [Id 5 0], Id 5 2, Id 5 3, Id 5 4]])"

lemma sigma1_lemma [simp]:
  shows "rec_eval (rec_sigma1 f) [x, y] = (\<Sum> z \<le> x. rec_eval f [z, y])"
  by (induct x) (simp_all add: rec_sigma1_def)

lemma sigma2_lemma [simp]:
  shows "rec_eval (rec_sigma2 f) [x, y1, y2] = (\<Sum> z \<le> x. rec_eval f  [z, y1, y2])"
  by (induct x) (simp_all add: rec_sigma2_def)

lemma accum1_lemma [simp]:
  shows "rec_eval (rec_accum1 f) [x, y] = (\<Prod> z \<le> x. rec_eval f  [z, y])"
  by (induct x) (simp_all add: rec_accum1_def)

lemma accum2_lemma [simp]:
  shows "rec_eval (rec_accum2 f) [x, y1, y2] = (\<Prod> z \<le> x. rec_eval f  [z, y1, y2])"
  by (induct x) (simp_all add: rec_accum2_def)

lemma accum3_lemma [simp]:
  shows "rec_eval (rec_accum3 f) [x, y1, y2, y3] = (\<Prod> z \<le> x. (rec_eval f)  [z, y1, y2, y3])"
  by (induct x) (simp_all add: rec_accum3_def)

section \<open>Bounded Quantifiers\<close>

definition
  "rec_all1 f = CN rec_sign [rec_accum1 f]"

definition
  "rec_all2 f = CN rec_sign [rec_accum2 f]"

definition
  "rec_all3 f = CN rec_sign [rec_accum3 f]"

definition
  "rec_all1_less f = (let cond1 = CN rec_eq [Id 3 0, Id 3 1] in
                      let cond2 = CN f [Id 3 0, Id 3 2]
                      in CN (rec_all2 (CN rec_disj [cond1, cond2])) [Id 2 0, Id 2 0, Id 2 1])"

definition
  "rec_all2_less f = (let cond1 = CN rec_eq [Id 4 0, Id 4 1] in
                      let cond2 = CN f [Id 4 0, Id 4 2, Id 4 3] in
                      CN (rec_all3 (CN rec_disj [cond1, cond2])) [Id 3 0, Id 3 0, Id 3 1, Id 3 2])"

definition
  "rec_ex1 f = CN rec_sign [rec_sigma1 f]"

definition
  "rec_ex2 f = CN rec_sign [rec_sigma2 f]"

lemma ex1_lemma [simp]:
  "rec_eval (rec_ex1 f) [x, y] = (if (\<exists>z \<le> x. 0 < rec_eval f [z, y]) then 1 else 0)"
  by (simp add: rec_ex1_def)

lemma all1_lemma [simp]:
  "rec_eval (rec_all1 f) [x, y] = (if (\<forall>z \<le> x. 0 < rec_eval f [z, y]) then 1 else 0)"
  by (simp add: rec_all1_def)

lemma all2_lemma [simp]:
  "rec_eval (rec_all2 f) [x, y1, y2] = (if (\<forall>z \<le> x. 0 < rec_eval f [z, y1, y2]) then 1 else 0)"
  by (simp add: rec_all2_def)

lemma all3_lemma [simp]:
  "rec_eval (rec_all3 f) [x, y1, y2, y3] = (if (\<forall>z \<le> x. 0 < rec_eval f [z, y1, y2, y3]) then 1 else 0)"
  by (simp add: rec_all3_def)

lemma all1_less_lemma [simp]:
  "rec_eval (rec_all1_less f) [x, y] = (if (\<forall>z < x. 0 < rec_eval f [z, y]) then 1 else 0)"
  apply(auto simp add: Let_def rec_all1_less_def)
   apply (metis nat_less_le)+
  done

lemma all2_less_lemma [simp]:
  "rec_eval (rec_all2_less f) [x, y1, y2] = (if (\<forall>z < x. 0 < rec_eval f [z, y1, y2]) then 1 else 0)"
  apply(auto simp add: Let_def rec_all2_less_def)
   apply(metis nat_less_le)+
  done

section \<open>Quotients\<close>

definition
  "rec_quo = (let lhs = CN S [Id 3 0] in
              let rhs = CN rec_mult [Id 3 2, CN S [Id 3 1]] in
              let cond = CN rec_eq [lhs, rhs] in
              let if_stmt = CN rec_if [cond, CN S [Id 3 1], Id 3 1]
              in PR Z if_stmt)"

fun Quo where
  "Quo x 0 = 0"
| "Quo x (Suc y) = (if (Suc y = x * (Suc (Quo x y))) then Suc (Quo x y) else Quo x y)"

lemma Quo0:
  shows "Quo 0 y = 0"
  by (induct y) (auto)

lemma Quo1:
  "x * (Quo x y) \<le> y"
  by (induct y) (simp_all)

lemma Quo2:
  "b * (Quo b a) + a mod b = a"
  by (induct a) (auto simp add: mod_Suc)

lemma Quo3:
  "n * (Quo n m) = m - m mod n"
  using Quo2[of n m] by (auto)

lemma Quo4:
  assumes h: "0 < x"
  shows "y < x + x * Quo x y"
proof -
  have "x - (y mod x) > 0" using mod_less_divisor assms by auto
  then have "y < y + (x - (y mod x))" by simp
  then have "y < x + (y - (y mod x))" by simp
  then show "y < x + x * (Quo x y)" by (simp add: Quo3)
qed

lemma Quo_div:
  shows "Quo x y = y div x"
  by (metis Quo0 Quo1 Quo4 div_by_0 div_nat_eqI mult_Suc_right neq0_conv)

lemma Quo_rec_quo:
  shows "rec_eval rec_quo [y, x] = Quo x y"
  by (induct y) (simp_all add: rec_quo_def)

lemma quo_lemma [simp]:
  shows "rec_eval rec_quo [y, x] = y div x"
  by (simp add: Quo_div Quo_rec_quo)

section \<open>Iteration\<close>

definition
  "rec_iter f = PR (Id 1 0) (CN f [Id 3 1])"

fun Iter where
  "Iter f 0 = id"
| "Iter f (Suc n) = f \<circ> (Iter f n)"

lemma Iter_comm:
  "(Iter f n) (f x) = f ((Iter f n) x)"
  by (induct n) (simp_all)

lemma iter_lemma [simp]:
  "rec_eval (rec_iter f) [n, x] =  Iter (\<lambda>x. rec_eval f [x]) n x"
  by (induct n) (simp_all add: rec_iter_def)

section \<open>Bounded Maximisation\<close>

fun BMax_rec where
  "BMax_rec R 0 = 0"
| "BMax_rec R (Suc n) = (if R (Suc n) then (Suc n) else BMax_rec R n)"

definition
  BMax_set :: "(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> nat"
  where
    "BMax_set R x = Max ({z. z \<le> x \<and> R z} \<union> {0})"

lemma BMax_rec_eq1:
  "BMax_rec R x = (GREATEST z. (R z \<and> z \<le> x) \<or> z = 0)"
  apply(induct x)
   apply(auto intro: Greatest_equality Greatest_equality[symmetric])
  apply(simp add: le_Suc_eq)
  by metis

lemma BMax_rec_eq2:
  "BMax_rec R x = Max ({z. z \<le> x \<and> R z} \<union> {0})"
  apply(induct x)
   apply(auto intro: Max_eqI Max_eqI[symmetric])
  apply(simp add: le_Suc_eq)
  by metis

lemma BMax_rec_eq3:
  "BMax_rec R x = Max (Set.filter (\<lambda>z. R z) {..x} \<union> {0})"
  by (simp add: BMax_rec_eq2 Set.filter_def)

definition
  "rec_max1 f = PR Z (CN rec_ifz [CN f [CN S [Id 3 0], Id 3 2], CN S [Id 3 0], Id 3 1])"

lemma max1_lemma [simp]:
  "rec_eval (rec_max1 f) [x, y] = BMax_rec (\<lambda>u. rec_eval f [u, y] = 0) x"
  by (induct x) (simp_all add: rec_max1_def)

definition
  "rec_max2 f = PR Z (CN rec_ifz [CN f [CN S [Id 4 0], Id 4 2, Id 4 3], CN S [Id 4 0], Id 4 1])"

lemma max2_lemma [simp]:
  "rec_eval (rec_max2 f) [x, y1, y2] = BMax_rec (\<lambda>u. rec_eval f [u, y1, y2] = 0) x"
  by (induct x) (simp_all add: rec_max2_def)

section \<open>Encodings using Cantor's pairing function\<close>

text \<open>
  We use Cantor's pairing function from Nat-Bijection.
  However, we need to prove that the formulation of the
  decoding function there is recursive. For this we first
  prove that we can extract the maximal triangle number
  using @{term prod_decode}.
\<close>

abbreviation Max_triangle_aux where
  "Max_triangle_aux k z \<equiv> fst (prod_decode_aux k z) + snd (prod_decode_aux k z)"

abbreviation Max_triangle where
  "Max_triangle z \<equiv> Max_triangle_aux 0 z"

abbreviation
  "pdec1 z \<equiv> fst (prod_decode z)"

abbreviation
  "pdec2 z \<equiv> snd (prod_decode z)"

abbreviation
  "penc m n \<equiv> prod_encode (m, n)"

lemma fst_prod_decode:
  "pdec1 z = z - triangle (Max_triangle z)"
  by (subst (3) prod_decode_inverse[symmetric])
    (simp add: prod_encode_def prod_decode_def split: prod.split)

lemma snd_prod_decode:
  "pdec2 z = Max_triangle z - pdec1 z"
  by (simp only: prod_decode_def)

lemma le_triangle:
  "m \<le> triangle (n + m)"
  by (induct m) (simp_all)

lemma Max_triangle_triangle_le:
  "triangle (Max_triangle z) \<le> z"
  by (subst (9) prod_decode_inverse[symmetric])
    (simp add: prod_decode_def prod_encode_def split: prod.split)

lemma Max_triangle_le:
  "Max_triangle z \<le> z"
proof -
  have "Max_triangle z \<le> triangle (Max_triangle z)"
    using le_triangle[of _ 0, simplified] by simp
  also have "... \<le> z" by (rule Max_triangle_triangle_le)
  finally show "Max_triangle z \<le> z" .
qed

lemma w_aux:
  "Max_triangle (triangle k + m) = Max_triangle_aux k m"
  by (simp add: prod_decode_def[symmetric] prod_decode_triangle_add)

lemma y_aux: "y \<le> Max_triangle_aux y k"
  apply(induct k arbitrary: y rule: nat_less_induct)
  apply(subst (1 2) prod_decode_aux.simps)
  by(auto dest!:spec mp elim:Suc_leD)

lemma Max_triangle_greatest:
  "Max_triangle z = (GREATEST k. (triangle k \<le> z \<and> k \<le> z) \<or> k = 0)"
  apply(rule Greatest_equality[symmetric])
   apply(rule disjI1)
   apply(rule conjI)
    apply(rule Max_triangle_triangle_le)
   apply(rule Max_triangle_le)
  apply(erule disjE)
   apply(erule conjE)
   apply(subst (asm) (1) le_iff_add)
   apply(erule exE)
   apply(clarify)
   apply(simp only: w_aux)
   apply(rule y_aux)
  apply(simp)
  done

definition
  "rec_triangle = CN rec_quo [CN rec_mult [Id 1 0, S], constn 2]"

definition
  "rec_max_triangle =
       (let cond = CN rec_not [CN rec_le [CN rec_triangle [Id 2 0], Id 2 1]] in
        CN (rec_max1 cond) [Id 1 0, Id 1 0])"

lemma triangle_lemma [simp]:
  "rec_eval rec_triangle [x] = triangle x"
  by (simp add: rec_triangle_def triangle_def)

lemma max_triangle_lemma [simp]:
  "rec_eval rec_max_triangle [x] = Max_triangle x"
  by (simp add: Max_triangle_greatest rec_max_triangle_def Let_def BMax_rec_eq1)

text \<open>Encodings for Products\<close>

definition
  "rec_penc = CN rec_add [CN rec_triangle [CN rec_add [Id 2 0, Id 2 1]], Id 2 0]"

definition
  "rec_pdec1 = CN rec_minus [Id 1 0, CN rec_triangle [CN rec_max_triangle [Id 1 0]]]"

definition
  "rec_pdec2 = CN rec_minus [CN rec_max_triangle [Id 1 0], CN rec_pdec1 [Id 1 0]]"

lemma pdec1_lemma [simp]:
  "rec_eval rec_pdec1 [z] = pdec1 z"
  by (simp add: rec_pdec1_def fst_prod_decode)

lemma pdec2_lemma [simp]:
  "rec_eval rec_pdec2 [z] = pdec2 z"
  by (simp add: rec_pdec2_def snd_prod_decode)

lemma penc_lemma [simp]:
  "rec_eval rec_penc [m, n] = penc m n"
  by (simp add: rec_penc_def prod_encode_def)

text \<open>Encodings of Lists\<close>

fun
  lenc :: "nat list \<Rightarrow> nat"
  where
    "lenc [] = 0"
  | "lenc (x # xs) = penc (Suc x) (lenc xs)"

fun
  ldec :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where
    "ldec z 0 = (pdec1 z) - 1"
  | "ldec z (Suc n) = ldec (pdec2 z) n"

lemma pdec_zero_simps [simp]:
  "pdec1 0 = 0"
  "pdec2 0 = 0"
  by (simp_all add: prod_decode_def prod_decode_aux.simps)

lemma ldec_zero:
  "ldec 0 n = 0"
  by (induct n) (simp_all add: prod_decode_def prod_decode_aux.simps)

lemma list_encode_inverse:
  "ldec (lenc xs) n = (if n < length xs then xs ! n else 0)"
  by (induct xs arbitrary: n rule: lenc.induct)
    (auto simp add: ldec_zero nth_Cons split: nat.splits)

lemma lenc_length_le:
  "length xs \<le> lenc xs"
  by (induct xs) (simp_all add: prod_encode_def)

text \<open>Membership for the List Encoding\<close>

fun inside :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
  "inside z 0 = (0 < z)"
| "inside z (Suc n) = inside (pdec2 z) n"

definition enclen :: "nat \<Rightarrow> nat" where
  "enclen z = BMax_rec (\<lambda>x. inside z (x - 1)) z"

lemma inside_False [simp]:
  "inside 0 n = False"
  by (induct n) (simp_all)

lemma inside_length [simp]:
  "inside (lenc xs) s = (s < length xs)"
proof(induct s arbitrary: xs)
  case 0
  then show ?case by (cases xs) (simp_all add: prod_encode_def)
next
  case (Suc s)
  then show ?case by (cases xs;auto)
qed

text \<open>Length of Encoded Lists\<close>

lemma enclen_length [simp]:
  "enclen (lenc xs) = length xs"
  unfolding enclen_def
  apply(simp add: BMax_rec_eq1)
  apply(rule Greatest_equality)
   apply(auto simp add: lenc_length_le)
  done

lemma enclen_penc [simp]:
  "enclen (penc (Suc x) (lenc xs)) = Suc (enclen (lenc xs))"
  by (simp only: lenc.simps[symmetric] enclen_length) (simp)

text \<open>Recursive Definitions for List Encodings\<close>

fun
  rec_lenc :: "recf list \<Rightarrow> recf"
  where
    "rec_lenc [] = Z"
  | "rec_lenc (f # fs) = CN rec_penc [CN S [f], rec_lenc fs]"

definition
  "rec_ldec = CN rec_predecessor [CN rec_pdec1 [rec_swap (rec_iter rec_pdec2)]]"

definition
  "rec_inside = CN rec_less [Z, rec_swap (rec_iter rec_pdec2)]"

definition
  "rec_enclen = CN (rec_max1 (CN rec_not [CN rec_inside [Id 2 1, CN rec_predecessor [Id 2 0]]])) [Id 1 0, Id 1 0]"

lemma ldec_iter:
  "ldec z n = pdec1 (Iter pdec2 n z) - 1"
  by (induct n arbitrary: z) (simp | subst Iter_comm)+

lemma inside_iter:
  "inside z n = (0 < Iter pdec2 n z)"
  by (induct n arbitrary: z) (simp | subst Iter_comm)+

lemma lenc_lemma [simp]:
  "rec_eval (rec_lenc fs) xs = lenc (map (\<lambda>f. rec_eval f xs) fs)"
  by (induct fs) (simp_all)

lemma ldec_lemma [simp]:
  "rec_eval rec_ldec [z, n] = ldec z n"
  by (simp add: ldec_iter rec_ldec_def)

lemma inside_lemma [simp]:
  "rec_eval rec_inside [z, n] = (if inside z n then 1 else 0)"
  by (simp add: inside_iter rec_inside_def)

lemma enclen_lemma [simp]:
  "rec_eval rec_enclen [z] = enclen z"
  by (simp add: rec_enclen_def enclen_def)

end


(*
  File: Logic_Thms.thy
  Author: Bohua Zhan

  Setup for proof steps related to logic.
*)

theory Logic_Thms
imports Auto2_HOL_Setup
begin

(* Trivial contradictions. *)
setup \<open>add_resolve_prfstep @{thm HOL.refl}\<close>
setup \<open>add_forward_prfstep @{thm contra_triv}\<close>
setup \<open>add_resolve_prfstep @{thm TrueI}\<close>
theorem FalseD [resolve]: "\<not>False" by simp
lemma exists_triv_eq [resolve]: "\<exists>x. x = x" by auto

(* Not. *)
setup \<open>add_forward_prfstep_cond @{thm HOL.not_sym}
  [with_filt (Auto2_Setup.ProofStep.not_type_filter "s" boolT)]\<close>

(* Iff. *)
setup \<open>add_gen_prfstep ("iff_intro1",
  [WithGoal @{term_pat "(?A::bool) = ?B"},
   CreateCase @{term_pat "?A::bool"},
   WithScore 25])\<close>
theorem iff_goal:
  "A \<noteq> B \<Longrightarrow> A \<Longrightarrow> \<not>B" "A \<noteq> B \<Longrightarrow> B \<Longrightarrow> \<not>A"
  "A \<noteq> B \<Longrightarrow> \<not>A \<Longrightarrow> B" "A \<noteq> B \<Longrightarrow> \<not>B \<Longrightarrow> A"
  "(\<not>A) \<noteq> B \<Longrightarrow> A \<Longrightarrow> B" "A \<noteq> (\<not>B) \<Longrightarrow> B \<Longrightarrow> A" by auto
setup \<open>fold (fn th => add_forward_prfstep_cond th [with_score 1]) @{thms iff_goal}\<close>

(* Quantifiers: normalization *)
theorem exists_split: "(\<exists>x y. P x \<and> Q y) = ((\<exists>x. P x) \<and> (\<exists>y. Q y))" by simp
setup \<open>add_backward_prfstep (equiv_backward_th @{thm exists_split})\<close>

(* Case analysis. *)
setup \<open>add_gen_prfstep ("case_intro",
  [WithTerm @{term_pat "if ?cond then (?yes::?'a) else ?no"},
   CreateCase @{term_pat "?cond::bool"}])\<close>
setup \<open>add_gen_prfstep ("case_intro_fact",
  [WithFact @{term_pat "if ?cond then (?yes::bool) else ?no"},
   CreateCase @{term_pat "?cond::bool"}])\<close>
setup \<open>add_gen_prfstep ("case_intro_goal",
  [WithGoal @{term_pat "if ?cond then (?yes::bool) else ?no"},
   CreateCase @{term_pat "?cond::bool"}])\<close>
lemma if_eval':
  "P \<Longrightarrow> (if \<not>P then x else y) = y" by auto
lemma ifb_eval:
  "P \<Longrightarrow> (if P then (x::bool) else y) = x"
  "\<not>P \<Longrightarrow> (if P then (x::bool) else y) = y"
  "P \<Longrightarrow> (if \<not>P then (x::bool) else y) = y" by auto
setup \<open>fold (fn th => add_rewrite_rule_cond th [with_score 1])
  ([@{thm HOL.if_P}, @{thm HOL.if_not_P}, @{thm if_eval'}] @ @{thms ifb_eval})\<close>

(* THE and \<exists>! *)
setup \<open>add_forward_prfstep_cond @{thm theI'} [with_term "THE x. ?P x"]\<close>
setup \<open>add_gen_prfstep ("ex1_case",
  [WithGoal @{term_pat "\<exists>!x. ?P x"}, CreateConcl @{term_pat "\<exists>x. ?P x"}])\<close>
theorem ex_ex1I' [backward1]: "\<forall>y. P y \<longrightarrow> x = y \<Longrightarrow> P x \<Longrightarrow> \<exists>!x. P x" by auto
theorem the1_equality': "P a \<Longrightarrow> \<exists>!x. P x \<Longrightarrow> (THE x. P x) = a" by (simp add: the1_equality)
setup \<open>add_forward_prfstep_cond @{thm the1_equality'} [with_term "THE x. ?P x"]\<close>

(* Hilbert choice. *)
setup \<open>add_gen_prfstep ("SOME_case_intro",
  [WithTerm @{term_pat "SOME k. ?P k"}, CreateConcl @{term_pat "\<exists>k. ?P k"}])\<close>
setup \<open>add_forward_prfstep_cond @{thm someI} [with_term "SOME x. ?P x"]\<close>
setup \<open>add_forward_prfstep_cond @{thm someI_ex} [with_term "SOME x. ?P x"]\<close>

(* Axiom of choice *)
setup \<open>add_prfstep_custom ("ex_choice",
  [WithGoal @{term_pat "EX f. !x. ?Q f x"}],
  (fn ((id, _), ths) => fn _ => fn _ =>
    let
      val choice = @{thm choice} |> apply_to_thm (Conv.rewr_conv Auto2_UtilBase.backward_conv_th)
    in
      [Auto2_Setup.Update.thm_update (id, (ths MRS choice))]
    end
    handle THM _ => []))
\<close>

(* Least operator. *)
theorem Least_equality' [backward1]:
  "P (x::('a::order)) \<Longrightarrow> \<forall>y. P y \<longrightarrow> x \<le> y \<Longrightarrow> Least P = x" by (simp add: Least_equality)

(* Pairs. *)
lemma pair_inj: "(a,b) = c \<longleftrightarrow> a = fst c \<and> b = snd c" by auto
setup \<open>Auto2_Setup.Normalizer.add_inj_struct_data @{thm pair_inj}\<close>

setup \<open>add_rewrite_rule @{thm fst_conv}\<close>
setup \<open>add_rewrite_rule @{thm snd_conv}\<close>
setup \<open>add_forward_prfstep (equiv_forward_th @{thm prod.simps(1)})\<close>
setup \<open>add_rewrite_rule_cond @{thm surjective_pairing} [with_cond "?t \<noteq> (?a, ?b)"]\<close>
setup \<open>Auto2_Setup.Normalizer.add_rewr_normalizer ("rewr_case", (to_meta_eq @{thm case_prod_beta'}))\<close>

(* Let. *)
setup \<open>Auto2_Setup.Normalizer.add_rewr_normalizer ("rewr_let", @{thm Let_def})\<close>

(* Equivalence relations *)
definition trans :: "('a \<times> 'a) set \<Rightarrow> bool" where
  "trans r = Relation.trans r"

lemma transD [forward]:
  "trans r \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> (y, z) \<in> r \<Longrightarrow> (x, z) \<in> r"
  unfolding trans_def by (meson transD)

lemma transI [backward]:
  "(\<And>x y z. (x, y) \<in> r \<Longrightarrow> (y, z) \<in> r \<Longrightarrow> (x, z) \<in> r) \<Longrightarrow> trans r"
  unfolding trans_def using transI by blast

setup \<open>add_forward_prfstep @{thm Relation.symD}\<close>
setup \<open>add_backward_prfstep @{thm Relation.symI}\<close>
(* setup \<open>add_forward_prfstep @{thm Relation.transD}\<close> *)
(* setup \<open>add_backward_prfstep @{thm Relation.transI}\<close> *)

(* Options *)
setup \<open>add_resolve_prfstep @{thm option.distinct(1)}\<close>
setup \<open>add_rewrite_rule @{thm Option.option.sel}\<close>
setup \<open>add_forward_prfstep @{thm option.collapse}\<close>
setup \<open>add_forward_prfstep (equiv_forward_th @{thm option.simps(1)})\<close>
setup \<open>fold (fn th => add_rewrite_rule_cond th [with_score 1]) @{thms Option.option.case}\<close>

end