subsection \<open>Parametricity of the State Monad\<close>

theory DP_CRelVS
  imports "./State_Monad_Ext" "../Pure_Monad"
begin

definition lift_p :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'a) state \<Rightarrow> bool" where
  "lift_p P f =
    (\<forall> heap. P heap \<longrightarrow> (case State_Monad.run_state f heap of (_, heap) \<Rightarrow> P heap))"

context
  fixes P f heap
  assumes lift: "lift_p P f" and P: "P heap"
begin

lemma run_state_cases:
  "case State_Monad.run_state f heap of (_, heap) \<Rightarrow> P heap"
  using lift P unfolding lift_p_def by auto

lemma lift_p_P:
  "P heap'" if "State_Monad.run_state f heap = (v, heap')"
  using that run_state_cases by auto

end

locale state_mem_defs =
  fixes lookup :: "'param \<Rightarrow> ('mem, 'result option) state"
    and update :: "'param \<Rightarrow> 'result \<Rightarrow> ('mem, unit) state"
begin

definition checkmem :: "'param \<Rightarrow> ('mem, 'result) state \<Rightarrow> ('mem, 'result) state" where
  "checkmem param calc \<equiv> do {
    x \<leftarrow> lookup param;
    case x of
      Some x \<Rightarrow> State_Monad.return x
    | None \<Rightarrow> do {
        x \<leftarrow> calc;
        update param x;
        State_Monad.return x
      }
  }"

abbreviation checkmem_eq ::
  "('param \<Rightarrow> ('mem, 'result) state) \<Rightarrow> 'param \<Rightarrow> ('mem, 'result) state \<Rightarrow> bool"
  ("_$ _ =CHECKMEM= _" [1000,51] 51) where
  "(dp\<^sub>T$ param =CHECKMEM= calc) \<equiv> (dp\<^sub>T param = checkmem param calc)"
term 0 (**)

definition map_of where
  "map_of heap k = fst (run_state (lookup k) heap)"

definition checkmem' :: "'param \<Rightarrow> (unit \<Rightarrow> ('mem, 'result) state) \<Rightarrow> ('mem, 'result) state" where
  "checkmem' param calc \<equiv> do {
    x \<leftarrow> lookup param;
    case x of
      Some x \<Rightarrow> State_Monad.return x
    | None \<Rightarrow> do {
        x \<leftarrow> calc ();
        update param x;
        State_Monad.return x
      }
  }"

lemma checkmem_checkmem':
  "checkmem' param (\<lambda>_. calc) = checkmem param calc"
  unfolding checkmem'_def checkmem_def ..

lemma checkmem_eq_alt:
  "checkmem_eq dp param calc = (dp param = checkmem' param (\<lambda> _. calc))"
  unfolding checkmem_checkmem' ..

end (* Mem Defs *)

locale mem_correct = state_mem_defs +
  fixes P
  assumes lookup_inv: "lift_p P (lookup k)" and update_inv: "lift_p P (update k v)"
  assumes
    lookup_correct: "P m \<Longrightarrow> map_of (snd (State_Monad.run_state (lookup k) m)) \<subseteq>\<^sub>m (map_of m)"
      and
    update_correct: "P m \<Longrightarrow> map_of (snd (State_Monad.run_state (update k v) m)) \<subseteq>\<^sub>m (map_of m)(k \<mapsto> v)"
  (* assumes correct: "lookup (update m k v) \<subseteq>\<^sub>m (lookup m)(k \<mapsto> v)" *)

locale dp_consistency =
  mem_correct lookup update P
  for lookup :: "'param \<Rightarrow> ('mem, 'result option) state" and update and P +
  fixes dp :: "'param \<Rightarrow> 'result"
begin

context
  includes lifting_syntax state_monad_syntax
begin

definition cmem :: "'mem \<Rightarrow> bool" where
  "cmem M \<equiv> \<forall>param\<in>dom (map_of M). map_of M param = Some (dp param)"

definition crel_vs :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> ('mem, 'b) state \<Rightarrow> bool" where
  "crel_vs R v s \<equiv> \<forall>M. cmem M \<and> P M \<longrightarrow> (case State_Monad.run_state s M of (v', M') \<Rightarrow> R v v' \<and> cmem M' \<and> P M')"

abbreviation rel_fun_lifted :: "('a \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('c ==_\<Longrightarrow> 'd) \<Rightarrow> bool" (infixr "===>\<^sub>T" 55) where
  "rel_fun_lifted R R' \<equiv> R ===> crel_vs R'"
term 0 (**)

definition consistentDP :: "('param == 'mem \<Longrightarrow> 'result) \<Rightarrow> bool" where
  "consistentDP \<equiv> ((=) ===> crel_vs (=)) dp"
term 0 (**)

  (* cmem *)
