theory "Axioms"
imports
  Ordinary_Differential_Equations.ODE_Analysis
  "Ids"
  "Lib"
  "Syntax"
  "Denotational_Semantics"
begin context ids begin

section \<open>Axioms\<close>
text \<open>
  The uniform substitution calculus is based on a finite list of concrete
  axioms, which are defined and proved valid (as in sound) in this section. When axioms apply
  to arbitrary programs or formulas, they mention concrete program or formula
  variables, which are then instantiated by uniform substitution, as opposed
  metavariables.

  This section contains axioms and rules for propositional connectives and programs other than
  ODE's. Differential axioms are handled separately because the proofs are significantly more involved.
  \<close>
named_theorems axiom_defs "Axiom definitions"

definition assign_axiom :: "('sf, 'sc, 'sz) formula"
where [axiom_defs]:"assign_axiom \<equiv>
  ([[vid1 := ($f fid1 empty)]] (Prop vid1 (singleton (Var vid1))))
    \<leftrightarrow> Prop vid1 (singleton ($f fid1 empty))"

definition diff_assign_axiom :: "('sf, 'sc, 'sz) formula"
where [axiom_defs]:"diff_assign_axiom \<equiv>
  ([[DiffAssign vid1  ($f fid1 empty)]] (Prop vid1 (singleton (DiffVar vid1))))
    \<leftrightarrow> Prop vid1 (singleton ($f fid1 empty))"

definition loop_iterate_axiom :: "('sf, 'sc, 'sz) formula"
where [axiom_defs]:"loop_iterate_axiom \<equiv> ([[$\<alpha> vid1**]]Predicational pid1)
  \<leftrightarrow> ((Predicational pid1) && ([[$\<alpha> vid1]][[$\<alpha> vid1**]]Predicational pid1))"

definition test_axiom :: "('sf, 'sc, 'sz) formula"
where [axiom_defs]:"test_axiom \<equiv>
  ([[?($\<phi> vid2 empty)]]$\<phi> vid1 empty) \<leftrightarrow> (($\<phi> vid2 empty) \<rightarrow> ($\<phi> vid1 empty))"

definition box_axiom :: "('sf, 'sc, 'sz) formula"
where [axiom_defs]:"box_axiom \<equiv> (\<langle>$\<alpha> vid1\<rangle>Predicational pid1) \<leftrightarrow> !([[$\<alpha> vid1]]!(Predicational pid1))"

definition choice_axiom :: "('sf, 'sc, 'sz) formula"
where [axiom_defs]:"choice_axiom \<equiv> ([[$\<alpha> vid1 \<union>\<union> $\<alpha> vid2]]Predicational pid1)
  \<leftrightarrow> (([[$\<alpha> vid1]]Predicational pid1) && ([[$\<alpha> vid2]]Predicational pid1))"

definition compose_axiom :: "('sf, 'sc, 'sz) formula"
where [axiom_defs]:"compose_axiom \<equiv> ([[$\<alpha> vid1 ;; $\<alpha> vid2]]Predicational pid1) \<leftrightarrow>
  ([[$\<alpha> vid1]][[ $\<alpha> vid2]]Predicational pid1)"

definition Kaxiom :: "('sf, 'sc, 'sz) formula"
where [axiom_defs]:"Kaxiom \<equiv> ([[$\<alpha> vid1]]((Predicational pid1) \<rightarrow> (Predicational pid2)))
  \<rightarrow> ([[$\<alpha> vid1]]Predicational pid1) \<rightarrow> ([[$\<alpha> vid1]]Predicational pid2)"

(* Here is an example of an old version of the induction axiom that was too weak
 * and thus very easy to prove: it used predicates when it should have used predicationals.
 * This serves as a reminder to be careful whether other axioms are also too weak. *)
(*
definition Ibroken :: "('sf, 'sc, 'sz) formula"
  where "Ibroken \<equiv> ([[$$a]]($P [] \<rightarrow> ([[$$a]]$P []))
    \<rightarrow> ($P [] \<rightarrow> ([[($$a)**]]$P [])))"*)

definition Iaxiom :: "('sf, 'sc, 'sz) formula"
where [axiom_defs]:"Iaxiom \<equiv>
([[($\<alpha> vid1)**]](Predicational pid1 \<rightarrow> ([[$\<alpha> vid1]]Predicational pid1)))
  \<rightarrow>((Predicational pid1 \<rightarrow> ([[($\<alpha> vid1)**]]Predicational pid1)))"

definition Vaxiom :: "('sf, 'sc, 'sz) formula"
where [axiom_defs]:"Vaxiom \<equiv> ($\<phi> vid1 empty) \<rightarrow> ([[$\<alpha> vid1]]($\<phi> vid1 empty))"

subsection \<open>Validity proofs for axioms\<close>
text \<open>Because an axiom in a uniform substitution calculus is an individual formula,
  proving the validity of that formula suffices to prove soundness\<close>
theorem test_valid: "valid test_axiom"
  by (auto simp add: valid_def test_axiom_def)

lemma assign_lem1:
"dterm_sem I (if i = vid1 then Var vid1 else (Const 0))
                   (vec_lambda (\<lambda>y. if vid1 = y then Functions I fid1
  (vec_lambda (\<lambda>i. dterm_sem I (empty i) \<nu>)) else  vec_nth (fst \<nu>) y), snd \<nu>)
=
 dterm_sem I (if i = vid1 then $f fid1 empty else (Const 0)) \<nu>"
  by (cases "i = vid1") (auto simp: proj_sing1)

lemma diff_assign_lem1:
"dterm_sem I (if i = vid1 then DiffVar vid1 else (Const 0))
                   (fst \<nu>, vec_lambda (\<lambda>y. if vid1 = y then Functions I fid1 (vec_lambda (\<lambda>i. dterm_sem I (empty i) \<nu>)) else  vec_nth (snd \<nu>) y))
=
 dterm_sem I (if i = vid1 then $f fid1 empty else (Const 0)) \<nu>
"
  by (cases "i = vid1") (auto simp: proj_sing1)

theorem assign_valid: "valid assign_axiom"
  unfolding  valid_def assign_axiom_def
  by (simp add: assign_lem1)

theorem diff_assign_valid: "valid diff_assign_axiom"
  unfolding  valid_def diff_assign_axiom_def
  by (simp add: diff_assign_lem1)

lemma mem_to_nonempty: "\<omega> \<in> S \<Longrightarrow> (S \<noteq> {})"
  by (auto)

lemma loop_forward: "\<nu> \<in> fml_sem I ([[$\<alpha> id1**]]Predicational pid1)
  \<longrightarrow> \<nu> \<in> fml_sem I (Predicational pid1&&[[$\<alpha> id1]][[$\<alpha> id1**]]Predicational pid1)"
  by (cases \<nu>) (auto intro: converse_rtrancl_into_rtrancl simp add: box_sem)

lemma loop_backward:
 "\<nu> \<in> fml_sem I (Predicational pid1 && [[$\<alpha> id1]][[$\<alpha> id1**]]Predicational pid1)
  \<longrightarrow> \<nu> \<in> fml_sem I ([[$\<alpha> id1**]]Predicational pid1)"
  by (auto elim: converse_rtranclE simp add: box_sem)

theorem loop_valid: "valid loop_iterate_axiom"
  apply(simp only: valid_def loop_iterate_axiom_def)
  apply(simp only: iff_sem)
  apply(simp only: HOL.iff_conv_conj_imp)
  apply(rule allI | rule impI)+
  apply(rule conjI)
  apply(rule loop_forward)
  apply(rule loop_backward)
done

theorem box_valid: "valid box_axiom"
  unfolding valid_def box_axiom_def by(auto)

theorem choice_valid: "valid choice_axiom"
  unfolding valid_def choice_axiom_def by (auto)

theorem compose_valid: "valid compose_axiom"
  unfolding valid_def compose_axiom_def by (auto)

theorem K_valid: "valid Kaxiom"
  unfolding valid_def Kaxiom_def by (auto)

lemma I_axiom_lemma:
  fixes I::"('sf,'sc,'sz) interp" and \<nu>
  assumes "is_interp I"
  assumes IS:"\<nu> \<in> fml_sem I ([[$\<alpha> vid1**]](Predicational pid1 \<rightarrow>
                            [[$\<alpha> vid1]]Predicational pid1))"
  assumes BC:"\<nu> \<in> fml_sem I (Predicational pid1)"
  shows "\<nu> \<in> fml_sem I ([[$\<alpha> vid1**]](Predicational pid1))"
proof -
  have IS':"\<And>\<nu>2. (\<nu>, \<nu>2) \<in> (prog_sem I ($\<alpha> vid1))\<^sup>* \<Longrightarrow> \<nu>2 \<in> fml_sem I (Predicational pid1 \<rightarrow> [[$\<alpha> vid1]](Predicational pid1))"
    using IS by (auto simp add: box_sem)
  have res:"\<And>\<nu>3. ((\<nu>, \<nu>3) \<in> (prog_sem I ($\<alpha> vid1))\<^sup>*) \<Longrightarrow> \<nu>3 \<in> fml_sem I (Predicational pid1)"
  proof -
    fix \<nu>3
    show "((\<nu>, \<nu>3) \<in> (prog_sem I ($\<alpha> vid1))\<^sup>*) \<Longrightarrow> \<nu>3 \<in> fml_sem I (Predicational pid1)"
      apply(induction rule:rtrancl_induct)
       apply(rule BC)
    proof -
      fix y z
      assume vy:"(\<nu>, y) \<in> (prog_sem I ($\<alpha> vid1))\<^sup>*"
      assume yz:"(y, z) \<in> prog_sem I ($\<alpha> vid1)"
      assume yPP:"y \<in> fml_sem I (Predicational pid1)"
      have imp3:"y \<in> fml_sem I (Predicational pid1 \<rightarrow> [[$\<alpha> vid1 ]](Predicational pid1))"
        using IS' vy by (simp)
      have imp4:"y \<in> fml_sem I (Predicational pid1) \<Longrightarrow> y \<in> fml_sem I  ([[$\<alpha> vid1]](Predicational pid1))"
        using imp3 impl_sem by (auto)
      have yaPP:"y \<in> fml_sem I ([[$\<alpha> vid1]]Predicational pid1)" using imp4 yPP by auto
      have zPP:"z \<in> fml_sem I (Predicational pid1)" using yaPP box_sem yz mem_Collect_eq by blast
      show "
        (\<nu>, y) \<in> (prog_sem I ($\<alpha> vid1))\<^sup>* \<Longrightarrow>
        (y, z) \<in> prog_sem I ($\<alpha> vid1) \<Longrightarrow>
        y \<in> fml_sem I (Predicational pid1) \<Longrightarrow>
        z \<in> fml_sem I (Predicational pid1)" using zPP by simp
    qed
  qed
  show "\<nu> \<in> fml_sem I ([[$\<alpha> vid1**]]Predicational pid1)"
    using res by (simp add: mem_Collect_eq box_sem loop_sem)
qed

theorem I_valid: "valid Iaxiom"
  apply(unfold Iaxiom_def valid_def)
  apply(rule impI | rule allI)+
  apply(simp only: impl_sem)
  using I_axiom_lemma by blast

theorem V_valid: "valid Vaxiom"
  apply(simp only: valid_def Vaxiom_def impl_sem box_sem)
  apply(rule allI | rule impI)+
  apply(auto simp add: empty_def)
done

definition G_holds :: "('sf, 'sc, 'sz) formula \<Rightarrow> ('sf, 'sc, 'sz) hp \<Rightarrow> bool"
where "G_holds \<phi> \<alpha> \<equiv> valid \<phi> \<longrightarrow> valid ([[\<alpha>]]\<phi>)"