private lemma cmem_intro:
  assumes "\<And>param v M'. State_Monad.run_state (lookup param) M = (Some v, M') \<Longrightarrow> v = dp param"
  shows "cmem M"
  unfolding cmem_def map_of_def
  apply safe
  subgoal for param y
    by (cases "State_Monad.run_state (lookup param) M") (auto intro: assms)
  done

lemma cmem_elim:
  assumes "cmem M" "State_Monad.run_state (lookup param) M = (Some v, M')"
  obtains "dp param = v"
  using assms unfolding cmem_def dom_def map_of_def by auto (metis fst_conv option.inject)
term 0 (**)

  (* crel_vs *)
lemma crel_vs_intro:
  assumes "\<And>M v' M'. \<lbrakk>cmem M; P M; State_Monad.run_state v\<^sub>T M = (v', M')\<rbrakk> \<Longrightarrow> R v v' \<and> cmem M' \<and> P M'"
  shows "crel_vs R v v\<^sub>T"
  using assms unfolding crel_vs_def by blast
term 0 (**)

lemma crel_vs_elim:
  assumes "crel_vs R v v\<^sub>T" "cmem M" "P M"
  obtains v' M' where "State_Monad.run_state v\<^sub>T M = (v', M')" "R v v'" "cmem M'" "P M'"
  using assms unfolding crel_vs_def by blast
term 0 (**)

  (* consistentDP *)
lemma consistentDP_intro:
  assumes "\<And>param. Transfer.Rel (crel_vs (=)) (dp param) (dp\<^sub>T param)"
  shows "consistentDP dp\<^sub>T"
  using assms unfolding consistentDP_def Rel_def by blast

lemma crel_vs_return:
  "\<lbrakk>Transfer.Rel R x y\<rbrakk> \<Longrightarrow> Transfer.Rel (crel_vs R) (Wrap x) (State_Monad.return y)"
  unfolding State_Monad.return_def Wrap_def Rel_def by (fastforce intro: crel_vs_intro)
term 0 (**)

lemma crel_vs_return_ext:
  "\<lbrakk>Transfer.Rel R x y\<rbrakk> \<Longrightarrow> Transfer.Rel (crel_vs R) x (State_Monad.return y)"
  by (fact crel_vs_return[unfolded Wrap_def])
term 0 (**)

  (* Low level operators *)
private lemma cmem_upd:
  "cmem M'" if "cmem M" "P M" "State_Monad.run_state (update param (dp param)) M = (v, M')"
  using update_correct[of M param "dp param"] that unfolding cmem_def map_le_def by simp force

private lemma P_upd:
  "P M'" if "P M" "State_Monad.run_state (update param (dp param)) M = (v, M')"
  by (meson lift_p_P that update_inv)

private lemma crel_vs_get:
  "\<lbrakk>\<And>M. cmem M \<Longrightarrow> crel_vs R v (sf M)\<rbrakk> \<Longrightarrow> crel_vs R v (State_Monad.get \<bind> sf)"
  unfolding State_Monad.get_def State_Monad.bind_def by (fastforce intro: crel_vs_intro elim: crel_vs_elim split: prod.split)
term 0 (**)

private lemma crel_vs_set:
  "\<lbrakk>crel_vs R v sf; cmem M; P M\<rbrakk> \<Longrightarrow> crel_vs R v (State_Monad.set M \<then> sf)"
  unfolding State_Monad.set_def State_Monad.bind_def by (fastforce intro: crel_vs_intro elim: crel_vs_elim split: prod.split)
term 0 (**)

private

lemma bind_transfer[transfer_rule]:
  "(crel_vs R0 ===> (R0 ===>\<^sub>T R1) ===> crel_vs R1) (\<lambda>v f. f v) (\<bind>)"
  unfolding State_Monad.bind_def rel_fun_def by (fastforce intro: crel_vs_intro elim: crel_vs_elim split: prod.split)

private lemma cmem_lookup:
  "cmem M'" if "cmem M" "P M" "State_Monad.run_state (lookup param) M = (v, M')"
  using lookup_correct[of M param] that unfolding cmem_def map_le_def by force

private lemma P_lookup:
  "P M'" if "P M" "State_Monad.run_state (lookup param) M = (v, M')"
  by (meson lift_p_P that lookup_inv)

lemma crel_vs_lookup:
  "crel_vs (\<lambda> v v'. case v' of None \<Rightarrow> True | Some v' \<Rightarrow> v = v' \<and> v = dp param) (dp param) (lookup param)"
  by (auto elim: cmem_elim intro: cmem_lookup crel_vs_intro P_lookup split: option.split)

lemma crel_vs_update:
  "crel_vs (=) () (update param (dp param))"
  by (auto intro: cmem_upd crel_vs_intro P_upd)

private lemma crel_vs_checkmem:
  "\<lbrakk>is_equality R; Transfer.Rel (crel_vs R) (dp param) s\<rbrakk>
  \<Longrightarrow> Transfer.Rel (crel_vs R) (dp param) (checkmem param s)"
  unfolding checkmem_def Rel_def is_equality_def
  by (rule bind_transfer[unfolded rel_fun_def, rule_format, OF crel_vs_lookup])
     (auto 4 3 intro: crel_vs_lookup crel_vs_update crel_vs_return[unfolded Rel_def Wrap_def] crel_vs_bind_eq
               split: option.split_asm
     )

lemma crel_vs_checkmem_tupled:
  assumes "v = dp param"
  shows "\<lbrakk>is_equality R; Transfer.Rel (crel_vs R) v s\<rbrakk>
        \<Longrightarrow> Transfer.Rel (crel_vs R) v (checkmem param s)"
  unfolding assms by (fact crel_vs_checkmem)

  (** Transfer rules **)
  (* Basics *)
lemma return_transfer[transfer_rule]:
  "(R ===>\<^sub>T R) Wrap State_Monad.return"
  unfolding rel_fun_def by (metis crel_vs_return Rel_def)

lemma fun_app_lifted_transfer[transfer_rule]:
  "(crel_vs (R0 ===>\<^sub>T R1) ===> crel_vs R0 ===> crel_vs R1) App (.)"
  unfolding App_def fun_app_lifted_def by transfer_prover

lemma crel_vs_fun_app:
  "\<lbrakk>Transfer.Rel (crel_vs R0) x x\<^sub>T; Transfer.Rel (crel_vs (R0 ===>\<^sub>T R1)) f f\<^sub>T\<rbrakk> \<Longrightarrow> Transfer.Rel (crel_vs R1) (App f x) (f\<^sub>T . x\<^sub>T)"
  unfolding Rel_def using fun_app_lifted_transfer[THEN rel_funD, THEN rel_funD] .

  (* HOL *)
lemma if\<^sub>T_transfer[transfer_rule]:
  "(crel_vs (=) ===> crel_vs R ===> crel_vs R ===> crel_vs R) If State_Monad_Ext.if\<^sub>T"
  unfolding State_Monad_Ext.if\<^sub>T_def by transfer_prover
end (* Lifting Syntax *)

end (* Consistency *)
end (* Theory *)


(*  Author:     Bernhard Haeupler

This theory is about of the relative completeness of the ring
method.  As long as the reified atomic polynomials of type pol are
in normal form, the ring method is complete.
*)

section \<open>Proof of the relative completeness of method comm-ring\<close>

theory Commutative_Ring_Complete
  imports Commutative_Ring
begin

text \<open>Formalization of normal form\<close>
fun isnorm :: "pol \<Rightarrow> bool"
  where
    "isnorm (Pc c) \<longleftrightarrow> True"
  | "isnorm (Pinj i (Pc c)) \<longleftrightarrow> False"
  | "isnorm (Pinj i (Pinj j Q)) \<longleftrightarrow> False"
  | "isnorm (Pinj 0 P) \<longleftrightarrow> False"
  | "isnorm (Pinj i (PX Q1 j Q2)) \<longleftrightarrow> isnorm (PX Q1 j Q2)"
  | "isnorm (PX P 0 Q) \<longleftrightarrow> False"
  | "isnorm (PX (Pc c) i Q) \<longleftrightarrow> c \<noteq> 0 \<and> isnorm Q"
  | "isnorm (PX (PX P1 j (Pc c)) i Q) \<longleftrightarrow> c \<noteq> 0 \<and> isnorm (PX P1 j (Pc c)) \<and> isnorm Q"
  | "isnorm (PX P i Q) \<longleftrightarrow> isnorm P \<and> isnorm Q"

subsection \<open>Some helpful lemmas\<close>

lemma norm_Pinj_0_False: "isnorm (Pinj 0 P) = False"
  by (cases P) auto

lemma norm_PX_0_False: "isnorm (PX (Pc 0) i Q) = False"
  by (cases i) auto

lemma norm_Pinj: "isnorm (Pinj i Q) \<Longrightarrow> isnorm Q"
  by (cases i) (simp add: norm_Pinj_0_False norm_PX_0_False, cases Q, auto)

lemma norm_PX2: "isnorm (PX P i Q) \<Longrightarrow> isnorm Q"
  apply (cases i)
   apply auto
  apply (cases P)
    apply auto
  subgoal for \<dots> pol2 by (cases pol2) auto
  done

lemma norm_PX1: "isnorm (PX P i Q) \<Longrightarrow> isnorm P"
  apply (cases i)
   apply auto
  apply (cases P)
    apply auto
  subgoal for \<dots> pol2 by (cases pol2) auto
  done

lemma mkPinj_cn: "y \<noteq> 0 \<Longrightarrow> isnorm Q \<Longrightarrow> isnorm (mkPinj y Q)"
  apply (auto simp add: mkPinj_def norm_Pinj_0_False split: pol.split)
   apply (rename_tac nat a, case_tac nat, auto simp add: norm_Pinj_0_False)
   apply (rename_tac pol a, case_tac pol, auto)
  apply (case_tac y, auto)
  done