definition Skolem_holds :: "('sf, 'sc, 'sz) formula \<Rightarrow> 'sz \<Rightarrow> bool"
where "Skolem_holds \<phi> var \<equiv> valid \<phi> \<longrightarrow> valid (Forall var \<phi>)"

definition MP_holds :: "('sf, 'sc, 'sz) formula \<Rightarrow> ('sf, 'sc, 'sz) formula \<Rightarrow> bool"
where "MP_holds \<phi> \<psi> \<equiv> valid (\<phi> \<rightarrow> \<psi>) \<longrightarrow> valid \<phi> \<longrightarrow> valid \<psi>"

definition CT_holds :: "'sf \<Rightarrow> ('sf, 'sz) trm \<Rightarrow> ('sf, 'sz) trm \<Rightarrow> bool"
where "CT_holds g \<theta> \<theta>' \<equiv> valid (Equals \<theta> \<theta>')
  \<longrightarrow> valid (Equals (Function g (singleton \<theta>)) (Function g (singleton \<theta>')))"

definition CQ_holds :: "'sz \<Rightarrow> ('sf, 'sz) trm \<Rightarrow> ('sf, 'sz) trm \<Rightarrow> bool"
where "CQ_holds p \<theta> \<theta>' \<equiv> valid (Equals \<theta> \<theta>')
  \<longrightarrow> valid ((Prop p (singleton \<theta>)) \<leftrightarrow> (Prop p (singleton \<theta>')))"

definition CE_holds :: "'sc \<Rightarrow> ('sf, 'sc, 'sz) formula \<Rightarrow> ('sf, 'sc, 'sz) formula \<Rightarrow> bool"
where "CE_holds var \<phi> \<psi> \<equiv> valid (\<phi> \<leftrightarrow> \<psi>)
  \<longrightarrow> valid (InContext var \<phi> \<leftrightarrow> InContext var \<psi>)"

subsection \<open>Soundness proofs for rules\<close>
theorem G_sound: "G_holds \<phi> \<alpha>"
  by (simp add: G_holds_def valid_def box_sem)

theorem Skolem_sound: "Skolem_holds \<phi> var"
  by (simp add: Skolem_holds_def valid_def)

theorem MP_sound: "MP_holds \<phi> \<psi>"
  by (auto simp add: MP_holds_def valid_def)

lemma CT_lemma:"\<And>I::('sf::finite, 'sc::finite, 'sz::{finite,linorder}) interp. \<And> a::(real, 'sz) vec. \<And> b::(real, 'sz) vec. \<forall>I::('sf,'sc,'sz) interp. is_interp I \<longrightarrow> (\<forall>a b. dterm_sem I \<theta> (a, b) = dterm_sem I \<theta>' (a, b)) \<Longrightarrow>
             is_interp I \<Longrightarrow>
             Functions I var (vec_lambda (\<lambda>i. dterm_sem I (if i = vid1 then \<theta> else  (Const 0)) (a, b))) =
             Functions I var (vec_lambda (\<lambda>i. dterm_sem I (if i = vid1 then \<theta>' else (Const 0)) (a, b)))"
proof -
  fix I :: "('sf::finite, 'sc::finite, 'sz::{finite,linorder}) interp" and a :: "(real, 'sz) vec" and b :: "(real, 'sz) vec"
  assume a1: "is_interp I"
  assume "\<forall>I::('sf,'sc,'sz) interp. is_interp I \<longrightarrow> (\<forall>a b. dterm_sem I \<theta> (a, b) = dterm_sem I \<theta>' (a, b))"
  then have "\<forall>i. dterm_sem I (if i = vid1 then \<theta>' else (Const 0)) (a, b) = dterm_sem I (if i = vid1 then \<theta> else (Const 0)) (a, b)"
    using a1 by presburger
  then show "Functions I var (vec_lambda (\<lambda>i. dterm_sem I (if i = vid1 then \<theta> else (Const 0)) (a, b)))
           = Functions I var (vec_lambda (\<lambda>i. dterm_sem I (if i = vid1 then \<theta>' else (Const 0)) (a, b)))"
    by presburger
qed

theorem CT_sound: "CT_holds var \<theta> \<theta>'"
  apply(simp only: CT_holds_def valid_def equals_sem vec_extensionality vec_eq_iff)
  apply(simp)
  apply(rule allI | rule impI)+
  apply(simp add: CT_lemma)
done

theorem CQ_sound: "CQ_holds var \<theta> \<theta>'"
proof (auto simp only: CQ_holds_def valid_def equals_sem vec_extensionality vec_eq_iff singleton.simps mem_Collect_eq)
  fix I :: "('sf,'sc,'sz) interp" and a b
  assume sem:"\<forall>I::('sf,'sc,'sz) interp. \<forall> \<nu>. is_interp I \<longrightarrow> dterm_sem I \<theta> \<nu> = dterm_sem I \<theta>' \<nu>"
  assume good:"is_interp I"
  have sem_eq:"dterm_sem I \<theta> (a,b) = dterm_sem I \<theta>' (a,b)"
    using sem good by auto
  have feq:"(\<chi> i. dterm_sem I (if i = vid1 then \<theta> else Const 0) (a, b)) = (\<chi> i. dterm_sem I (if i = vid1 then \<theta>' else Const 0) (a, b))"
    apply(rule vec_extensionality)
    using sem_eq by auto
  then show "(a, b) \<in> fml_sem I ($\<phi> var (singleton \<theta>) \<leftrightarrow> $\<phi> var (singleton \<theta>'))"
    by auto
qed

theorem CE_sound: "CE_holds var \<phi> \<psi>"
  apply(simp only: CE_holds_def valid_def iff_sem)
  apply(rule allI | rule impI)+
  apply(simp)
  apply(metis subsetI subset_antisym surj_pair)
done
end end


theory Let
imports "../Nominal2"
begin

atom_decl name

nominal_datatype trm =
  Var "name"
| App "trm" "trm"
| Let as::"assn" t::"trm"   binds "bn as" in as t
and assn =
  ANil
| ACons "name" "trm" "assn"
binder
  bn
where
  "bn ANil = []"
| "bn (ACons x t as) = (atom x) # (bn as)"

nominal_function substrec where
  "substrec fa fl fd y z (Var x) = (if (y = x) then z else (Var x))"
| "substrec fa fl fd y z (App l r) = fa l r"
| "(set (bn as) \<sharp>* (Let as t, y, z) \<and> (\<forall>bs s. set (bn bs) \<sharp>* (Let bs s, y, z) \<longrightarrow> Let as t = Let bs s \<longrightarrow> fl as t = fl bs s)) \<Longrightarrow>
   substrec fa fl fd y z (Let as t) = fl as t"
| "(set (bn as) \<sharp>* (Let as t, y, z) \<and> \<not>(\<forall>bs s. set (bn bs) \<sharp>* (Let bs s, y, z) \<longrightarrow> Let as t = Let bs s \<longrightarrow> fl as t = fl bs s)) \<Longrightarrow>
   substrec fa fl fd y z (Let as t) = fd"
  unfolding eqvt_def substrec_graph_def
  apply (rule, perm_simp, rule, rule)
  apply (case_tac x)
  apply (rule_tac y="f" and c="(f, d, e)" in trm_assn.strong_exhaust(1))
  apply metis
  apply metis
  apply (thin_tac "\<And>fa fl fd y z xa. x = (fa, fl, fd, y, z, Var xa) \<Longrightarrow> P")
  apply (thin_tac "\<And>fa fl fd y z l r. x = (fa, fl, fd, y, z, App l r) \<Longrightarrow> P")
  apply (drule_tac x="assn" in meta_spec)+
  apply (drule_tac x="trm" in meta_spec)+
  apply (drule_tac x="d" in meta_spec)+
  apply (drule_tac x="e" in meta_spec)+
  apply (drule_tac x="b" in meta_spec)+
  apply (drule_tac x="a" in meta_spec)+
  apply (drule_tac x="c" in meta_spec)+
  apply (case_tac "(\<forall>bs s.
             set (bn bs) \<sharp>* (Let bs s, d, e) \<longrightarrow>
             Let.Let assn trm = Let.Let bs s \<longrightarrow> b assn trm = b bs s)")
  apply simp
  apply (thin_tac "set (bn assn) \<sharp>* (Let assn trm, d, e) \<and>
         (\<forall>bs s.
             set (bn bs) \<sharp>* (Let bs s, d, e) \<longrightarrow>
             Let.Let assn trm = Let.Let bs s \<longrightarrow> b assn trm = b bs s) \<Longrightarrow>
         x = (a, b, c, d, e, Let.Let assn trm) \<Longrightarrow> P")
  apply simp
  apply simp_all
  apply clarify
  apply metis
  done
nominal_termination (eqvt) by lexicographic_order

nominal_function substarec :: "(name \<Rightarrow> trm \<Rightarrow> assn \<Rightarrow> assn) \<Rightarrow> assn \<Rightarrow> assn" where
  "substarec fac ANil = ANil"
| "substarec fac (ACons x t as) = fac x t as"
  unfolding eqvt_def substarec_graph_def
  apply (rule, perm_simp, rule, rule)
  apply (case_tac x)
  apply (rule_tac y="b" in trm_assn.exhaust(2))
  apply auto
  done
nominal_termination (eqvt) by lexicographic_order

lemma [fundef_cong]:
 "(\<And>t1 t2. t = App t1 t2 \<Longrightarrow> fa t1 t2 = fa' t1 t2) \<Longrightarrow>
  (\<And>as s. t = Let as s \<Longrightarrow> fl as s = fl' as s) \<Longrightarrow>
  substrec fa fl fd y z t = substrec fa' fl' fd y z t"
  apply (rule_tac y="t" and c="(t, y, z)" in trm_assn.strong_exhaust(1))
  apply auto
  apply (case_tac "(\<forall>bs s. set (bn bs) \<sharp>* (Let bs s, y, z) \<longrightarrow> Let assn trm = Let bs s \<longrightarrow> fl assn trm = fl bs s)")
  apply (subst substrec.simps(3)) apply simp
  apply (subst substrec.simps(3)) apply simp
  apply metis
  apply (subst substrec.simps(4)) apply simp
  apply (subst substrec.simps(4)) apply simp_all
  done

lemma [fundef_cong]:
 "(\<And>x s as. t = ACons x s as \<Longrightarrow> fac x s as = fac' x s as) \<Longrightarrow>
  substarec fac t = substarec fac' t"
  by (rule_tac y="t" in trm_assn.exhaust(2)) simp_all

function
    subst  :: "name \<Rightarrow> trm \<Rightarrow> trm \<Rightarrow> trm"
and substa :: "name \<Rightarrow> trm \<Rightarrow> assn \<Rightarrow> assn"
where
  [simp del]: "subst y z t = substrec
     (\<lambda>l r. App (subst y z l) (subst y z r))
     (\<lambda>as t. Let (substa y z as) (subst y z t))
     (Let (ACons y (Var y) ANil) (Var y)) y z t"
| [simp del]: "substa y z t = substarec
     (\<lambda>x t as. ACons x (subst y z t) (substa y z as)) t"
  by pat_completeness auto

termination by lexicographic_order

lemma testl:
  assumes a: "\<exists>y. f x = Inl y"
  shows "(p \<bullet> (Sum_Type.Projl (f x))) = Sum_Type.Projl ((p \<bullet> f) (p \<bullet> x))"
using a
apply clarify
apply(frule_tac p="p" in permute_boolI)
apply(simp (no_asm_use) only: eqvts)
apply(subst (asm) permute_fun_app_eq)
back
apply(simp)
done

lemma testr:
  assumes a: "\<exists>y. f x = Inr y"
  shows "(p \<bullet> (Sum_Type.Projr (f x))) = Sum_Type.Projr ((p \<bullet> f) (p \<bullet> x))"
using a
apply clarify
apply(frule_tac p="p" in permute_boolI)
apply(simp (no_asm_use) only: eqvts)
apply(subst (asm) permute_fun_app_eq)
back
apply(simp)
done

lemma permute_move: "p \<bullet> x = y \<longleftrightarrow> x = -p \<bullet> y"
  by (metis eqvt_bound unpermute_def)

lemma "subst_substa_graph x t \<Longrightarrow> subst_substa_graph (p \<bullet> x) (p \<bullet> t)"
proof (induct arbitrary: p rule: subst_substa_graph.induct)
fix f y z t p
assume a: "\<And>t1 t2 p. t = App t1 t2 \<Longrightarrow> subst_substa_graph (p \<bullet> Inl (y, z, t1)) (p \<bullet> f (Inl (y, z, t1)))"
   and b: "\<And>t1 t2 p. t = App t1 t2 \<Longrightarrow> subst_substa_graph (p \<bullet> Inl (y, z, t2)) (p \<bullet> f (Inl (y, z, t2)))"
   and c: "\<And>as s p. t = Let.Let as s \<Longrightarrow> subst_substa_graph (p \<bullet> Inr (y, z, as)) (p \<bullet> f (Inr (y, z, as)))"
   and d: "\<And>as s p. t = Let.Let as s \<Longrightarrow> subst_substa_graph (p \<bullet> Inl (y, z, s)) (p \<bullet> f (Inl (y, z, s)))"
   then show "subst_substa_graph (p \<bullet> Inl (y, z, t))
           (p \<bullet> Inl (substrec
                      (\<lambda>l r. App (Sum_Type.Projl (f (Inl (y, z, l))))
                              (Sum_Type.Projl (f (Inl (y, z, r)))))
                      (\<lambda>as t. Let.Let (Sum_Type.Projr (f (Inr (y, z, as))))
                               (Sum_Type.Projl (f (Inl (y, z, t)))))
                      (Let.Let (ACons y (Var y) ANil) (Var y)) y z t))"
     proof (rule_tac y="t" and c="(t, y, z)" in trm_assn.strong_exhaust(1))
       fix name
       assume "t = Var name"
       then show ?thesis
         apply (simp add: eqvts split del: if_splits)
         apply (simp only:  trm_assn.perm_simps)
         apply (rule subst_substa_graph.intros(1)[of "Var (p \<bullet> name)" "p \<bullet> y" "p \<bullet> z", simplified])
         by simp_all
     next
       fix trm1 trm2
       assume e: "t = App trm1 trm2"
       then show ?thesis
         apply (simp add: eqvts)
         apply (subst testl) back
         apply (rule subst_substa_graph.cases[OF a[OF e, of 0, simplified]])
         apply metis apply simp
         apply (subst testl) back
         apply (rule subst_substa_graph.cases[OF b[OF e, of 0, simplified]])
         apply metis apply (simp add: eqvts)
         apply (simp only: Inl_eqvt) apply simp
         apply (rule subst_substa_graph.intros(1)[of "App (p \<bullet> trm1) (p \<bullet> trm2)" "p \<bullet> y" "p \<bullet> z", simplified])
         apply simp_all apply clarify
         using a[OF e, simplified Inl_eqvt, simplified]
         apply (metis (lifting) Inl_eqvt permute_fun_app_eq permute_prod.simps)
         apply clarify
         using b[OF e, simplified Inl_eqvt, simplified]
         by (metis (lifting) Inl_eqvt permute_fun_app_eq permute_prod.simps)
     next
       fix assn trm
       assume e: "t = Let.Let assn trm" and f: "set (bn assn) \<sharp>* (t, y, z)"
       then show ?thesis
         apply (simp add: eqvts)
         apply (simp only: permute_fun_def)
         apply (simp only: eqvts permute_minus_cancel)
         apply (case_tac "(\<forall>bs s. set (bn bs) \<sharp>* (Let.Let bs s, p \<bullet> y, p \<bullet> z) \<longrightarrow>
                 Let.Let (p \<bullet> assn) (p \<bullet> trm) = Let.Let bs s \<longrightarrow>
                 Let.Let (p \<bullet> Sum_Type.Projr (f (Inr (y, z, - p \<bullet> p \<bullet> assn))))
                  (p \<bullet> Sum_Type.Projl (f (Inl (y, z, - p \<bullet> p \<bullet> trm)))) =
                 Let.Let (p \<bullet> Sum_Type.Projr (f (Inr (y, z, - p \<bullet> bs))))
                  (p \<bullet> Sum_Type.Projl (f (Inl (y, z, - p \<bullet> s)))))")
         prefer 2
         apply (subst substrec.simps(4))
         apply rule
         apply (simp add: fresh_star_Pair)
         apply (intro conjI)
         apply (metis fresh_star_permute_iff set_eqvt trm_assn.fv_bn_eqvt(4) trm_assn.perm_simps(3))
         apply (metis (lifting) fresh_star_permute_iff set_eqvt trm_assn.fv_bn_eqvt(4))
         apply (metis (lifting) fresh_star_permute_iff set_eqvt trm_assn.fv_bn_eqvt(4))
         apply assumption
         prefer 2
         apply (subst substrec.simps(3))
         apply rule
         apply (simp add: fresh_star_Pair)
         apply (intro conjI)
         apply (metis fresh_star_permute_iff set_eqvt trm_assn.fv_bn_eqvt(4) trm_assn.perm_simps(3))
         apply (metis (lifting) fresh_star_permute_iff set_eqvt trm_assn.fv_bn_eqvt(4))
         apply (metis (lifting) fresh_star_permute_iff set_eqvt trm_assn.fv_bn_eqvt(4))
         apply assumption
(*       The following subgoal is motivated by:
   thm subst_substa_graph.intros(1)[of "Let (p \<bullet> assn) (p \<bullet> trm)" "p \<bullet> y" "p \<bullet> z" "(p \<bullet> f)", simplified]*)
         apply (subgoal_tac "subst_substa_graph (Inl (p \<bullet> y, p \<bullet> z, Let.Let (p \<bullet> assn) (p \<bullet> trm)))
           (Inl (substrec
           (\<lambda>l r. App (Sum_Type.Projl ((p \<bullet> f) (Inl (p \<bullet> y, p \<bullet> z, l))))
                   (Sum_Type.Projl ((p \<bullet> f) (Inl (p \<bullet> y, p \<bullet> z, r)))))
           (\<lambda>as t. Let.Let (Sum_Type.Projr ((p \<bullet> f) (Inr (p \<bullet> y, p \<bullet> z, as))))
                    (Sum_Type.Projl ((p \<bullet> f) (Inl (p \<bullet> y, p \<bullet> z, t)))))
           (Let.Let (ACons (p \<bullet> y) (Var (p \<bullet> y)) ANil) (Var (p \<bullet> y))) (p \<bullet> y) (p \<bullet> z)
           (Let.Let (p \<bullet> assn) (p \<bullet> trm))))")
         apply (subst (asm) substrec.simps(3))
         apply rule
         apply (simp add: fresh_star_Pair)
         apply (intro conjI)
         apply (metis fresh_star_permute_iff set_eqvt trm_assn.fv_bn_eqvt(4) trm_assn.perm_simps(3))
         apply (metis (lifting) fresh_star_permute_iff set_eqvt trm_assn.fv_bn_eqvt(4))
         apply (metis (lifting) fresh_star_permute_iff set_eqvt trm_assn.fv_bn_eqvt(4))
         (* We don't have equivariance of Projl/Projr at the arbitrary 'bs' point *)
         defer
         apply (subst testr) back
         apply (rule subst_substa_graph.cases[OF c[OF e, of 0, simplified]])
         apply simp apply simp
         apply (subst testl) back
         apply (rule subst_substa_graph.cases[OF d[OF e, of 0, simplified]])
         apply simp apply simp apply simp
         apply (rule subst_substa_graph.intros(1)[of "Let (p \<bullet> assn) (p \<bullet> trm)" "p \<bullet> y" "p \<bullet> z" "(p \<bullet> f)", simplified])
         apply simp apply simp (* These two should follow by d for arbitrary 'as' point *)
         defer defer
         sorry
     qed
   next
     fix f y z t p
     show "subst_substa_graph (p \<bullet> Inr (y, z, t)) (p \<bullet> Inr (substarec (\<lambda>x t as. ACons
       x (Sum_Type.Projl (f (Inl (y, z, t)))) (Sum_Type.Projr (f (Inr (y, z, as))))) t))"
       sorry
   qed

(* Will follow from above and accp *)
lemma [eqvt]:
  "p \<bullet> (subst y z t) = subst (p \<bullet> y) (p \<bullet> z) (p \<bullet> t)"
  "p \<bullet> (substa y z t2) = substa (p \<bullet> y) (p \<bullet> z) (p \<bullet> t2)"
  sorry

lemma substa_simps[simp]:
  "substa y z ANil = ANil"
  "substa y z (ACons x t as) = ACons x (subst y z t) (substa y z as)"
  apply (subst substa.simps) apply (subst substarec.simps) apply rule
  apply (subst substa.simps) apply (subst substarec.simps) apply rule
  done

lemma bn_substa: "bn (substa y z t) = bn t"
  by (induct t rule: trm_assn.inducts(2)) (simp_all add: trm_assn.bn_defs)

lemma fresh_fun_eqvt_app3:
  assumes e: "eqvt f"
  shows "\<lbrakk>a \<sharp> x; a \<sharp> y; a \<sharp> z\<rbrakk> \<Longrightarrow> a \<sharp> f x y z"
  using fresh_fun_eqvt_app[OF e] fresh_fun_app by (metis (lifting, full_types))

lemma
  "subst y z (Var x) = (if (y = x) then z else (Var x))"
  "subst y z (App l r) = App (subst y z l) (subst y z r)"
  "set (bn as) \<sharp>* (Let as t, y, z) \<Longrightarrow> subst y z (Let as t) = Let (substa y z as) (subst y z t)"
  apply (subst subst.simps) apply (subst substrec.simps) apply rule
  apply (subst subst.simps) apply (subst substrec.simps) apply rule
  apply (subst subst.simps) apply (subst substrec.simps) apply auto
  apply (subst (asm) Abs_eq_iff2)
  apply clarify
  apply (simp add: alphas bn_substa)
  apply (rule_tac s="p \<bullet> ([bn as]lst. (substa y z as, subst y z t))" in trans)
  apply (rule sym)
  defer
  apply (simp add: eqvts)
  apply (subgoal_tac "supp p \<sharp>* y")
  apply (subgoal_tac "supp p \<sharp>* z")
  apply (simp add: perm_supp_eq)
  apply (simp add: fresh_Pair fresh_star_def)
  apply blast
  apply (simp add: fresh_Pair fresh_star_def)
  apply blast
  apply (rule perm_supp_eq)
  apply (simp add: fresh_star_Pair)
  apply (simp add: fresh_star_def Abs_fresh_iff)
  apply (auto)
  apply (simp add: bn_substa fresh_Pair)
  apply (rule)
  apply (rule fresh_fun_eqvt_app3[of substa])
  apply (simp add: eqvt_def eqvts_raw)
  apply (metis (lifting) Diff_partition Un_iff)
  apply (metis (lifting) Diff_partition Un_iff)
  apply (simp add: fresh_def trm_assn.supp)
  apply (metis (lifting) DiffI UnI1 supp_Pair)
  apply (rule fresh_fun_eqvt_app3[of subst])
  apply (simp add: eqvt_def eqvts_raw)
  apply (metis (lifting) Diff_partition Un_iff)
  apply (metis (lifting) Diff_partition Un_iff)
  apply (simp add: fresh_def trm_assn.supp)
  by (metis Diff_iff Un_iff supp_Pair)

end


(* Title:      Containers/Collection_Order.thy
    Author:     Andreas Lochbihler, KIT
                René Thiemann, UIBK *)

theory Collection_Order
imports
  Set_Linorder
  Containers_Generator
  Deriving.Compare_Instances
begin

chapter \<open>Light-weight containers\<close>
text_raw \<open>\label{chapter:light-weight:containers}\<close>

section \<open>A linear order for code generation\<close>

subsection \<open>Optional comparators\<close>

class ccompare =
  fixes ccompare :: "'a comparator option"
  assumes ccompare: "\<And> comp. ccompare = Some comp \<Longrightarrow> comparator comp"
begin
abbreviation ccomp :: "'a comparator" where "ccomp \<equiv> the (ID ccompare)"
abbreviation cless :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where "cless \<equiv> lt_of_comp (the (ID ccompare))"
abbreviation cless_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where "cless_eq \<equiv> le_of_comp (the (ID ccompare))"
end

lemma (in ccompare) ID_ccompare':
  "\<And>c. ID ccompare = Some c \<Longrightarrow> comparator c"
  unfolding ID_def id_apply using ccompare by simp

lemma (in ccompare) ID_ccompare:
  "\<And>c. ID ccompare = Some c \<Longrightarrow> class.linorder (le_of_comp c) (lt_of_comp c)"
  by (rule comparator.linorder[OF ID_ccompare'])

syntax "_CCOMPARE" :: "type => logic"  ("(1CCOMPARE/(1'(_')))")

parse_translation \<open>
let
  fun ccompare_tr [ty] =
     (Syntax.const @{syntax_const "_constrain"} $ Syntax.const @{const_syntax "ccompare"} $
       (Syntax.const @{type_syntax option} $
         (Syntax.const @{type_syntax fun} $ ty $
           (Syntax.const @{type_syntax fun} $ ty $ Syntax.const @{type_syntax order}))))
    | ccompare_tr ts = raise TERM ("ccompare_tr", ts);
in [(@{syntax_const "_CCOMPARE"}, K ccompare_tr)] end
\<close>

definition is_ccompare :: "'a :: ccompare itself \<Rightarrow> bool"
where "is_ccompare _ \<longleftrightarrow> ID CCOMPARE('a) \<noteq> None"

context ccompare
begin
lemma cless_eq_conv_cless:
  fixes a b :: "'a"
  assumes "ID CCOMPARE('a) \<noteq> None"
  shows "cless_eq a b \<longleftrightarrow> cless a b \<or> a = b"
proof -
  from assms interpret linorder cless_eq "cless :: 'a \<Rightarrow> 'a \<Rightarrow> bool"
    by(clarsimp simp add: ID_ccompare)
  show ?thesis by(rule le_less)
qed
end

subsection \<open>Generator for the @{class ccompare}--class\<close>

text \<open>
This generator registers itself at the derive-manager for the class
@{class ccompare}. To be more precise, one can choose whether one does not want to
support a comparator by passing parameter "no", one wants to register an arbitrary type which
is already in class @{class compare} using parameter "compare", or
one wants to generate a new comparator by passing no parameter.
In the last case, one demands that the type is a datatype
and that all non-recursive types of that datatype already provide a comparator,
which can usually be achieved via "derive comparator type" or "derive compare type".

\begin{itemize}
\item \texttt{instantiation type :: (type,\ldots,type) (no) corder}
\item \texttt{instantiation datatype :: (type,\ldots,type) corder}
\item \texttt{instantiation datatype :: (compare,\ldots,compare) (compare) corder}
\end{itemize}

If the parameter "no" is not used, then the corresponding
@{const is_ccompare}-theorem is automatically generated and attributed with
\texttt{[simp, code-post]}.
\<close>

text \<open>
To create a new comparator, we just invoke the functionality provided by the generator.
The only difference is the boilerplate-code, which for the generator has to perform
the class instantiation for a comparator, whereas here we have to invoke the methods to
satisfy the corresponding locale for comparators.
\<close>

text \<open>
This generator can be used for arbitrary types, not just datatypes.
When passing no parameters, we get same limitation as for the order generator.
\<close>

lemma corder_intro: "class.linorder le lt \<Longrightarrow> a = Some (le, lt)\<Longrightarrow> a = Some (le',lt') \<Longrightarrow>
  class.linorder le' lt'" by auto

lemma comparator_subst: "c1 = c2 \<Longrightarrow> comparator c1 \<Longrightarrow> comparator c2" by blast

lemma (in compare) compare_subst: "\<And> comp. compare = comp \<Longrightarrow> comparator comp"
  using comparator_compare by blast

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

subsection \<open>Instantiations for HOL types\<close>

derive (linorder) compare_order
  Enum.finite_1 Enum.finite_2 Enum.finite_3 natural String.literal
derive (compare) ccompare
  unit bool nat int Enum.finite_1 Enum.finite_2 Enum.finite_3 integer natural char String.literal
derive (no) ccompare Enum.finite_4 Enum.finite_5

derive ccompare sum list option prod

derive (no) ccompare "fun"

lemma is_ccompare_fun [simp]: "\<not> is_ccompare TYPE('a \<Rightarrow> 'b)"
by(simp add: is_ccompare_def ccompare_fun_def ID_None)

instantiation set :: (ccompare) ccompare begin
definition "CCOMPARE('a set) =
  map_option (\<lambda> c. comp_of_ords (ord.set_less_eq (le_of_comp c)) (ord.set_less (le_of_comp c))) (ID CCOMPARE('a))"
instance by(intro_classes)(auto simp add: ccompare_set_def intro: comp_of_ords linorder.set_less_eq_linorder ID_ccompare)
end

lemma is_ccompare_set [simp, code_post]:
  "is_ccompare TYPE('a set) \<longleftrightarrow> is_ccompare TYPE('a :: ccompare)"
by(simp add: is_ccompare_def ccompare_set_def ID_def)

definition cless_eq_set :: "'a :: ccompare set \<Rightarrow> 'a set \<Rightarrow> bool"
where [simp, code del]: "cless_eq_set = le_of_comp (the (ID CCOMPARE('a set)))"

definition cless_set :: "'a :: ccompare set \<Rightarrow> 'a set \<Rightarrow> bool"
where [simp, code del]: "cless_set = lt_of_comp (the (ID CCOMPARE('a set)))"

lemma ccompare_set_code [code]:
  "CCOMPARE('a :: ccompare set) =
    (case ID CCOMPARE('a) of None \<Rightarrow> None | Some _ \<Rightarrow> Some (comp_of_ords cless_eq_set cless_set))"
  by (clarsimp simp add: ccompare_set_def ID_Some split: option.split)

derive (no) ccompare Predicate.pred

subsection \<open>Proper intervals\<close>

class cproper_interval = ccompare +
  fixes cproper_interval :: "'a option \<Rightarrow> 'a option \<Rightarrow> bool"
  assumes cproper_interval:
  "\<lbrakk> ID CCOMPARE('a) \<noteq> None; finite (UNIV :: 'a set) \<rbrakk>
  \<Longrightarrow> class.proper_interval cless cproper_interval"
begin

lemma ID_ccompare_interval:
  "\<lbrakk> ID CCOMPARE('a) = Some c; finite (UNIV :: 'a set) \<rbrakk>
  \<Longrightarrow> class.linorder_proper_interval (le_of_comp c) (lt_of_comp c) cproper_interval"
using cproper_interval
by(simp add: ID_ccompare class.linorder_proper_interval_def)

end

instantiation unit :: cproper_interval begin
definition "cproper_interval = (proper_interval :: unit proper_interval)"
instance by intro_classes (simp add: compare_order_class.ord_defs cproper_interval_unit_def ccompare_unit_def ID_Some proper_interval_class.axioms)
end

instantiation bool :: cproper_interval begin
definition "cproper_interval = (proper_interval :: bool proper_interval)"
instance by(intro_classes)
  (simp add: cproper_interval_bool_def ord_defs ccompare_bool_def ID_Some proper_interval_class.axioms)
end

instantiation nat :: cproper_interval begin
definition "cproper_interval = (proper_interval :: nat proper_interval)"
instance by intro_classes simp
end

instantiation int :: cproper_interval begin
definition "cproper_interval = (proper_interval :: int proper_interval)"
instance by intro_classes
  (simp add: cproper_interval_int_def ord_defs ccompare_int_def ID_Some proper_interval_class.axioms)
end

instantiation integer :: cproper_interval begin
definition "cproper_interval = (proper_interval :: integer proper_interval)"
instance by intro_classes
  (simp add: cproper_interval_integer_def ord_defs ccompare_integer_def ID_Some proper_interval_class.axioms)
end

instantiation natural :: cproper_interval begin
definition "cproper_interval = (proper_interval :: natural proper_interval)"
instance by intro_classes (simp add: cproper_interval_natural_def ord_defs ccompare_natural_def ID_Some proper_interval_class.axioms)
end

instantiation char :: cproper_interval begin
definition "cproper_interval = (proper_interval :: char proper_interval)"
instance by intro_classes (simp add: cproper_interval_char_def ord_defs ccompare_char_def ID_Some proper_interval_class.axioms)
end

instantiation Enum.finite_1 :: cproper_interval begin
definition "cproper_interval = (proper_interval :: Enum.finite_1 proper_interval)"
instance by intro_classes (simp add: cproper_interval_finite_1_def ord_defs ccompare_finite_1_def ID_Some proper_interval_class.axioms)
end

instantiation Enum.finite_2 :: cproper_interval begin
definition "cproper_interval = (proper_interval :: Enum.finite_2 proper_interval)"
instance by intro_classes (simp add: cproper_interval_finite_2_def ord_defs ccompare_finite_2_def ID_Some proper_interval_class.axioms)
end

instantiation Enum.finite_3 :: cproper_interval begin
definition "cproper_interval = (proper_interval :: Enum.finite_3 proper_interval)"
instance by intro_classes (simp add: cproper_interval_finite_3_def ord_defs ccompare_finite_3_def ID_Some proper_interval_class.axioms)
end

instantiation Enum.finite_4 :: cproper_interval begin
definition "(cproper_interval :: Enum.finite_4 proper_interval) _ _ = undefined"
instance by intro_classes(simp add: ord_defs ccompare_finite_4_def ID_None)
end

instantiation Enum.finite_5 :: cproper_interval begin
definition "(cproper_interval :: Enum.finite_5 proper_interval) _ _ = undefined"
instance by intro_classes(simp add: ord_defs ccompare_finite_5_def ID_None)
end

lemma lt_of_comp_sum: "lt_of_comp (comparator_sum ca cb) sx sy = (
  case sx of Inl x \<Rightarrow> (case sy of Inl y \<Rightarrow> lt_of_comp ca x y | Inr y \<Rightarrow> True)
   | Inr x \<Rightarrow> (case sy of Inl y \<Rightarrow> False | Inr y \<Rightarrow> lt_of_comp cb x y))"
    by (simp add: lt_of_comp_def le_of_comp_def split: sum.split)

instantiation sum :: (cproper_interval, cproper_interval) cproper_interval begin
fun cproper_interval_sum :: "('a + 'b) proper_interval" where
  "cproper_interval_sum None None \<longleftrightarrow> True"
| "cproper_interval_sum None (Some (Inl x)) \<longleftrightarrow> cproper_interval None (Some x)"
| "cproper_interval_sum None (Some (Inr y)) \<longleftrightarrow> True"
| "cproper_interval_sum (Some (Inl x)) None \<longleftrightarrow> True"
| "cproper_interval_sum (Some (Inl x)) (Some (Inl y)) \<longleftrightarrow> cproper_interval (Some x) (Some y)"
| "cproper_interval_sum (Some (Inl x)) (Some (Inr y)) \<longleftrightarrow> cproper_interval (Some x) None \<or> cproper_interval None (Some y)"
| "cproper_interval_sum (Some (Inr y)) None \<longleftrightarrow> cproper_interval (Some y) None"
| "cproper_interval_sum (Some (Inr y)) (Some (Inl x)) \<longleftrightarrow> False"
| "cproper_interval_sum (Some (Inr x)) (Some (Inr y)) \<longleftrightarrow> cproper_interval (Some x) (Some y)"
instance
proof
  assume "ID CCOMPARE('a + 'b) \<noteq> None" "finite (UNIV :: ('a + 'b) set)"
  then obtain c_a c_b
    where A: "ID CCOMPARE('a) = Some c_a" "finite (UNIV :: 'a set)"
    and B: "ID CCOMPARE('b) = Some c_b" "finite (UNIV :: 'b set)"
    by(fastforce simp add: ccompare_sum_def ID_Some ID_None split: option.split_asm)
  note [simp] = proper_interval.proper_interval_simps[OF cproper_interval]
    lt_of_comp_sum ccompare_sum_def ID_Some
    and [split] = sum.split
  show "class.proper_interval cless (cproper_interval :: ('a + 'b) proper_interval)"
  proof
    fix y :: "'a + 'b"
    show "cproper_interval None (Some y) = (\<exists>z. cless z y)"
      using A B by(cases y)(auto, case_tac z, auto)

    fix x :: "'a + 'b"
    show "cproper_interval (Some x) None = (\<exists>z. cless x z)"
      using A B by(cases x)(auto, case_tac z, auto)

    show "cproper_interval (Some x) (Some y) = (\<exists>z. cless x z \<and> cless z y)"
      using A B by(cases x)(case_tac [!] y, auto, case_tac [!] z, auto)
  qed simp
qed
end

lemma lt_of_comp_less_prod: "lt_of_comp (comparator_prod c_a c_b) =
  less_prod (le_of_comp c_a) (lt_of_comp c_a) (lt_of_comp c_b)"
  unfolding less_prod_def
  by (intro ext, auto simp: lt_of_comp_def le_of_comp_def split: order.split_asm prod.split)

lemma lt_of_comp_prod: "lt_of_comp (comparator_prod c_a c_b) (x1,x2) (y1,y2) =
  (lt_of_comp c_a x1 y1 \<or> le_of_comp c_a x1 y1 \<and> lt_of_comp c_b x2 y2)"
  unfolding lt_of_comp_less_prod less_prod_def by simp

instantiation prod :: (cproper_interval, cproper_interval) cproper_interval begin
fun cproper_interval_prod :: "('a \<times> 'b) proper_interval" where
  "cproper_interval_prod None None \<longleftrightarrow> True"
| "cproper_interval_prod None (Some (y1, y2)) \<longleftrightarrow> cproper_interval None (Some y1) \<or> cproper_interval None (Some y2)"
| "cproper_interval_prod (Some (x1, x2)) None \<longleftrightarrow> cproper_interval (Some x1) None \<or> cproper_interval (Some x2) None"
| "cproper_interval_prod (Some (x1, x2)) (Some (y1, y2)) \<longleftrightarrow>
   cproper_interval (Some x1) (Some y1) \<or>
   cless x1 y1 \<and> (cproper_interval (Some x2) None \<or> cproper_interval None (Some y2)) \<or>
   \<not> cless y1 x1 \<and> cproper_interval (Some x2) (Some y2)"
instance
proof
  assume "ID CCOMPARE('a \<times> 'b) \<noteq> None" "finite (UNIV :: ('a \<times> 'b) set)"
  then obtain c_a c_b
    where A: "ID CCOMPARE('a) = Some c_a" "finite (UNIV :: 'a set)"
    and B: "ID CCOMPARE('b) = Some c_b" "finite (UNIV :: 'b set)"
    by(fastforce simp add: ccompare_prod_def ID_Some ID_None finite_prod split: option.split_asm)
  interpret a: linorder "le_of_comp c_a" "lt_of_comp c_a" by(rule ID_ccompare)(rule A)
  note [simp] = proper_interval.proper_interval_simps[OF cproper_interval]
    ccompare_prod_def lt_of_comp_prod ID_Some
  show "class.proper_interval cless (cproper_interval :: ('a \<times> 'b) proper_interval)" using A B
    by (unfold_locales, auto 4 4)
qed
end

instantiation list :: (ccompare) cproper_interval begin
definition cproper_interval_list :: "'a list proper_interval"
where "cproper_interval_list xso yso = undefined"
instance by(intro_classes)(simp add: infinite_UNIV_listI)
end

lemma infinite_UNIV_literal:
  "infinite (UNIV :: String.literal set)"
  by (fact infinite_literal)

instantiation String.literal :: cproper_interval begin
definition cproper_interval_literal :: "String.literal proper_interval"
where "cproper_interval_literal xso yso = undefined"
instance by(intro_classes)(simp add: infinite_UNIV_literal)
end

lemma lt_of_comp_option: "lt_of_comp (comparator_option c) sx sy = (
  case sx of None \<Rightarrow> (case sy of None \<Rightarrow> False | Some y \<Rightarrow> True)
   | Some x \<Rightarrow> (case sy of None \<Rightarrow> False | Some y \<Rightarrow> lt_of_comp c x y))"
    by (simp add: lt_of_comp_def le_of_comp_def split: option.split)

instantiation option :: (cproper_interval) cproper_interval begin
fun cproper_interval_option :: "'a option proper_interval" where
  "cproper_interval_option None None \<longleftrightarrow> True"
| "cproper_interval_option None (Some x) \<longleftrightarrow> x \<noteq> None"
| "cproper_interval_option (Some x) None \<longleftrightarrow> cproper_interval x None"
| "cproper_interval_option (Some x) (Some None) \<longleftrightarrow> False"
| "cproper_interval_option (Some x) (Some (Some y)) \<longleftrightarrow> cproper_interval x (Some y)"
instance
proof
  assume "ID CCOMPARE('a option) \<noteq> None" "finite (UNIV :: 'a option set)"
  then obtain c_a
    where A: "ID CCOMPARE('a) = Some c_a" "finite (UNIV :: 'a set)"
    by(auto simp add: ccompare_option_def ID_def split: option.split_asm)
  note [simp] = proper_interval.proper_interval_simps[OF cproper_interval]
    ccompare_option_def lt_of_comp_option ID_Some
  show "class.proper_interval cless (cproper_interval :: 'a option proper_interval)" using A
  proof(unfold_locales)
    fix x y :: "'a option"
    show "cproper_interval (Some x) None = (\<exists>z. cless x z)" using A
      by(cases x)(auto split: option.split intro: exI[where x="Some undefined"])

    show "cproper_interval (Some x) (Some y) = (\<exists>z. cless x z \<and> cless z y)" using A
      by(cases x y rule: option.exhaust[case_product option.exhaust])(auto cong: option.case_cong split: option.split)
  qed(auto split: option.splits)
qed
end

instantiation set :: (cproper_interval) cproper_interval begin
fun cproper_interval_set :: "'a set proper_interval" where
  [code]: "cproper_interval_set None None \<longleftrightarrow> True"
| [code]: "cproper_interval_set None (Some B) \<longleftrightarrow> (B \<noteq> {})"
| [code]: "cproper_interval_set (Some A) None \<longleftrightarrow> (A \<noteq> UNIV)"
| cproper_interval_set_Some_Some [code del]: \<comment> \<open>Refine for concrete implementations\<close>
  "cproper_interval_set (Some A) (Some B) \<longleftrightarrow> finite (UNIV :: 'a set) \<and> (\<exists>C. cless A C \<and> cless C B)"
instance
proof
  assume "ID CCOMPARE('a set) \<noteq> None" "finite (UNIV :: 'a set set)"
  then obtain c_a
    where A: "ID CCOMPARE('a) = Some c_a" "finite (UNIV :: 'a set)"
    by(auto simp add: ccompare_set_def ID_def Finite_Set.finite_set)
  interpret a: linorder "le_of_comp c_a" "lt_of_comp c_a" by(rule ID_ccompare)(rule A)
  note [simp] = proper_interval.proper_interval_simps[OF cproper_interval] ccompare_set_def
    ID_Some lt_of_comp_of_ords
  show "class.proper_interval cless (cproper_interval :: 'a set proper_interval)" using A
    by (unfold_locales, auto)
qed

lemma Complement_cproper_interval_set_Complement:
  fixes A B :: "'a set"
  assumes corder: "ID CCOMPARE('a) \<noteq> None"
  shows "cproper_interval (Some (- A)) (Some (- B)) = cproper_interval (Some B) (Some A)"
using assms
by(clarsimp simp add: ccompare_set_def ID_Some lt_of_comp_of_ords) (metis double_complement linorder.Compl_set_less_Compl[OF ID_ccompare])

end

instantiation "fun" :: (type, type) cproper_interval begin
text \<open>No interval checks on functions needed because we have not defined an order on them.\<close>
definition "cproper_interval = (undefined :: ('a \<Rightarrow> 'b) proper_interval)"
instance by(intro_classes)(simp add: ccompare_fun_def ID_None)
end

end


section \<open>Natural Language Operators\<close>

theory NL_Operators
  imports Main
begin

lemma "((\<forall> a1. is_aux(a1, None) \<longrightarrow> \<not>is_aux(a1, not_part)) \<and>
is_aux(change, None))
\<longrightarrow> \<not>is_aux(change, not_part)"
  by auto

lemma "((\<forall> a1 a2. means_verb(a1, a2) \<longrightarrow>  a1 = a2) \<and>
means_verb(cat, feline))
\<longrightarrow> cat = feline"
  by auto

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                   July 2005  (modified)   |
            |                 August 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  March 2007  (modified)   |
            |                 August 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_T_mono
imports CSP_T_traces
begin

(*****************************************************************

         1. mono check of tracesfun
         2.
         3.
         4.

 *****************************************************************)

(*--------------------------------*
 |        STOP,SKIP,DIV           |
 *--------------------------------*)

lemma mono_traces_STOP: "mono (traces (STOP))"
by (simp add: mono_def traces_iff)

lemma mono_traces_SKIP: "mono (traces (SKIP))"
by (simp add: mono_def traces_iff)

lemma mono_traces_DIV: "mono (traces (DIV))"
by (simp add: mono_def traces_iff)

(*--------------------------------*
 |          Act_prefix            |
 *--------------------------------*)

lemma mono_traces_Act_prefix:
 "mono (traces P) ==> mono (traces (a -> P))"
apply (simp add: mono_def)
apply (intro allI impI)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (simp)
apply (rule)
apply (simp add: in_traces)
apply (auto)
done

(*--------------------------------*
 |        Ext_pre_choice          |
 *--------------------------------*)

lemma mono_traces_Ext_pre_choice:
 "ALL a. mono (traces (Pf a))
  ==> mono (traces (? a:X -> (Pf a)))"
apply (simp add: mono_def)
apply (intro allI impI)
apply (rule)
apply (simp add: in_traces)
apply (erule disjE, simp)
apply (rule disjI2)
apply (elim conjE exE)
apply (drule_tac x="a" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (auto)
done

(*--------------------------------*
 |          Ext_choice            |
 *--------------------------------*)

lemma mono_traces_Ext_choice:
 "[| mono (traces P) ; mono (traces Q) |]
  ==> mono (traces (P [+] Q))"
apply (simp add: mono_def)
apply (auto simp add: in_traces subdomT_iff)
done

(*--------------------------------*
 |          Int_choice            |
 *--------------------------------*)

lemma mono_traces_Int_choice:
 "[| mono (traces P) ; mono (traces Q) |]
  ==> mono (traces (P |~| Q))"
apply (simp add: mono_def)
apply (auto simp add: in_traces subdomT_iff)
done

(*--------------------------------*
 |        Rep_int_choice          |
 *--------------------------------*)

lemma mono_traces_Rep_int_choice:
 "ALL c: sumset C. mono (traces (Pf c))
  ==> mono (traces (!! :C .. Pf))"
apply (simp add: mono_def)
apply (intro allI impI)
apply (rule)
apply (simp add: in_traces)
apply (erule disjE, simp)
apply (rule disjI2)
apply (elim conjE bexE)
apply (drule_tac x="c" in bspec, simp)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (auto)
done

(*--------------------------------*
 |              IF                |
 *--------------------------------*)

lemma mono_traces_IF:
 "[| mono (traces P) ; mono (traces Q) |]
  ==> mono (traces (IF b THEN P ELSE Q))"
apply (simp add: mono_def)
apply (auto simp add: in_traces subdomT_iff)
done

(*--------------------------------*
 |           Parallel             |
 *--------------------------------*)

lemma mono_traces_Parallel:
 "[| mono (traces P) ; mono (traces Q) |]
  ==> mono (traces (P |[X]| Q))"
apply (simp add: mono_def)
apply (intro allI impI)
apply (rule)
apply (simp add: in_traces)
apply (elim conjE exE)
apply (rule_tac x="s" in exI)
apply (rule_tac x="ta" in exI)
apply (auto simp add: subdomT_iff)
done

(*--------------------------------*
 |            Hiding              |
 *--------------------------------*)

lemma mono_traces_Hiding:
 "mono (traces P)
  ==> mono (traces (P -- X))"
apply (simp add: mono_def)
apply (intro allI impI)
apply (rule)
apply (simp add: in_traces)
apply (elim conjE exE)
apply (rule_tac x="s" in exI)
apply (auto simp add: subdomT_iff)
done

(*--------------------------------*
 |           Renaming             |
 *--------------------------------*)

lemma mono_traces_Renaming:
 "mono (traces P)
  ==> mono (traces (P [[r]]))"
apply (simp add: mono_def)
apply (intro allI impI)
apply (rule)
apply (simp add: in_traces)
apply (elim conjE exE)
apply (rule_tac x="s" in exI)
apply (auto simp add: subdomT_iff)
done

(*--------------------------------*
 |           Seq_compo            |
 *--------------------------------*)

lemma mono_traces_Seq_compo:
 "[| mono (traces P) ; mono (traces Q) |]
  ==> mono (traces (P ;; Q))"
apply (simp add: mono_def)
apply (intro allI impI)
apply (rule)
apply (simp add: in_traces)
apply (erule disjE)
apply (simp add: subdomT_iff)
apply (fast)

apply (elim conjE exE)
apply (rule disjI2)
apply (rule_tac x="s" in exI)
apply (rule_tac x="ta" in exI)
apply (auto simp add: subdomT_iff)
done

(*--------------------------------*
 |          Depth_rest            |
 *--------------------------------*)

lemma mono_traces_Depth_rest:
 "mono (traces P)
  ==> mono (traces (P |. n))"
apply (simp add: mono_def)
apply (intro allI impI)
apply (rule)
apply (simp add: in_traces)
apply (elim conjE exE)
apply (auto simp add: subdomT_iff)
done

(*--------------------------------*
 |            variable            |
 *--------------------------------*)

lemma mono_traces_variable:
   "mono (traces ($p))"
apply (simp add: mono_def)
apply (intro allI impI)
apply (rule)
apply (simp add: in_traces)
apply (simp add: order_prod_def)
apply (auto simp add: subdomT_iff)
done

(*--------------------------------*
 |            Procfun             |
 *--------------------------------*)

lemma mono_traces: "mono (traces P)"
apply (induct_tac P)
apply (simp add: mono_traces_STOP)
apply (simp add: mono_traces_SKIP)
apply (simp add: mono_traces_DIV)
apply (simp add: mono_traces_Act_prefix)
apply (simp add: mono_traces_Ext_pre_choice)
apply (simp add: mono_traces_Ext_choice)
apply (simp add: mono_traces_Int_choice)
apply (simp add: mono_traces_Rep_int_choice)
apply (simp add: mono_traces_IF)
apply (simp add: mono_traces_Parallel)
apply (simp add: mono_traces_Hiding)
apply (simp add: mono_traces_Renaming)
apply (simp add: mono_traces_Seq_compo)
apply (simp add: mono_traces_Depth_rest)
apply (simp add: mono_traces_variable)
done

(*=============================================================*
 |                          [[P]]Tf                            |
 *=============================================================*)

lemma mono_semTf: "mono [[Pf]]Tf"
apply (simp add: semTf_def)
apply (simp add: mono_traces)
done

(*=============================================================*
 |                         [[P]]Tfun                           |
 *=============================================================*)

lemma mono_semTfun: "mono [[Pf]]Tfun"
apply (simp add: prod_mono)
apply (simp add: semTfun_def)
apply (simp add: proj_fun_def)
apply (simp add: comp_def)
apply (simp add: mono_semTf)
done

end


(*  Title: thys/Recs_alt__Ex.thy
    Author: Franz Regensburger (FABR) 03/2022
 *)

section \<open>Examples for recursive functions using the alternative definitions\<close>

theory Recs_alt_Ex
  imports Recs_alt_Def
begin

(*
definition plus_2 :: "recf"
  where
    "plus_2 = (Cn 8 S [S])"      (* arity is deliberately and falsely set to 8 *)
*)

definition plus_2 :: "recf"
  where
    "plus_2 = (CN S [S])"

lemma "rec_eval S [0] = Suc 0"
  by auto

lemma "rec_eval plus_2 [0] = rec_eval (Cn 8 S [S]) [0]" (* arity is not checked by rec_eval *)
  unfolding plus_2_def
  by auto

lemma "Cn 1 S [S] = CN S [S]"
  by auto

lemma "rec_eval plus_2 [0] = 2"
  unfolding plus_2_def
  by auto

lemma "rec_eval plus_2 [2] = 4"
  unfolding plus_2_def
  by auto

lemma "rec_eval plus_2 [0,4] = 2"  (* arity is not checked by rec_eval *)
  unfolding plus_2_def
  by auto

(* Q: what is the purpose of the arity parameter?
 * A: the arity is needed for termination proofs.
 *    See the inductive predicate 'Recs.terminates'
 *)

(* --------------- from Recs.thy --------------- *)

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

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

*)

(* but also *)

lemma add_lemma_more_args:
  "rec_eval rec_add ([x, y] @ z) =  x + y"
  by (induct x) (simp_all add: rec_add_def)

lemma "rec_eval (Pr v va vb) [] = undefined"
  by auto

lemma add_lemma_no_args:
  "rec_eval rec_add [] =  undefined"
  by (simp_all add: rec_add_def)

lemma add_lemma_one_arg:
  "rec_eval rec_add [x] =  undefined"
proof (induct x)
  case 0
(*
  then show ?case by (auto simp add: rec_add_def)

goal (1 subgoal):
 1. \<And>x. rec_eval rec_add [x] = undefined \<Longrightarrow> rec_eval rec_add [Suc x] = undefined
Failed to finish proof\<^here>:
goal (1 subgoal):
 1. [] ! 0 = undefined
*)
  oops

lemma "[]!0 = undefined" (* how can we prove this one? *)
  oops

end


(*  Title:      HOL/Hoare/Pointer_ExamplesAbort.thy
    Author:     Tobias Nipkow
    Copyright   2002 TUM
*)

section \<open>Examples of verifications of pointer programs\<close>

theory Pointer_ExamplesAbort
  imports HeapSyntaxAbort
begin

subsection "Verifications"

subsubsection "List reversal"

text "Interestingly, this proof is the same as for the unguarded program:"

lemma "VARS tl p q r
  {List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {}}
  WHILE p \<noteq> Null
  INV {\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
                 rev ps @ qs = rev Ps @ Qs}
  DO r := p; (p \<noteq> Null \<rightarrow> p := p^.tl); r^.tl := q; q := r OD
  {List tl q (rev Ps @ Qs)}"
apply vcg_simp
  apply fastforce
 apply(fastforce intro:notin_List_update[THEN iffD2])
done

end


(*  Title:      HOL/HOLCF/IOA/NTP/Correctness.thy
    Author:     Tobias Nipkow & Konrad Slind
*)

section \<open>The main correctness proof: Impl implements Spec\<close>

theory Correctness
imports Impl Spec
begin

definition
  hom :: "'m impl_state => 'm list" where
  "hom s = rq(rec(s)) @ (if rbit(rec s) = sbit(sen s) then sq(sen s)
                         else tl(sq(sen s)))"

setup \<open>map_theory_claset (fn ctxt => ctxt delSWrapper "split_all_tac")\<close>

lemmas hom_ioas = Spec.ioa_def Spec.trans_def sender_trans_def receiver_trans_def impl_ioas
  and impl_asigs = sender_asig_def receiver_asig_def srch_asig_def rsch_asig_def

declare split_paired_All [simp del]

text \<open>
  A lemma about restricting the action signature of the implementation
  to that of the specification.
\<close>

lemma externals_lemma:
 "a\<in>externals(asig_of(Automata.restrict impl_ioa (externals spec_sig))) =
  (case a of
      S_msg(m) \<Rightarrow> True
    | R_msg(m) \<Rightarrow> True
    | S_pkt(pkt) \<Rightarrow> False
    | R_pkt(pkt) \<Rightarrow> False
    | S_ack(b) \<Rightarrow> False
    | R_ack(b) \<Rightarrow> False
    | C_m_s \<Rightarrow> False
    | C_m_r \<Rightarrow> False
    | C_r_s \<Rightarrow> False
    | C_r_r(m) \<Rightarrow> False)"
 apply (simp (no_asm) add: externals_def restrict_def restrict_asig_def Spec.sig_def asig_projections)

  apply (induct_tac "a")
  apply (simp_all (no_asm) add: actions_def asig_projections)
  txt \<open>2\<close>
  apply (simp (no_asm) add: impl_ioas)
  apply (simp (no_asm) add: impl_asigs)
  apply (simp (no_asm) add: asig_of_par asig_comp_def asig_projections)
  apply (simp (no_asm) add: "transitions"(1) unfold_renaming)
  txt \<open>1\<close>
  apply (simp (no_asm) add: impl_ioas)
  apply (simp (no_asm) add: impl_asigs)
  apply (simp (no_asm) add: asig_of_par asig_comp_def asig_projections)
  done

lemmas sels = sbit_def sq_def ssending_def rbit_def rq_def rsending_def

text \<open>Proof of correctness\<close>
lemma ntp_correct:
  "is_weak_ref_map hom (Automata.restrict impl_ioa (externals spec_sig)) spec_ioa"
apply (unfold Spec.ioa_def is_weak_ref_map_def)
apply (simp (no_asm) cong del: if_weak_cong split del: if_split add: Correctness.hom_def
  cancel_restrict externals_lemma)
apply (rule conjI)
 apply (simp (no_asm) add: hom_ioas)
 apply (simp (no_asm_simp) add: sels)
apply (rule allI)+
apply (rule imp_conj_lemma)

apply (induct_tac "a")
apply (simp_all (no_asm_simp) add: hom_ioas)
apply (frule inv4)
apply force

apply (frule inv4)
apply (frule inv2)
apply (erule disjE)
apply (simp (no_asm_simp))
apply force

apply (frule inv2)
apply (erule disjE)

apply (frule inv3)
apply (case_tac "sq (sen (s))=[]")

apply (simp add: hom_ioas)
apply (blast dest!: add_leD1 [THEN leD])

apply (rename_tac m, case_tac "m = hd (sq (sen (s)))")

apply force

apply simp
apply (blast dest!: add_leD1 [THEN leD])

apply simp
done

end


section "Example: Computing Maximum with a forEach-Loop"

theory example_loop_max2
  imports
    program_verification_tactics
    unique_ids
    program_proof_rules_loops
    app_verification_helpers
    unique_ids_loops
begin

datatype val =
    Nat (nat_value:nat)
  | Bool (bool_value:bool)
  | Undef
  | ListVal (list_value:"val list")

instance val :: countable
  by countable_datatype

instantiation val :: valueType begin
definition [simp]: "uniqueIds_val \<equiv> \<lambda>x::val. {}::uniqueId set"
definition [simp]: "default_val \<equiv> Undef"

instance by (standard, auto)
end

instantiation val :: natConvert begin
definition[simp]: "fromNat \<equiv> Nat"
instance proof (standard, simp)
  show "inj Nat"
    using injI by force
qed
end

type_synonym operation = unit

datatype proc =
    PMax "nat list"

definition "only_store_changed PS_old PS \<equiv> \<exists>store'. PS = PS_old\<lparr>ps_store := store'\<rparr>"

lemma show_only_store_changed:
  assumes "only_store_changed PS_old PS"
    and "PS' = PS\<lparr>ps_store := x\<rparr>"
  shows "only_store_changed PS_old PS'"
  using assms by (auto simp add: only_store_changed_def)

text_raw \<open>\DefineSnippet{loop_max_example_loop_inv}{\<close>
definition loop_inv :: "nat ref \<Rightarrow> nat list \<Rightarrow> (proc, val, unit) proof_state \<Rightarrow> nat list \<Rightarrow> 'a list \<Rightarrow> nat list \<Rightarrow> (proc, val, unit) proof_state \<Rightarrow> bool" where
"loop_inv resR p_list PS_old Done res Todo  PS \<equiv>
 \<exists>re.
          (iref resR) \<in> dom (ps_store PS)
        \<and> re ::= s_read (ps_store PS) resR
        \<and> (if Done = [] then re = 0 else re = Max (set Done))
        \<and> (only_store_changed PS_old PS)"
text_raw \<open>}%EndSnippet\<close>

text_raw \<open>\DefineSnippet{loop_max_example_impl}{\<close>
definition max_impl :: "nat list \<Rightarrow> (val,operation,val) io" where
"max_impl p_list \<equiv>
   do {
      resR \<leftarrow> makeRef 0;
      forEach_a p_list (loop_inv resR p_list) (\<lambda>x. do {
        res \<leftarrow> read resR;
        resR :\<leftarrow> max x res
      });
      res \<leftarrow> read resR;
      return (Nat res)
}"
text_raw \<open>}%EndSnippet\<close>

instance proc :: countable
  by countable_datatype

instantiation proc :: valueType begin
definition [simp]: "uniqueIds_proc (proc::proc) \<equiv> ({} :: uniqueId set)"

definition [simp]: "default_proc \<equiv> PMax []"

instance by (standard, auto)
end

type_synonym localState = "val store  \<times> uniqueId set \<times> (val, operation, val) io"

definition procedures :: "proc \<Rightarrow> (localState \<times> (localState, operation, val) procedureImpl)" where
  "procedures invoc \<equiv>
  case invoc of
    PMax n \<Rightarrow> toImpl' invoc (max_impl n)
"

text_raw \<open>\DefineSnippet{loop_max_example_inv}{\<close>
definition inv1 where
"inv1 op res \<equiv> \<forall>i list r.
    op i \<triangleq> PMax list
  \<and> list \<noteq> []
  \<and> res i \<triangleq> r
  \<longrightarrow> (r = Nat (Max (set list)))
"
text_raw \<open>}%EndSnippet\<close>

definition inv :: "(proc, operation, val) invContext \<Rightarrow> bool" where
  "inv ctxt \<equiv>
    inv1 (invocOp ctxt) (invocRes ctxt) "

definition "crdtSpec c op r = False"

definition "crdtSpec' op Cs Ops  Hb C_out r = False"

lemma crdtSpec_rel:
  shows "crdt_spec_rel crdtSpec crdtSpec'"
  by (rule show_crdt_spec_rel')
   (auto simp add: crdtSpec_def crdtSpec'_def)

definition progr :: "(proc, localState, operation, val) prog" where
  "progr \<equiv> \<lparr>
  querySpec = crdtSpec,
  procedure = procedures,
  invariant = inv
\<rparr>"

lemma progr_wf[simp]: "program_wellFormed progr"
proof (auto simp add: program_wellFormed_def)
  show "invocations_cannot_guess_ids progr"
  proof (rule invocations_cannot_guess_ids_io)

    show "impl = impl_language_loops.toImpl \<and> localKnown = uniqueIds proc"
      if c0: "procedure progr proc = ((store, localKnown, cmd), impl)"
      for  proc store localKnown cmd impl
      using that by (auto simp add: progr_def procedures_def split: proc.splits)
  qed

  show "queries_cannot_guess_ids crdtSpec"
  proof (auto simp add:  crdtSpec_def queries_cannot_guess_ids_def split: )

    show "\<And>opr. query_cannot_guess_ids (uniqueIds opr) (crdtSpec opr)"
      by (simp add: crdtSpec_def query_cannot_guess_ids_def2)
  qed
qed

theorem correct: "programCorrect progr"
proof M_show_programCorrect

  case invariant_initial_state
  show "invariant_all' (initialState progr)"
    by (simp add: inv_def initialState_def invContextH2_calls inv1_def  invContextH2_happensBefore invContextH2_i_invocOp progr_def)

  case (procedure_correct S i)

  show "procedureCorrect S i"
  proof (rule Initial_Label, rule show_initial_state_prop[OF procedure_correct], rule DC_final2, casify)
    case (show_P S_pre proc initState impl1)
    have "invocOp S i \<triangleq> proc"
      using show_P by auto
    have "invocRes S i = None"
      using show_P apply auto
      using state_wellFormed_invocation_before_result by blast

    have "uniqueIds proc \<subseteq> knownIds S"
      using show_P by auto

    note show_P[simp]

    show "procedureCorrect S i"
    proof (cases proc)
      case (PMax list)

      show "procedureCorrect S i"
      proof M_show_procedureCorrect
        case after_invocation
         show ?case
           using show_P.invariant_pre  show_P.i_fresh
           by (auto simp add:  inv_def inv1_def  invContextH2_simps wf_result_after_invocation)

      next
        case execution

        have ls: "localState S i \<triangleq> (Map.empty, {}, max_impl list)"
            by (auto simp add: PMax procedures_def )

        show "execution_s_correct S i"
          using ls procedure_correct.in_initial_state
        proof (fuzzy_rule execution_s_check_sound4)
          show "currentProc S i \<triangleq> toImpl"
            by (auto simp add:  PMax procedures_def )

          show "invocOp S i \<triangleq> PMax list"
            using PMax \<open>invocOp S i \<triangleq> proc\<close> by blast

          note max_impl_def[simp]

          show "program_wellFormed (prog S)"
            by (auto simp add: show_P)

          from `invariant_all' S`
          show "invariant_all' S" .

          show "crdt_spec_rel (querySpec progr) crdtSpec'"
            using crdtSpec_rel progr_def by simp

          show "program_proof_rules_loops.execution_s_check (invariant progr) crdtSpec' \<lparr>
                  calls = s_calls,
                  happensBefore = s_happensBefore,
                  callOrigin = s_callOrigin,
                  txOrigin = s_txOrigin,
                  knownIds = s_knownIds,
                  invocOp = (s_invocOp(i \<mapsto> PMax list)),
                  invocRes = (s_invocRes(i := None)),
                  ps_i = i,
                  ps_generatedLocal = {},
                  ps_generatedLocalPrivate = {},
                  ps_localKnown = uniqueIds (PMax list),
                  ps_vis = {},
                  ps_localCalls = [],
                  ps_tx = None,
                  ps_firstTx = True,
                  ps_store = Map.empty,
                  ps_prog = progr
                  \<rparr>
                  (max_impl list)
                  (finalCheck (invariant progr) i)" \<comment> \<open>TODO finalCheck could be fixed for the initial P (as variant)\<close>
            if c0: "(\<And>tx. s_txOrigin tx \<noteq> Some i)"
              and inv: "invariant progr
                         \<lparr>calls = s_calls, happensBefore = s_happensBefore, callOrigin = s_callOrigin,
                            txOrigin = s_txOrigin, knownIds = s_knownIds,
                            invocOp = s_invocOp(i \<mapsto> PMax list), invocRes = s_invocRes(i := None)\<rparr>"
            for  s_calls s_happensBefore s_callOrigin s_txOrigin s_knownIds s_invocOp s_invocRes
              (*
            Would also work with this one-liner:
            by (repliss_vcg_l asmUnfold: loop_inv_def, use inv in \<open> auto simp add:  inv_def inv1_def loop_inv_def Def_def only_store_changed_def s_read_def split: if_splits\<close>)
        *)
          proof (repliss_vcg_l asmUnfold: loop_inv_def,
              fuzzy_goal_cases loop_inv_start loop_body final)
            case loop_inv_start
            show ?case
              unfolding loop_inv_def
              by (auto simp add: s_read_def Def_def only_store_changed_def)
          next
            case (loop_body Done results t todo PSl re y)
            show ?case
            proof (auto simp add: loop_inv_def Def_def)
              show "s_read (ps_store PSl(0 \<mapsto> intoAny (max t (s_read (ps_store PSl) (Ref 0))))) (Ref 0) = Max (insert t (set Done))"
                using `re ::= s_read (ps_store PSl) (Ref 0)`
                  and `if Done = [] then re = 0 else re = Max (set Done)`
                by (auto simp add: s_read_def Def_def split: if_splits)

              from loop_body.only_store_changed
              show "only_store_changed
                 \<lparr>calls = s_calls, happensBefore = s_happensBefore, callOrigin = s_callOrigin,
                    txOrigin = s_txOrigin, knownIds = s_knownIds,
                    invocOp = s_invocOp(i \<mapsto> PMax (Done @ t # todo)), invocRes = s_invocRes(i := None),
                    ps_i = i, ps_generatedLocal = {}, ps_generatedLocalPrivate = {}, ps_localKnown = {}, ps_vis = {},
                    ps_localCalls = [], ps_tx = None, ps_firstTx = True, ps_store = [0 \<mapsto> intoAny 0], ps_prog = progr\<rparr>
                 (PSl\<lparr>ps_store := ps_store PSl(0 \<mapsto> intoAny (max t (s_read (ps_store PSl) (Ref 0))))\<rparr>)"
                by (auto simp add: only_store_changed_def proof_state_ext)
            qed
          next
            case (final results PSl re y)

            from final.only_store_changed
            have "invocOp PSl i \<triangleq> PMax list"
              by (auto simp add: only_store_changed_def)

            show "example_loop_max2.inv
            \<lparr>calls = calls PSl, happensBefore = happensBefore PSl,
               callOrigin = callOrigin PSl, txOrigin = txOrigin PSl,
               knownIds = knownIds PSl, invocOp = invocOp PSl,
               invocRes = invocRes PSl(i \<mapsto>
                 val.Nat (s_read (ps_store PSl) (Ref 0)))\<rparr>"
              unfolding inv_def inv1_def
            proof (auto simp add:  `invocOp PSl i \<triangleq> PMax list`)

              show "s_read (ps_store PSl) (Ref 0) = Max (set list)"
                if c0: "list \<noteq> []"
                using `re ::= s_read (ps_store PSl) (Ref 0)`
                  `if list = [] then re = 0 else re = Max (set list)`
                  that
                by (auto simp add: Def_def)

              from inv
              have "inv1 (s_invocOp(i \<mapsto> PMax list)) (s_invocRes(i := None))"
                by (auto simp add: inv_def)

              with final.only_store_changed
              have "inv1 (invocOp PSl) (invocRes PSl)"
                using only_store_changed_def by force

              show "r = val.Nat (Max (set list))"
                if c0: "ia \<noteq> i"
                  and c1: "invocOp PSl ia \<triangleq> PMax list"
                  and c2: "list \<noteq> []"
                  and c3: "invocRes PSl ia \<triangleq> r"
                for  ia list r
                by (meson \<open>inv1 (invocOp PSl) (invocRes PSl)\<close> c1 c2 c3 inv1_def)
            qed
          qed
        qed (auto)
      qed
    qed
  qed
qed

end


theory Logic imports "../Yul/YulSemanticsSingleStep"
begin

definition YulSteps ::
  "('g, 'v, 't) YulDialect \<Rightarrow>
  (('g, 'v, 't) result \<Rightarrow> bool) \<Rightarrow>
   (('g, 'v, 't) result \<Rightarrow> bool) \<Rightarrow>
   bool"
("_ % {_} {_}")
  where
"YulSteps D P Q =
  (\<forall> st . P st \<longrightarrow>
    (\<exists> n st' . evalYul' D st n = YulResult st' \<and>
     Q st'))"

lemma YSI [intro]:
  assumes
    "\<And> st . P st \<Longrightarrow>
      (\<exists> n st' . evalYul' D st n = YulResult st' \<and>
     Q st')"
  shows "D % {P} {Q}" using assms
  unfolding YulSteps_def
  by auto

lemma HTE [elim]:
  assumes H : "D%{P} {Q}"
  assumes HP : "P st"
  shows "(\<exists> n st'. evalYul' D st n = YulResult st' \<and>
     Q st')"
  using assms unfolding YulSteps_def by auto

(* Hoare logic rules *)
lemma HT_conseq :
  assumes H : "D%{P} {Q}"
  assumes HP : "\<And> st . P' st \<Longrightarrow> P st"
  assumes HQ : "\<And> st . Q st \<Longrightarrow> Q' st"
  shows "D%{P'} {Q'}"
proof
  fix st
  assume P' : "P' st"
  hence P : "P st" using HP by auto

  obtain n st' where Exec : "evalYul' D st n = YulResult st' \<and>
           Q st'"
    using HTE[OF H P] by auto

  hence Q' : "Q' st'" using HQ Exec by auto

  thus "\<exists>n st'.
             evalYul' D st n = YulResult st' \<and> Q' st'"
    using Exec by blast
qed

lemma HT_step :
  assumes H : "\<And> st . P st \<Longrightarrow>
      (\<exists> st' . evalYulStep D st = YulResult st' \<and> Q st')"
  shows "D%{P} {Q}"
proof
  fix st
  assume P : "P st"
  obtain st' where St' : "evalYulStep D st = YulResult st'"  and Q : "Q st'"
    using H[OF P] by auto

  hence "evalYul' D st 1 = YulResult st'" by auto

  thus "\<exists>n st' . evalYul' D st n = YulResult st' \<and>  Q st'" using St' Q by blast
qed

lemma evalYul'_steps :
  assumes H1 : "evalYul' D st1 n1 = YulResult st2"
  assumes H2 : "evalYul' D st2 n2 = st3"
  shows "evalYul' D st1 (n1 + n2) = st3" using assms
proof(induction n1 arbitrary: st1 st2 n2 st3)
  case 0
  then show ?case by auto
next
  case (Suc n1)
  show ?case
  proof(cases "cont st1")
    case Nil
    then show ?thesis using Suc by(auto)
  next
    case (Cons ch1 ct1)

    obtain st1' where "evalYulStep D st1 = YulResult st1'"
      using Suc.prems Cons by(auto simp del: evalYulStep.simps split:YulResult.splits)

    then show ?thesis using Suc.prems Suc.IH Cons
      by(simp del: evalYulStep.simps)
  qed
qed

lemma HT_steps :
  assumes H1 : "D % {P1} {P2}"
  assumes H2 : "D % {P2} {P3}"
  shows "D % {P1} {P3}"
proof
  fix st1
  assume P1 : "P1 st1"
  obtain n1 st2 where Exec1 : "evalYul' D st1 n1 = YulResult st2" and P2 : "P2 st2"
    using HTE[OF H1 P1] by auto
  obtain n2 st3 where Exec2 : "evalYul' D st2 n2 = YulResult st3" and P3 : "P3 st3"
    using HTE[OF H2 P2] by auto

  have Exec : "evalYul' D st1 (n1 + n2) = YulResult st3"
    using evalYul'_steps[OF Exec1 Exec2] by auto

  thus "\<exists>n st'. evalYul' D st1 n = YulResult st' \<and> P3 st'" using P3 by blast
qed

(* characterize successfully halted states *)
definition is_halted :: "('g, 'v, 't) result \<Rightarrow> bool" where
"is_halted r = (cont r = [])"

(* a more familiar-looking Hoare logic of statements - but showing its relationship to the
   actual executions beyond the first instruction will take some work. *)
definition YulStepsStmt ::
  "('g, 'v, 't) YulDialect \<Rightarrow>
   (('g, 'v, 't) result \<Rightarrow> bool) \<Rightarrow>
   ('v, 't) YulStatement \<Rightarrow>
   (('g, 'v, 't) result \<Rightarrow> bool) \<Rightarrow>
   bool"
("_ % {_} _ {_}") where
"(D % {P} c {Q}) =
  ((D % {P} {Q}) \<and>
   (\<forall> st . P st \<longrightarrow> cont st = [EnterStatement c]))"

(* Revisiting the implementation - how can we make it easier to model behavior?
   1: formalize continuation stack transformation patterns. everything except for
break and continue will add a (possibly empty) prefix to the stack, and drop the current element.
*)

(* one idea: we could have a
delta function that precisely describes the
change to the continuation *)

lemma evalYulStep_cont_pref :
  assumes Hcont : "cont st = h#t"
  assumes Hstep : "evalYulStep D st = YulResult st'"
  shows "\<exists> pre . cont st' = pre @ t"
proof(cases h)
  case (EnterStatement st)
  show ?thesis
  proof(cases st)
    case (YulFunctionCallStatement x)
    then show ?thesis using assms EnterStatement
      by(cases x; auto)
  next
    case (YulAssignmentStatement x)
    then show ?thesis using assms EnterStatement
      by(cases x; auto)
  next
    case (YulVariableDeclarationStatement x)
    show ?thesis
    proof(cases x)
      case (YulVariableDeclaration x1 x2)
      then show ?thesis using assms EnterStatement YulVariableDeclarationStatement
        by(cases x2; auto)
    qed
  next
    case (YulFunctionDefinitionStatement x)
    then show ?thesis using assms EnterStatement YulFunctionDefinitionStatement
      by(auto)
  next
    case (YulIf x1 x2)
    then show ?thesis using assms EnterStatement by auto
  next
    case (YulSwitch x1 x2)
    then show ?thesis using assms EnterStatement by auto
  next
    case (YulForLoop pre cond post body)
    then show ?thesis using assms EnterStatement
      by(cases pre; auto)
  next
  case YulBreak
  then show ?thesis using assms EnterStatement
    by(auto)
  next
    case YulContinue
    then show ?thesis using assms EnterStatement
      by auto
  next
    case YulLeave
    then show ?thesis using assms EnterStatement
      by auto
  next
    case (YulBlock x11)
    then show ?thesis using assms EnterStatement
      by(auto split: sum.splits)
  qed
next
  case (ExitStatement st locals sigs)
  show ?thesis
  proof(cases st)
    case (YulFunctionCallStatement x)
    then show ?thesis using assms ExitStatement
      by(cases x; auto split:list.splits)
  next
    case (YulAssignmentStatement x)
    then show ?thesis using assms ExitStatement
      by(cases x; auto split:list.splits if_splits option.splits)
  next
    case (YulVariableDeclarationStatement x)
    show ?thesis
    proof(cases x)
      case (YulVariableDeclaration x1 x2)
      then show ?thesis using assms ExitStatement YulVariableDeclarationStatement
        by(cases x2; auto split: if_splits option.splits)
    qed
  next
    case (YulFunctionDefinitionStatement x)
    then show ?thesis using assms ExitStatement YulFunctionDefinitionStatement
      by(auto)
  next
    case (YulIf x1 x2)
    then show ?thesis using assms ExitStatement
      by(auto split:list.splits if_splits)
  next
    case (YulSwitch x1 x2)
    then show ?thesis using assms ExitStatement
      by(auto split:list.splits if_splits prod.splits option.splits YulSwitchCase.splits YulLiteral.splits)
  next
    case (YulForLoop x1 x2 x3 x4)
    then show ?thesis using assms ExitStatement
      by(auto split:list.splits if_splits)
  next
    case YulBreak
    then show ?thesis using assms ExitStatement
      apply(auto split:list.splits if_splits)
  next
    case YulContinue
    then show ?thesis sorry
  next
    case YulLeave
    then show ?thesis sorry
  next
    case (YulBlock x11)
    then show ?thesis sorry
  qed

next
  case (EnterFunctionCall x31 x32)
  then show ?thesis sorry
next
  case (ExitFunctionCall x41 x42 x43 x44 x45)
  then show ?thesis sorry
next
  case (Expression x5)
  then show ?thesis sorry
qed

(* reasoning about Seq. idea:
   - EnterStatement (spre  @ spost) becomes
   - (map statement spre) @ (map statement spost)
*)

(*
  another perspective. suppose P \<Longrightarrow> cont = h#t
  and also Q1 \<Longrightarrow> cont = t

  then. if (P, Q1) holds and (Q1, Q2) holds, then so does
  (P, Q2) (i.e., extending execution

  this is a special case of ht_steps. but could be a useful
  notion for reasoning about individual statements.

*)

(*
lemma evalYul'_bisect_cont :
  assumes H :
*)

(*
  relating terminating sub-executions
*)

(*
  P1 P2 (? ?)

*)

end


theory weird_nat_mul3acc_rrot
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S y2) z = add3acc Z y2 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

fun mul3acc :: "Nat => Nat => Nat => Nat" where
"mul3acc (Z) y z = Z"
| "mul3acc (S x2) (Z) z = Z"
| "mul3acc (S x2) (S x3) (Z) = Z"
| "mul3acc (S (Z)) (S (Z)) (S (Z)) = S Z"
| "mul3acc (S (Z)) (S (Z)) (S (S x5)) =
     S (add3acc
          (mul3acc Z Z (S x5))
          (add3acc
             (mul3acc (S Z) Z (S x5)) (mul3acc Z (S Z) (S x5))
             (mul3acc Z Z (S Z)))
          (add3acc Z Z (S x5)))"
| "mul3acc (S (Z)) (S (S x6)) (S x4) =
     S (add3acc
          (mul3acc Z (S x6) x4)
          (add3acc
             (mul3acc (S Z) (S x6) x4) (mul3acc Z (S Z) x4)
             (mul3acc Z (S x6) (S Z)))
          (add3acc Z (S x6) x4))"
| "mul3acc (S (S x7)) (S x3) (S x4) =
     S (add3acc
          (mul3acc (S x7) x3 x4)
          (add3acc
             (mul3acc (S Z) x3 x4) (mul3acc (S x7) (S Z) x4)
             (mul3acc (S x7) x3 (S Z)))
          (add3acc (S x7) x3 x4))"

(*hipster add3acc mul3acc *)

theorem x0 :
  "!! (x :: Nat) (y :: Nat) (z :: Nat) .
     (mul3acc x y z) = (mul3acc z x y)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end