lemma norm_PXtrans:
  assumes A: "isnorm (PX P x Q)"
    and "isnorm Q2"
  shows "isnorm (PX P x Q2)"
proof (cases P)
  case (PX p1 y p2)
  with assms show ?thesis
    apply (cases x)
     apply auto
    apply (cases p2)
      apply auto
    done
next
  case Pc
  with assms show ?thesis
    by (cases x) auto
next
  case Pinj
  with assms show ?thesis
    by (cases x) auto
qed

lemma norm_PXtrans2:
  assumes "isnorm (PX P x Q)"
    and "isnorm Q2"
  shows "isnorm (PX P (Suc (n + x)) Q2)"
proof (cases P)
  case (PX p1 y p2)
  with assms show ?thesis
    apply (cases x)
     apply auto
    apply (cases p2)
      apply auto
    done
next
  case Pc
  with assms show ?thesis
    by (cases x) auto
next
  case Pinj
  with assms show ?thesis
    by (cases x) auto
qed

text \<open>\<open>mkPX\<close> conserves normalizedness (\<open>_cn\<close>)\<close>
lemma mkPX_cn:
  assumes "x \<noteq> 0"
    and "isnorm P"
    and "isnorm Q"
  shows "isnorm (mkPX P x Q)"
proof (cases P)
  case (Pc c)
  with assms show ?thesis
    by (cases x) (auto simp add: mkPinj_cn mkPX_def)
next
  case (Pinj i Q)
  with assms show ?thesis
    by (cases x) (auto simp add: mkPinj_cn mkPX_def)
next
  case (PX P1 y P2)
  with assms have Y0: "y > 0"
    by (cases y) auto
  from assms PX have "isnorm P1" "isnorm P2"
    by (auto simp add: norm_PX1[of P1 y P2] norm_PX2[of P1 y P2])
  from assms PX Y0 show ?thesis
    apply (cases x)
     apply (auto simp add: mkPX_def norm_PXtrans2[of P1 y _ Q _])
    apply (cases P2)
      apply auto
    done
qed

text \<open>\<open>add\<close> conserves normalizedness\<close>
lemma add_cn: "isnorm P \<Longrightarrow> isnorm Q \<Longrightarrow> isnorm (P \<langle>+\<rangle> Q)"
proof (induct P Q rule: add.induct)
  case 1
  then show ?case by simp
next
  case (2 c i P2)
  then show ?case
    apply (cases P2)
      apply simp_all
    apply (cases i)
     apply simp_all
    done
next
  case (3 i P2 c)
  then show ?case
    apply (cases P2)
      apply simp_all
    apply (cases i)
     apply simp_all
    done
next
  case (4 c P2 i Q2)
  then have "isnorm P2" "isnorm Q2"
    by (auto simp only: norm_PX1[of P2 i Q2] norm_PX2[of P2 i Q2])
  with 4 show ?case
    apply (cases i)
     apply simp
    apply (cases P2)
      apply auto
    subgoal for \<dots> pol2 by (cases pol2) auto
    done
next
  case (5 P2 i Q2 c)
  then have "isnorm P2" "isnorm Q2"
    by (auto simp only: norm_PX1[of P2 i Q2] norm_PX2[of P2 i Q2])
  with 5 show ?case
    apply (cases i)
     apply simp
    apply (cases P2)
      apply auto
    subgoal for \<dots> pol2 by (cases pol2) auto
    done
next
  case (6 x P2 y Q2)
  then have Y0: "y > 0"
    by (cases y) (auto simp add: norm_Pinj_0_False)
  with 6 have X0: "x > 0"
    by (cases x) (auto simp add: norm_Pinj_0_False)
  consider "x < y" | "x = y" | "x > y" by arith
  then show ?case
  proof cases
    case xy: 1
    then obtain d where y: "y = d + x"
      by atomize_elim arith
    from 6 have *: "isnorm P2" "isnorm Q2"
      by (auto simp add: norm_Pinj[of _ P2] norm_Pinj[of _ Q2])
    from 6 xy y have "isnorm (Pinj d Q2)"
      by (cases d, simp, cases Q2, auto)
    with 6 X0 y * show ?thesis
      by (simp add: mkPinj_cn)
  next
    case xy: 2
    from 6 have "isnorm P2" "isnorm Q2"
      by (auto simp add: norm_Pinj[of _ P2] norm_Pinj[of _ Q2])
    with xy 6 Y0 show ?thesis
      by (simp add: mkPinj_cn)
  next
    case xy: 3
    then obtain d where x: "x = d + y"
      by atomize_elim arith
    from 6 have *: "isnorm P2" "isnorm Q2"
      by (auto simp add: norm_Pinj[of _ P2] norm_Pinj[of _ Q2])
    from 6 xy x have "isnorm (Pinj d P2)"
      by (cases d) (simp, cases P2, auto)
    with xy 6 Y0 * x show ?thesis by (simp add: mkPinj_cn)
  qed
next
  case (7 x P2 Q2 y R)
  consider "x = 0" | "x = 1" | d where "x = Suc (Suc d)"
    by atomize_elim arith
  then show ?case
  proof cases
    case 1
    with 7 show ?thesis
      by (auto simp add: norm_Pinj_0_False)
  next
    case x: 2
    from 7 have "isnorm R" "isnorm P2"
      by (auto simp add: norm_Pinj[of _ P2] norm_PX2[of Q2 y R])
    with 7 x have "isnorm (R \<langle>+\<rangle> P2)"
      by simp
    with 7 x show ?thesis
      by (simp add: norm_PXtrans[of Q2 y _])
  next
    case x: 3
    with 7 have NR: "isnorm R" "isnorm P2"
      by (auto simp add: norm_Pinj[of _ P2] norm_PX2[of Q2 y R])
    with 7 x have "isnorm (Pinj (x - 1) P2)"
      by (cases P2) auto
    with 7 x NR have "isnorm (R \<langle>+\<rangle> Pinj (x - 1) P2)"
      by simp
    with \<open>isnorm (PX Q2 y R)\<close> x show ?thesis
      by (simp add: norm_PXtrans[of Q2 y _])
  qed
next
  case (8 Q2 y R x P2)
  consider "x = 0" | "x = 1" | "x > 1"
    by arith
  then show ?case
  proof cases
    case 1
    with 8 show ?thesis
      by (auto simp add: norm_Pinj_0_False)
  next
    case x: 2
    with 8 have "isnorm R" "isnorm P2"
      by (auto simp add: norm_Pinj[of _ P2] norm_PX2[of Q2 y R])
    with 8 x have "isnorm (R \<langle>+\<rangle> P2)"
      by simp
    with 8 x show ?thesis
      by (simp add: norm_PXtrans[of Q2 y _])
  next
    case x: 3
    then obtain d where x: "x = Suc (Suc d)" by atomize_elim arith
    with 8 have NR: "isnorm R" "isnorm P2"
      by (auto simp add: norm_Pinj[of _ P2] norm_PX2[of Q2 y R])
    with 8 x have "isnorm (Pinj (x - 1) P2)"
      by (cases P2) auto
    with 8 x NR have "isnorm (R \<langle>+\<rangle> Pinj (x - 1) P2)"
      by simp
    with \<open>isnorm (PX Q2 y R)\<close> x show ?thesis
      by (simp add: norm_PXtrans[of Q2 y _])
  qed
next
  case (9 P1 x P2 Q1 y Q2)
  then have Y0: "y > 0" by (cases y) auto
  with 9 have X0: "x > 0" by (cases x) auto
  with 9 have NP1: "isnorm P1" and NP2: "isnorm P2"
    by (auto simp add: norm_PX1[of P1 _ P2] norm_PX2[of P1 _ P2])
  with 9 have NQ1: "isnorm Q1" and NQ2: "isnorm Q2"
    by (auto simp add: norm_PX1[of Q1 _ Q2] norm_PX2[of Q1 _ Q2])
  consider "y < x" | "x = y" | "x < y" by arith
  then show ?case
  proof cases
    case xy: 1
    then obtain d where x: "x = d + y"
      by atomize_elim arith
    have "isnorm (PX P1 d (Pc 0))"
    proof (cases P1)
      case (PX p1 y p2)
      with 9 xy x show ?thesis
        by (cases d) (simp, cases p2, auto)
    next
      case Pc
      with 9 xy x show ?thesis
        by (cases d) auto
    next
      case Pinj
      with 9 xy x show ?thesis
        by (cases d) auto
    qed
    with 9 NQ1 NP1 NP2 NQ2 xy x have "isnorm (P2 \<langle>+\<rangle> Q2)" "isnorm (PX P1 (x - y) (Pc 0) \<langle>+\<rangle> Q1)"
      by auto
    with Y0 xy x show ?thesis
      by (simp add: mkPX_cn)
  next
    case xy: 2
    with 9 NP1 NP2 NQ1 NQ2 have "isnorm (P2 \<langle>+\<rangle> Q2)" "isnorm (P1 \<langle>+\<rangle> Q1)"
      by auto
    with xy Y0 show ?thesis
      by (simp add: mkPX_cn)
  next
    case xy: 3
    then obtain d where y: "y = d + x"
      by atomize_elim arith
    have "isnorm (PX Q1 d (Pc 0))"
    proof (cases Q1)
      case (PX p1 y p2)
      with 9 xy y show ?thesis
        by (cases d) (simp, cases p2, auto)
    next
      case Pc
      with 9 xy y show ?thesis
        by (cases d) auto
    next
      case Pinj
      with 9 xy y show ?thesis
        by (cases d) auto
    qed
    with 9 NQ1 NP1 NP2 NQ2 xy y have "isnorm (P2 \<langle>+\<rangle> Q2)" "isnorm (PX Q1 (y - x) (Pc 0) \<langle>+\<rangle> P1)"
      by auto
    with X0 xy y show ?thesis
      by (simp add: mkPX_cn)
  qed
qed

text \<open>\<open>mul\<close> concerves normalizedness\<close>
lemma mul_cn: "isnorm P \<Longrightarrow> isnorm Q \<Longrightarrow> isnorm (P \<langle>*\<rangle> Q)"
proof (induct P Q rule: mul.induct)
  case 1
  then show ?case by simp
next
  case (2 c i P2)
  then show ?case
    apply (cases P2)
      apply simp_all
    apply (cases i)
     apply (simp_all add: mkPinj_cn)
    done
next
  case (3 i P2 c)
  then show ?case
    apply (cases P2)
      apply simp_all
    apply (cases i)
     apply (simp_all add: mkPinj_cn)
    done
next
  case (4 c P2 i Q2)
  then have "isnorm P2" "isnorm Q2"
    by (auto simp only: norm_PX1[of P2 i Q2] norm_PX2[of P2 i Q2])
  with 4 show ?case
    apply (cases "c = 0")
     apply simp_all
    apply (cases "i = 0")
     apply (simp_all add: mkPX_cn)
    done
next
  case (5 P2 i Q2 c)
  then have "isnorm P2" "isnorm Q2"
    by (auto simp only: norm_PX1[of P2 i Q2] norm_PX2[of P2 i Q2])
  with 5 show ?case
    apply (cases "c = 0")
     apply simp_all
    apply (cases "i = 0")
     apply (simp_all add: mkPX_cn)
    done
next
  case (6 x P2 y Q2)
  consider "x < y" | "x = y" | "x > y" by arith
  then show ?case
  proof cases
    case xy: 1
    then obtain d where y: "y = d + x"
      by atomize_elim arith
    from 6 have *: "x > 0"
      by (cases x) (auto simp add: norm_Pinj_0_False)
    from 6 have **: "isnorm P2" "isnorm Q2"
      by (auto simp add: norm_Pinj[of _ P2] norm_Pinj[of _ Q2])
    from 6 xy y have "isnorm (Pinj d Q2)"
      apply (cases d)
       apply simp
      apply (cases Q2)
        apply auto
      done
    with 6 * ** y show ?thesis
      by (simp add: mkPinj_cn)
  next
    case xy: 2
    from 6 have *: "isnorm P2" "isnorm Q2"
      by (auto simp add: norm_Pinj[of _ P2] norm_Pinj[of _ Q2])
    from 6 have **: "y > 0"
      by (cases y) (auto simp add: norm_Pinj_0_False)
    with 6 xy * ** show ?thesis
      by (simp add: mkPinj_cn)
  next
    case xy: 3
    then obtain d where x: "x = d + y"
      by atomize_elim arith
    from 6 have *: "y > 0"
      by (cases y) (auto simp add: norm_Pinj_0_False)
    from 6 have **: "isnorm P2" "isnorm Q2"
      by (auto simp add: norm_Pinj[of _ P2] norm_Pinj[of _ Q2])
    from 6 xy x have "isnorm (Pinj d P2)"
      apply (cases d)
      apply simp
      apply (cases P2)
      apply auto
      done
    with 6 xy * ** x show ?thesis
      by (simp add: mkPinj_cn)
  qed
next
  case (7 x P2 Q2 y R)
  then have Y0: "y > 0" by (cases y) auto
  consider "x = 0" | "x = 1" | d where "x = Suc (Suc d)"
    by atomize_elim arith
  then show ?case
  proof cases
    case 1
    with 7 show ?thesis
      by (auto simp add: norm_Pinj_0_False)
  next
    case x: 2
    from 7 have "isnorm R" "isnorm P2"
      by (auto simp add: norm_Pinj[of _ P2] norm_PX2[of Q2 y R])
    with 7 x have "isnorm (R \<langle>*\<rangle> P2)" "isnorm Q2"
      by (auto simp add: norm_PX1[of Q2 y R])
    with 7 x Y0 show ?thesis
      by (simp add: mkPX_cn)
  next
    case x: 3
    from 7 have *: "isnorm R" "isnorm Q2"
      by (auto simp add: norm_PX2[of Q2 y R] norm_PX1[of Q2 y R])
    from 7 x have "isnorm (Pinj (x - 1) P2)"
      by (cases P2) auto
    with 7 x * have "isnorm (R \<langle>*\<rangle> Pinj (x - 1) P2)" "isnorm (Pinj x P2 \<langle>*\<rangle> Q2)"
      by auto
    with Y0 x show ?thesis
      by (simp add: mkPX_cn)
  qed
next
  case (8 Q2 y R x P2)
  then have Y0: "y > 0"
    by (cases y) auto
  consider "x = 0" | "x = 1" | d where "x = Suc (Suc d)"
    by atomize_elim arith
  then show ?case
  proof cases
    case 1
    with 8 show ?thesis
      by (auto simp add: norm_Pinj_0_False)
  next
    case x: 2
    from 8 have "isnorm R" "isnorm P2"
      by (auto simp add: norm_Pinj[of _ P2] norm_PX2[of Q2 y R])
    with 8 x have "isnorm (R \<langle>*\<rangle> P2)" "isnorm Q2"
      by (auto simp add: norm_PX1[of Q2 y R])
    with 8 x Y0 show ?thesis
      by (simp add: mkPX_cn)
  next
    case x: 3
    from 8 have *: "isnorm R" "isnorm Q2"
      by (auto simp add: norm_PX2[of Q2 y R] norm_PX1[of Q2 y R])
    from 8 x have "isnorm (Pinj (x - 1) P2)"
      by (cases P2) auto
    with 8 x * have "isnorm (R \<langle>*\<rangle> Pinj (x - 1) P2)" "isnorm (Pinj x P2 \<langle>*\<rangle> Q2)"
      by auto
    with Y0 x show ?thesis
      by (simp add: mkPX_cn)
  qed
next
  case (9 P1 x P2 Q1 y Q2)
  from 9 have X0: "x > 0" by (cases x) auto
  from 9 have Y0: "y > 0" by (cases y) auto
  from 9 have *: "isnorm P1" "isnorm P2"
    by (auto simp add: norm_PX1[of P1 x P2] norm_PX2[of P1 x P2])
  from 9 have "isnorm Q1" "isnorm Q2"
    by (auto simp add: norm_PX1[of Q1 y Q2] norm_PX2[of Q1 y Q2])
  with 9 * have "isnorm (P1 \<langle>*\<rangle> Q1)" "isnorm (P2 \<langle>*\<rangle> Q2)"
    "isnorm (P1 \<langle>*\<rangle> mkPinj 1 Q2)" "isnorm (Q1 \<langle>*\<rangle> mkPinj 1 P2)"
    by (auto simp add: mkPinj_cn)
  with 9 X0 Y0 have
    "isnorm (mkPX (P1 \<langle>*\<rangle> Q1) (x + y) (P2 \<langle>*\<rangle> Q2))"
    "isnorm (mkPX (P1 \<langle>*\<rangle> mkPinj (Suc 0) Q2) x (Pc 0))"
    "isnorm (mkPX (Q1 \<langle>*\<rangle> mkPinj (Suc 0) P2) y (Pc 0))"
    by (auto simp add: mkPX_cn)
  then show ?case
    by (simp add: add_cn)
qed

text \<open>neg conserves normalizedness\<close>
lemma neg_cn: "isnorm P \<Longrightarrow> isnorm (neg P)"
proof (induct P)
  case Pc
  then show ?case by simp
next
  case (Pinj i P2)
  then have "isnorm P2"
    by (simp add: norm_Pinj[of i P2])
  with Pinj show ?case
    by (cases P2) (auto, cases i, auto)
next
  case (PX P1 x P2) note PX1 = this
  from PX have "isnorm P2" "isnorm P1"
    by (auto simp add: norm_PX1[of P1 x P2] norm_PX2[of P1 x P2])
  with PX show ?case
  proof (cases P1)
    case (PX p1 y p2)
    with PX1 show ?thesis
      by (cases x) (auto, cases p2, auto)
  next
    case Pinj
    with PX1 show ?thesis
      by (cases x) auto
  qed (cases x, auto)
qed

text \<open>sub conserves normalizedness\<close>
lemma sub_cn: "isnorm p \<Longrightarrow> isnorm q \<Longrightarrow> isnorm (p \<langle>-\<rangle> q)"
  by (simp add: sub_def add_cn neg_cn)

text \<open>sqr conserves normalizizedness\<close>
lemma sqr_cn: "isnorm P \<Longrightarrow> isnorm (sqr P)"
proof (induct P)
  case Pc
  then show ?case by simp
next
  case (Pinj i Q)
  then show ?case
    apply (cases Q)
      apply (auto simp add: mkPX_cn mkPinj_cn)
    apply (cases i)
     apply (auto simp add: mkPX_cn mkPinj_cn)
    done
next
  case (PX P1 x P2)
  then have "x + x \<noteq> 0" "isnorm P2" "isnorm P1"
    by (cases x) (use PX in \<open>auto simp add: norm_PX1[of P1 x P2] norm_PX2[of P1 x P2]\<close>)
  with PX have "isnorm (mkPX (Pc (1 + 1) \<langle>*\<rangle> P1 \<langle>*\<rangle> mkPinj (Suc 0) P2) x (Pc 0))"
    and "isnorm (mkPX (sqr P1) (x + x) (sqr P2))"
    by (auto simp add: add_cn mkPX_cn mkPinj_cn mul_cn)
  then show ?case
    by (auto simp add: add_cn mkPX_cn mkPinj_cn mul_cn)
qed

text \<open>\<open>pow\<close> conserves normalizedness\<close>
lemma pow_cn: "isnorm P \<Longrightarrow> isnorm (pow n P)"
proof (induct n arbitrary: P rule: less_induct)
  case (less k)
  show ?case
  proof (cases "k = 0")
    case True
    then show ?thesis by simp
  next
    case False
    then have K2: "k div 2 < k"
      by (cases k) auto
    from less have "isnorm (sqr P)"
      by (simp add: sqr_cn)
    with less False K2 show ?thesis
      by (cases "even k") (auto simp add: mul_cn elim: evenE oddE)
  qed
qed

end


(*  File:       Minimax_Rule.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Stephan Bohr, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Minimax Rule\<close>

theory Minimax_Rule
  imports "Compositional_Structures/Basic_Modules/Minimax_Module"
          "Compositional_Structures/Elect_Composition"
begin

text
\<open>This is the Minimax voting rule. It elects the alternatives with the highest
Minimax score.\<close>

subsection \<open>Definition\<close>

fun minimax_rule :: "'a Electoral_Module" where
  "minimax_rule A p vs = elector minimax A p vs"

subsection \<open>Condorcet Consistency Property\<close>

theorem minimax_condorcet: "condorcet_consistency minimax_rule"
proof -
  have
    "condorcet_consistency (elector minimax)"
    using minimax_is_dcc dcc_imp_cc_elector
    by metis
  thus ?thesis
    using condorcet_consistency2 electoral_module_def
          minimax_rule.simps
    by metis
qed

end


(*  Title:      HOL/Eisbach/Examples_FOL.thy
    Author:     Daniel Matichuk, NICTA/UNSW
*)

section \<open>Basic Eisbach examples (in FOL)\<close>

theory Examples_FOL
imports "~~/src/FOL/FOL" Eisbach_Old_Appl_Syntax
begin

subsection \<open>Basic methods\<close>

method my_intros = (rule conjI | rule impI)

lemma "P \<and> Q \<longrightarrow> Z \<and> X"
  apply my_intros+
  oops

method my_intros' uses intros = (rule conjI | rule impI | rule intros)

lemma "P \<and> Q \<longrightarrow> Z \<or> X"
  apply (my_intros' intros: disjI1)+
  oops

method my_spec for x :: 'a = (drule spec[where x="x"])

lemma "\<forall>x. P(x) \<Longrightarrow> P(x)"
  apply (my_spec x)
  apply assumption
  done

subsection \<open>Demo\<close>

named_theorems intros and elims and subst

method prop_solver declares intros elims subst =
  (assumption |
    rule intros | erule elims |
    subst subst | subst (asm) subst |
    (erule notE; solves prop_solver))+

lemmas [intros] =
  conjI
  impI
  disjCI
  iffI
  notI
lemmas [elims] =
  impCE
  conjE
  disjE

lemma "((A \<or> B) \<and> (A \<longrightarrow> C) \<and> (B \<longrightarrow> C)) \<longrightarrow> C"
  apply prop_solver
  done

method guess_all =
  (match premises in U[thin]:"\<forall>x. P (x :: 'a)" for P \<Rightarrow>
    \<open>match premises in "?H (y :: 'a)" for y \<Rightarrow>
       \<open>rule allE[where P = P and x = y, OF U]\<close>
   | match conclusion in "?H (y :: 'a)" for y \<Rightarrow>
       \<open>rule allE[where P = P and x = y, OF U]\<close>\<close>)

lemma "(\<forall>x. P(x) \<longrightarrow> Q(x)) \<Longrightarrow> P(y) \<Longrightarrow> Q(y)"
  apply guess_all
  apply prop_solver
  done

lemma "(\<forall>x. P(x) \<longrightarrow> Q(x)) \<Longrightarrow>  P(z) \<Longrightarrow> P(y) \<Longrightarrow> Q(y)"
  apply (solves \<open>guess_all, prop_solver\<close>)  \<comment> \<open>Try it without solve\<close>
  done

method guess_ex =
  (match conclusion in
    "\<exists>x. P (x :: 'a)" for P \<Rightarrow>
      \<open>match premises in "?H (x :: 'a)" for x \<Rightarrow>
              \<open>rule exI[where x=x]\<close>\<close>)

lemma "P(x) \<Longrightarrow> \<exists>x. P(x)"
  apply guess_ex
  apply prop_solver
  done

method fol_solver =
  ((guess_ex | guess_all | prop_solver); solves fol_solver)

declare
  allI [intros]
  exE [elims]
  ex_simps [subst]
  all_simps [subst]

lemma "(\<forall>x. P(x)) \<and> (\<forall>x. Q(x)) \<Longrightarrow> (\<forall>x. P(x) \<and> Q(x))"
  and  "\<exists>x. P(x) \<longrightarrow> (\<forall>x. P(x))"
  and "(\<exists>x. \<forall>y. R(x, y)) \<longrightarrow> (\<forall>y. \<exists>x. R(x, y))"
  by fol_solver+

end