(*  Title:      ZF/Induct/Comb.thy
    Author:     Lawrence C Paulson
    Copyright   1994  University of Cambridge
*)

section \<open>Combinatory Logic example: the Church-Rosser Theorem\<close>

theory Comb
imports ZF
begin

text \<open>
  Curiously, combinators do not include free variables.

  Example taken from @{cite camilleri92}.
\<close>

subsection \<open>Definitions\<close>

text \<open>Datatype definition of combinators \<open>S\<close> and \<open>K\<close>.\<close>

consts comb :: i
datatype comb =
  K
| S
| app ("p \<in> comb", "q \<in> comb")  (infixl "\<bullet>" 90)

text \<open>
  Inductive definition of contractions, \<open>\<rightarrow>\<^sup>1\<close> and
  (multi-step) reductions, \<open>\<rightarrow>\<close>.
\<close>

consts contract  :: i
abbreviation contract_syntax :: "[i,i] \<Rightarrow> o"  (infixl "\<rightarrow>\<^sup>1" 50)
  where "p \<rightarrow>\<^sup>1 q \<equiv> <p,q> \<in> contract"

abbreviation contract_multi :: "[i,i] \<Rightarrow> o"  (infixl "\<rightarrow>" 50)
  where "p \<rightarrow> q \<equiv> <p,q> \<in> contract^*"

inductive
  domains "contract" \<subseteq> "comb \<times> comb"
  intros
    K:   "[| p \<in> comb;  q \<in> comb |] ==> K\<bullet>p\<bullet>q \<rightarrow>\<^sup>1 p"
    S:   "[| p \<in> comb;  q \<in> comb;  r \<in> comb |] ==> S\<bullet>p\<bullet>q\<bullet>r \<rightarrow>\<^sup>1 (p\<bullet>r)\<bullet>(q\<bullet>r)"
    Ap1: "[| p\<rightarrow>\<^sup>1q;  r \<in> comb |] ==> p\<bullet>r \<rightarrow>\<^sup>1 q\<bullet>r"
    Ap2: "[| p\<rightarrow>\<^sup>1q;  r \<in> comb |] ==> r\<bullet>p \<rightarrow>\<^sup>1 r\<bullet>q"
  type_intros comb.intros

text \<open>
  Inductive definition of parallel contractions, \<open>\<Rrightarrow>\<^sup>1\<close> and
  (multi-step) parallel reductions, \<open>\<Rrightarrow>\<close>.
\<close>

consts parcontract :: i

abbreviation parcontract_syntax :: "[i,i] => o"  (infixl "\<Rrightarrow>\<^sup>1" 50)
  where "p \<Rrightarrow>\<^sup>1 q == <p,q> \<in> parcontract"

abbreviation parcontract_multi :: "[i,i] => o"  (infixl "\<Rrightarrow>" 50)
  where "p \<Rrightarrow> q == <p,q> \<in> parcontract^+"

inductive
  domains "parcontract" \<subseteq> "comb \<times> comb"
  intros
    refl: "[| p \<in> comb |] ==> p \<Rrightarrow>\<^sup>1 p"
    K:    "[| p \<in> comb;  q \<in> comb |] ==> K\<bullet>p\<bullet>q \<Rrightarrow>\<^sup>1 p"
    S:    "[| p \<in> comb;  q \<in> comb;  r \<in> comb |] ==> S\<bullet>p\<bullet>q\<bullet>r \<Rrightarrow>\<^sup>1 (p\<bullet>r)\<bullet>(q\<bullet>r)"
    Ap:   "[| p\<Rrightarrow>\<^sup>1q;  r\<Rrightarrow>\<^sup>1s |] ==> p\<bullet>r \<Rrightarrow>\<^sup>1 q\<bullet>s"
  type_intros comb.intros

text \<open>
  Misc definitions.
\<close>

definition I :: i
  where "I \<equiv> S\<bullet>K\<bullet>K"

definition diamond :: "i \<Rightarrow> o"
  where "diamond(r) \<equiv>
    \<forall>x y. <x,y>\<in>r \<longrightarrow> (\<forall>y'. <x,y'>\<in>r \<longrightarrow> (\<exists>z. <y,z>\<in>r & <y',z> \<in> r))"

subsection \<open>Transitive closure preserves the Church-Rosser property\<close>

lemma diamond_strip_lemmaD [rule_format]:
  "[| diamond(r);  <x,y>:r^+ |] ==>
    \<forall>y'. <x,y'>:r \<longrightarrow> (\<exists>z. <y',z>: r^+ & <y,z>: r)"
  apply (unfold diamond_def)
  apply (erule trancl_induct)
   apply (blast intro: r_into_trancl)
  apply clarify
  apply (drule spec [THEN mp], assumption)
  apply (blast intro: r_into_trancl trans_trancl [THEN transD])
  done

lemma diamond_trancl: "diamond(r) ==> diamond(r^+)"
  apply (simp (no_asm_simp) add: diamond_def)
  apply (rule impI [THEN allI, THEN allI])
  apply (erule trancl_induct)
   apply auto
   apply (best intro: r_into_trancl trans_trancl [THEN transD]
     dest: diamond_strip_lemmaD)+
  done

inductive_cases Ap_E [elim!]: "p\<bullet>q \<in> comb"

subsection \<open>Results about Contraction\<close>

text \<open>
  For type checking: replaces @{term "a \<rightarrow>\<^sup>1 b"} by \<open>a, b \<in>
  comb\<close>.
\<close>

lemmas contract_combE2 = contract.dom_subset [THEN subsetD, THEN SigmaE2]
  and contract_combD1 = contract.dom_subset [THEN subsetD, THEN SigmaD1]
  and contract_combD2 = contract.dom_subset [THEN subsetD, THEN SigmaD2]

lemma field_contract_eq: "field(contract) = comb"
  by (blast intro: contract.K elim!: contract_combE2)

lemmas reduction_refl =
  field_contract_eq [THEN equalityD2, THEN subsetD, THEN rtrancl_refl]

lemmas rtrancl_into_rtrancl2 =
  r_into_rtrancl [THEN trans_rtrancl [THEN transD]]

declare reduction_refl [intro!] contract.K [intro!] contract.S [intro!]

lemmas reduction_rls =
  contract.K [THEN rtrancl_into_rtrancl2]
  contract.S [THEN rtrancl_into_rtrancl2]
  contract.Ap1 [THEN rtrancl_into_rtrancl2]
  contract.Ap2 [THEN rtrancl_into_rtrancl2]

lemma "p \<in> comb ==> I\<bullet>p \<rightarrow> p"
  \<comment> \<open>Example only: not used\<close>
  unfolding I_def by (blast intro: reduction_rls)

lemma comb_I: "I \<in> comb"
  unfolding I_def by blast

subsection \<open>Non-contraction results\<close>

text \<open>Derive a case for each combinator constructor.\<close>

inductive_cases K_contractE [elim!]: "K \<rightarrow>\<^sup>1 r"
  and S_contractE [elim!]: "S \<rightarrow>\<^sup>1 r"
  and Ap_contractE [elim!]: "p\<bullet>q \<rightarrow>\<^sup>1 r"

lemma I_contract_E: "I \<rightarrow>\<^sup>1 r ==> P"
  by (auto simp add: I_def)

lemma K1_contractD: "K\<bullet>p \<rightarrow>\<^sup>1 r ==> (\<exists>q. r = K\<bullet>q & p \<rightarrow>\<^sup>1 q)"
  by auto

lemma Ap_reduce1: "[| p \<rightarrow> q;  r \<in> comb |] ==> p\<bullet>r \<rightarrow> q\<bullet>r"
  apply (frule rtrancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_contract_eq [THEN equalityD1, THEN subsetD])
  apply (erule rtrancl_induct)
   apply (blast intro: reduction_rls)
  apply (erule trans_rtrancl [THEN transD])
  apply (blast intro: contract_combD2 reduction_rls)
  done

lemma Ap_reduce2: "[| p \<rightarrow> q;  r \<in> comb |] ==> r\<bullet>p \<rightarrow> r\<bullet>q"
  apply (frule rtrancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_contract_eq [THEN equalityD1, THEN subsetD])
  apply (erule rtrancl_induct)
   apply (blast intro: reduction_rls)
  apply (blast intro: trans_rtrancl [THEN transD]
                      contract_combD2 reduction_rls)
  done

text \<open>Counterexample to the diamond property for \<open>\<rightarrow>\<^sup>1\<close>.\<close>

lemma KIII_contract1: "K\<bullet>I\<bullet>(I\<bullet>I) \<rightarrow>\<^sup>1 I"
  by (blast intro: comb_I)

lemma KIII_contract2: "K\<bullet>I\<bullet>(I\<bullet>I) \<rightarrow>\<^sup>1 K\<bullet>I\<bullet>((K\<bullet>I)\<bullet>(K\<bullet>I))"
  by (unfold I_def) (blast intro: contract.intros)

lemma KIII_contract3: "K\<bullet>I\<bullet>((K\<bullet>I)\<bullet>(K\<bullet>I)) \<rightarrow>\<^sup>1 I"
  by (blast intro: comb_I)

lemma not_diamond_contract: "\<not> diamond(contract)"
  apply (unfold diamond_def)
  apply (blast intro: KIII_contract1 KIII_contract2 KIII_contract3
    elim!: I_contract_E)
  done

subsection \<open>Results about Parallel Contraction\<close>

text \<open>For type checking: replaces \<open>a \<Rrightarrow>\<^sup>1 b\<close> by \<open>a, b
  \<in> comb\<close>\<close>
lemmas parcontract_combE2 = parcontract.dom_subset [THEN subsetD, THEN SigmaE2]
  and parcontract_combD1 = parcontract.dom_subset [THEN subsetD, THEN SigmaD1]
  and parcontract_combD2 = parcontract.dom_subset [THEN subsetD, THEN SigmaD2]

lemma field_parcontract_eq: "field(parcontract) = comb"
  by (blast intro: parcontract.K elim!: parcontract_combE2)

text \<open>Derive a case for each combinator constructor.\<close>
inductive_cases
      K_parcontractE [elim!]: "K \<Rrightarrow>\<^sup>1 r"
  and S_parcontractE [elim!]: "S \<Rrightarrow>\<^sup>1 r"
  and Ap_parcontractE [elim!]: "p\<bullet>q \<Rrightarrow>\<^sup>1 r"

declare parcontract.intros [intro]

subsection \<open>Basic properties of parallel contraction\<close>

lemma K1_parcontractD [dest!]:
    "K\<bullet>p \<Rrightarrow>\<^sup>1 r ==> (\<exists>p'. r = K\<bullet>p' & p \<Rrightarrow>\<^sup>1 p')"
  by auto

lemma S1_parcontractD [dest!]:
    "S\<bullet>p \<Rrightarrow>\<^sup>1 r ==> (\<exists>p'. r = S\<bullet>p' & p \<Rrightarrow>\<^sup>1 p')"
  by auto

lemma S2_parcontractD [dest!]:
    "S\<bullet>p\<bullet>q \<Rrightarrow>\<^sup>1 r ==> (\<exists>p' q'. r = S\<bullet>p'\<bullet>q' & p \<Rrightarrow>\<^sup>1 p' & q \<Rrightarrow>\<^sup>1 q')"
  by auto

lemma diamond_parcontract: "diamond(parcontract)"
  \<comment> \<open>Church-Rosser property for parallel contraction\<close>
  apply (unfold diamond_def)
  apply (rule impI [THEN allI, THEN allI])
  apply (erule parcontract.induct)
     apply (blast elim!: comb.free_elims  intro: parcontract_combD2)+
  done

text \<open>
  \medskip Equivalence of @{prop "p \<rightarrow> q"} and @{prop "p \<Rrightarrow> q"}.
\<close>

lemma contract_imp_parcontract: "p\<rightarrow>\<^sup>1q ==> p\<Rrightarrow>\<^sup>1q"
  by (induct set: contract) auto

lemma reduce_imp_parreduce: "p\<rightarrow>q ==> p\<Rrightarrow>q"
  apply (frule rtrancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_contract_eq [THEN equalityD1, THEN subsetD])
  apply (erule rtrancl_induct)
   apply (blast intro: r_into_trancl)
  apply (blast intro: contract_imp_parcontract r_into_trancl
    trans_trancl [THEN transD])
  done

lemma parcontract_imp_reduce: "p\<Rrightarrow>\<^sup>1q ==> p\<rightarrow>q"
  apply (induct set: parcontract)
     apply (blast intro: reduction_rls)
    apply (blast intro: reduction_rls)
   apply (blast intro: reduction_rls)
  apply (blast intro: trans_rtrancl [THEN transD]
    Ap_reduce1 Ap_reduce2 parcontract_combD1 parcontract_combD2)
  done

lemma parreduce_imp_reduce: "p\<Rrightarrow>q ==> p\<rightarrow>q"
  apply (frule trancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_parcontract_eq [THEN equalityD1, THEN subsetD])
  apply (erule trancl_induct, erule parcontract_imp_reduce)
  apply (erule trans_rtrancl [THEN transD])
  apply (erule parcontract_imp_reduce)
  done

lemma parreduce_iff_reduce: "p\<Rrightarrow>q \<longleftrightarrow> p\<rightarrow>q"
  by (blast intro: parreduce_imp_reduce reduce_imp_parreduce)

end


(*  File:       Copeland_Module.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>Copeland Module\<close>

theory Copeland_Module
  imports "Component_Types/Elimination_Module"
begin

text
\<open>This is the Copeland module used by the Copeland voting rule. The Copeland
rule elects the alternatives with the highest difference between the amount
of simple-majority wins and the amount of simple-majority losses. The module
implemented herein only rejects the alternatives not elected by the voting
rule, and defers the alternatives that would be elected by the full voting
rule.\<close>

subsection \<open>Definition\<close>

fun copeland_score :: "'a Evaluation_Function" where
  "copeland_score x A p vs =
    card{y \<in> A . wins x p y} - card{y \<in> A . wins y p x}"

fun copeland :: "'a Electoral_Module" where
  "copeland A p vs= max_eliminator copeland_score A p vs"

subsection \<open>Lemmata\<close>

(*For a Condorcet winner w, we have: card{y \<in> A . wins x p y} = |A|-1*)
lemma cond_winner_imp_win_count:
  assumes winner: "condorcet_winner A p w"
  shows "card {y \<in> A . wins w p y} = card A -1"
proof -
  from winner
  have 0: "\<forall>x \<in> A - {w} . wins w p x"
    by simp
  have 1: "\<forall>M . {x \<in> M . True} = M"
    by blast
  from 0 1
  have "{x \<in> A - {w} . wins w p x} = A - {w}"
    by blast
  hence 10: "card {x \<in> A - {w} . wins w p x} = card (A - {w})"
    by simp
  from winner
  have 11: "w \<in> A"
    by simp
  hence "card (A - {w}) = card A - 1"
    using card_Diff_singleton condorcet_winner.simps winner
    by metis
  hence amount1:
    "card {x \<in> A - {w} . wins w p x} = card (A) - 1"
    using "10"
    by linarith
  have 2: "\<forall>x \<in> {w} . \<not> wins x p x"
    by (simp add: wins_irreflex)
  have 3: "\<forall>M . {x \<in> M . False} = {}"
    by blast
  from 2 3
  have "{x \<in> {w} . wins w p x} = {}"
    by blast
  hence amount2: "card {x \<in> {w} . wins w p x} = 0"
    by simp
  have disjunct:
    "{x \<in> A - {w} . wins w p x} \<inter> {x \<in> {w} . wins w p x} = {}"
    by blast
  have union:
    "{x \<in> A - {w} . wins w p x} \<union> {x \<in> {w} . wins w p x} =
        {x \<in> A . wins w p x}"
    using "2"
    by blast
  have finiteness1: "finite {x \<in> A - {w} . wins w p x}"
    using condorcet_winner.simps winner
    by fastforce
  have finiteness2: "finite {x \<in> {w} . wins w p x}"
    by simp
  from finiteness1 finiteness2 disjunct card_Un_disjoint
  have
    "card ({x \<in> A - {w} . wins w p x} \<union> {x \<in> {w} . wins w p x}) =
        card {x \<in> A - {w} . wins w p x} + card {x \<in> {w} . wins w p x}"
    by blast
  with union
  have "card {x \<in> A . wins w p x} =
          card {x \<in> A - {w} . wins w p x} + card {x \<in> {w} . wins w p x}"
    by simp
  with amount1 amount2
  show ?thesis
    by linarith
qed

(*For a Condorcet winner w, we have: card{y \<in> A . wins y p x} = 0*)
lemma cond_winner_imp_loss_count:
  assumes winner: "condorcet_winner A p w"
  shows "card {y \<in> A . wins y p w} = 0"
  using Collect_empty_eq card_eq_0_iff condorcet_winner.simps
        insert_Diff insert_iff wins_antisym winner
  by (metis (no_types, lifting))

(*Copeland Score of a Condorcet Winner*)
lemma cond_winner_imp_copeland_score:
  assumes winner: "condorcet_winner A p w"
  shows "copeland_score w A p vs = card A -1"
  unfolding copeland_score.simps
proof -
  show
    "card {y \<in> A. wins w p y} - card {y \<in> A. wins y p w} =
      card A - 1"
    using cond_winner_imp_loss_count
        cond_winner_imp_win_count winner
  proof -
    have f1: "card {a \<in> A. wins w p a} = card A - 1"
      using cond_winner_imp_win_count winner
      by simp
    have f2: "card {a \<in> A. wins a p w} = 0"
      using cond_winner_imp_loss_count winner
      by (metis (no_types))
    have "card A - 1 - 0 = card A - 1"
      by simp
    thus ?thesis
      using f2 f1
      by simp
  qed
qed

(*
   For a non-Condorcet winner l, we have:
   card{y \<in> A . wins x p y} <= |A|-1 -1
*)
lemma non_cond_winner_imp_win_count:
  assumes
    winner: "condorcet_winner A p w" and
    loser: "l \<noteq> w" and
    l_in_A: "l \<in> A"
  shows "card {y \<in> A . wins l p y} <= card A - 2"
proof -
  from winner loser l_in_A
  have "wins w p l"
    by simp
  hence 0: "\<not> wins l p w"
    by (simp add: wins_antisym)
  have 1: "\<not> wins l p l"
    by (simp add: wins_irreflex)
  from 0 1 have 2:
    "{y \<in> A . wins l p y} =
        {y \<in> A-{l,w} . wins l p y}"
    by blast
  have 3: "\<forall> M f . finite M \<longrightarrow> card {x \<in> M . f x} \<le> card M"
    by (simp add: card_mono)
  have 4: "finite (A-{l,w})"
    using condorcet_winner.simps finite_Diff winner
    by metis
  from 3 4 have 5:
    "card {y \<in> A-{l,w} . wins l p y} \<le>
      card (A-{l,w})"
    by (metis (full_types))
  have "w \<in> A"
    using condorcet_winner.simps winner
    by metis
  with l_in_A
  have "card(A-{l,w}) = card A - card {l,w}"
    by (simp add: card_Diff_subset)
  hence "card(A-{l,w}) = card A - 2"
    by (simp add: loser)
  with 5 2
  show ?thesis
    by simp
qed

subsection \<open>Property\<close>

(*The Copeland score is Condorcet rating*)
theorem copeland_score_is_cr: "condorcet_rating copeland_score"
  unfolding condorcet_rating_def
proof (unfold copeland_score.simps, safe)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a" and
    l :: "'a"
  assume
    winner: "condorcet_winner A p w" and
    l_in_A: "l \<in> A" and
    l_neq_w: "l \<noteq> w"
  show
    "card {y \<in> A. wins l p y} - card {y \<in> A. wins y p l}
        < card {y \<in> A. wins w p y} - card {y \<in> A. wins y p w}"
  proof -
    from winner have 0:
      "card {y \<in> A. wins w p y} - card {y \<in> A. wins y p w} =
        card A -1"
      using cond_winner_imp_copeland_score
      by fastforce
    from winner l_neq_w l_in_A have 1:
      "card {y \<in> A. wins l p y} - card {y \<in> A. wins y p l} \<le>
          card A -2"
      using non_cond_winner_imp_win_count
      by fastforce
    have 2: "card A -2 < card A -1"
      using card_0_eq card_Diff_singleton
            condorcet_winner.simps diff_less_mono2
            empty_iff finite_Diff insertE insert_Diff
            l_in_A l_neq_w neq0_conv one_less_numeral_iff
            semiring_norm(76) winner zero_less_diff
      by metis
    hence
      "card {y \<in> A. wins l p y} - card {y \<in> A. wins y p l} <
        card A -1"
      using "1" le_less_trans
      by blast
    with 0
    show ?thesis
      by linarith
  qed
qed

theorem copeland_is_dcc: "defer_condorcet_consistency copeland"
unfolding defer_condorcet_consistency_def electoral_module_def
proof (safe)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs :: "'a Pair_Vectors"
  assume
    finA: "finite A" and
    profA: "profile A p" and
    vecA: "vector_pair A vs"
  have "well_formed A (max_eliminator copeland_score A p vs)"
    using electoral_module_def finA max_elim_sound profA vecA
    by blast
  thus "well_formed A (copeland A p vs)"
    by simp
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a" and
    vs :: "'a Pair_Vectors"
  assume
    cwin_w: "condorcet_winner A p w" and
    finA: "finite A" and
    vecA: "vector_pair A vs"
  have max_cplscore_dcc:
    "defer_condorcet_consistency (max_eliminator copeland_score)"
    using cr_eval_imp_dcc_max_elim finA
    by (simp add: copeland_score_is_cr)
  have
    "\<forall>A p. (copeland A p vs = max_eliminator copeland_score A p vs)"
    by simp
  with defer_condorcet_consistency_def
  show
    "copeland A p vs=
      ({},
       A - defer copeland A p vs,
       {d \<in> A. condorcet_winner A p d})"
    using Collect_cong cwin_w finA max_cplscore_dcc vecA
    by (smt (z3))
qed

end


theory Available_Expressions imports Reaching_Definitions begin

section \<open>Available Expressions\<close>

fun ae_arith :: "'v arith \<Rightarrow> 'v arith set" where
  "ae_arith (Integer i) = {}"
| "ae_arith (Arith_Var v) = {}"
| "ae_arith (Arith_Op a1 opr a2) = ae_arith a1 \<union> ae_arith a1 \<union> {Arith_Op a1 opr a2}"
| "ae_arith (Minus a) = ae_arith a"

lemma finite_ae_arith: "finite (ae_arith a)"
  by (induction a) auto

fun ae_boolean :: "'v boolean \<Rightarrow> 'v arith set" where
  "ae_boolean true = {}"
| "ae_boolean false = {}"
| "ae_boolean (Rel_Op a1 opr a2) = ae_arith a1 \<union> ae_arith a2"
| "ae_boolean (Bool_Op b1 opr b2) = ae_boolean b1 \<union> ae_boolean b2"
| "ae_boolean (Neg b) = ae_boolean b"

lemma finite_ae_boolean: "finite (ae_boolean b)"
  using finite_ae_arith by (induction b) auto

fun aexp_action :: "'v action \<Rightarrow> 'v arith set" where
  "aexp_action (x ::= a) = ae_arith a"
| "aexp_action (Bool b) = ae_boolean b"
| "aexp_action Skip = {}"

lemma finite_aexp_action: "finite (aexp_action \<alpha>)"
  using finite_ae_arith finite_ae_boolean by (cases \<alpha>) auto

fun aexp_edge :: "('n,'v) edge \<Rightarrow> 'v arith set" where
  "aexp_edge (q1, \<alpha>, q2) = aexp_action \<alpha>"

lemma finite_aexp_edge: "finite (aexp_edge (q1, \<alpha>, q2))"
  using finite_aexp_action by auto

fun aexp_pg :: "('n,'v) program_graph \<Rightarrow> 'v arith set" where
  "aexp_pg pg = \<Union>(aexp_edge ` (fst pg))"

definition aexp_edge_list :: "('n,'v) edge list \<Rightarrow> 'v arith \<Rightarrow> bool" where
  "aexp_edge_list \<pi> a = (\<exists>\<pi>1 \<pi>2 e. \<pi> = \<pi>1 @ [e] @ \<pi>2 \<and> a \<in> aexp_edge e \<and> (\<forall>e' \<in> set ([e] @ \<pi>2). fv_arith a \<inter> def_edge e' = {}))"

definition aexp_path :: "'n list \<times> 'v action list \<Rightarrow> 'v arith set" where
  "aexp_path \<pi> = {a. aexp_edge_list (transition_list \<pi>) a}"

locale analysis_AE = finite_program_graph pg
  for pg :: "('n::finite,'v::finite) program_graph"
begin

interpretation LTS edge_set .

definition analysis_dom_AE :: "'v arith set" where
  "analysis_dom_AE = aexp_pg pg"

lemma finite_analysis_dom_AE: "finite analysis_dom_AE"
proof -
  have "finite (\<Union> (aexp_edge ` edge_set))"
    by (metis aexp_edge.elims finite_UN finite_aexp_edge finite_program_graph_axioms
        finite_program_graph_def)
  then show ?thesis
    unfolding analysis_dom_AE_def using edge_set_def by force
qed

fun kill_set_AE :: "('n,'v) edge \<Rightarrow> 'v arith set" where
  "kill_set_AE (q\<^sub>o, x ::= a, q\<^sub>s) = {a'. x \<in> fv_arith a'}"
| "kill_set_AE (q\<^sub>o, Bool b, q\<^sub>s) = {}"
| "kill_set_AE (v, Skip, vc) = {}"

fun gen_set_AE :: "('n,'v) edge \<Rightarrow> 'v arith set" where
  "gen_set_AE (q\<^sub>o, x ::= a, q\<^sub>s) = {a'. a' \<in> ae_arith a \<and> x \<notin> fv_arith a'}"
| "gen_set_AE (q\<^sub>o, Bool b, q\<^sub>s) = ae_boolean b"
| "gen_set_AE (v, Skip, vc) = {}"

definition d_init_AE :: "'v arith set" where
  "d_init_AE = {}"

interpretation fw_must: analysis_BV_forward_must pg analysis_dom_AE kill_set_AE gen_set_AE d_init_AE
  using analysis_BV_forward_must.intro analysis_AE_axioms analysis_AE_def
    d_init_AE_def empty_subsetI finite_analysis_dom_AE analysis_BV_forward_must_axioms.intro
  by metis

lemma aexp_edge_list_S_hat_edge_list:
  assumes "a \<in> aexp_edge (q, \<alpha>, q')"
  assumes "fv_arith a \<inter> def_edge (q, \<alpha>, q') = {}"
  shows "a \<in> fw_must.S_hat (q, \<alpha>, q') R"
  using assms unfolding fw_must.S_hat_def by (cases \<alpha>) auto

lemma empty_inter_fv_arith_def_edge:
  assumes "aexp_edge_list (\<pi> @ [e]) a"
  shows "fv_arith a \<inter> def_edge e = {}"
proof -
  from assms(1) obtain \<pi>1 \<pi>2 e' where \<pi>1_\<pi>2_e'_p:
    "\<pi> @ [e] = \<pi>1 @ [e'] @ \<pi>2"
    "a \<in> aexp_edge e'"
    "(\<forall>e''\<in>set ([e'] @ \<pi>2). fv_arith a \<inter> def_edge e'' = {})"
    unfolding aexp_edge_list_def by auto
  from this(1) have "e \<in> set ([e'] @ \<pi>2)"
    by (metis append_is_Nil_conv last_appendR last_in_set snoc_eq_iff_butlast)
  then show "fv_arith a \<inter> def_edge e = {}"
    using \<pi>1_\<pi>2_e'_p(3) by auto
qed

lemma aexp_edge_list_append_singleton:
  assumes "aexp_edge_list (\<pi> @ [e]) a"
  shows "aexp_edge_list \<pi> a \<or> a \<in> aexp_edge e"
proof -
  from assms(1) obtain \<pi>1 \<pi>2 e' where \<pi>1_\<pi>2_e'_p:
    "\<pi> @ [e] = \<pi>1 @ [e'] @ \<pi>2"
    "a \<in> aexp_edge e'"
    "(\<forall>e''\<in>set ([e'] @ \<pi>2). fv_arith a \<inter> def_edge e'' = {})"
    unfolding aexp_edge_list_def by auto
  from this(1) have "e \<in> set ([e'] @ \<pi>2)"
    by (metis append_is_Nil_conv last_appendR last_in_set snoc_eq_iff_butlast)
  then have "e = e' \<or> e \<in> set \<pi>2"
    by auto
  then show ?thesis
  proof
    assume "e = e'"
    then have "a \<in> aexp_edge e"
      using \<pi>1_\<pi>2_e'_p by auto
    then show ?thesis
      by auto
  next
    assume "e \<in> set \<pi>2"
    have "\<pi> = \<pi>1 @ [e'] @ (butlast \<pi>2)"
      by (metis \<open>e \<in> set \<pi>2\<close> \<pi>1_\<pi>2_e'_p(1) append_is_Nil_conv butlast_append butlast_snoc in_set_conv_decomp_first)
    moreover
    have "a \<in> aexp_edge e'"
      by (simp add: \<pi>1_\<pi>2_e'_p(2))
    moreover
    have "(\<forall>e''\<in>set ([e'] @ butlast \<pi>2). fv_arith a \<inter> def_edge e'' = {})"
      by (metis \<pi>1_\<pi>2_e'_p(3) butlast.simps(1) butlast_append in_set_butlastD)
    ultimately
    have "aexp_edge_list \<pi> a"
      unfolding aexp_edge_list_def by blast
    then show ?thesis
      by auto
  qed
qed

lemma gen_set_AE_subset_aexp_edge:
  assumes "a \<in> gen_set_AE e"
  shows "a \<in> aexp_edge e"
proof -
  obtain q \<alpha> q' where "e = (q, \<alpha>, q')"
    by (cases e)
  then show ?thesis
    using assms by (cases \<alpha>) auto
qed

lemma empty_inter_fv_arith_def_edge':
  assumes "a \<in> gen_set_AE e"
  shows "fv_arith a \<inter> def_edge e = {}"
proof -
  obtain q \<alpha> q' where "e = (q, \<alpha>, q')"
    by (cases e)
  then show ?thesis
    using assms by (cases \<alpha>) auto
qed

lemma empty_inter_fv_arith_def_edge'':
  assumes "a \<notin> kill_set_AE e"
  shows "fv_arith a \<inter> def_edge e = {}"
proof -
  obtain q \<alpha> q' where "e = (q, \<alpha>, q')"
    by (cases e)
  then show ?thesis
    using assms by (cases \<alpha>) auto
qed

lemma S_hat_edge_list_aexp_edge_list:
  assumes "a \<in> fw_must.S_hat_edge_list \<pi> d_init_AE"
  shows "aexp_edge_list \<pi> a"
  using assms
proof (induction \<pi> rule: rev_induct)
  case Nil
  then show ?case
    unfolding d_init_AE_def by auto
next
  case (snoc e \<pi>)
  from snoc(2) have "a \<in> (fw_must.S_hat_edge_list \<pi> d_init_AE - kill_set_AE e) \<or> a \<in> gen_set_AE e"
    using fw_must.S_hat_def by auto
  then show ?case
  proof
    assume a_S_hat: "a \<in> fw_must.S_hat_edge_list \<pi> d_init_AE - kill_set_AE e"
    then have "aexp_edge_list \<pi> a"
      using snoc by auto
    moreover
    from a_S_hat have "a \<notin> kill_set_AE e"
      by auto
    then have "fv_arith a \<inter> def_edge e = {}"
      using empty_inter_fv_arith_def_edge'' by auto
    ultimately show "aexp_edge_list (\<pi> @ [e]) a"
      unfolding aexp_edge_list_def by force
  next
    assume a_gen: "a \<in> gen_set_AE e"
    then have "a \<in> aexp_edge e"
      using gen_set_AE_subset_aexp_edge by auto
    moreover
    from a_gen have "(fv_arith a \<inter> def_edge e = {})"
      using empty_inter_fv_arith_def_edge' by auto
    ultimately
    show "aexp_edge_list (\<pi> @ [e]) a"
      unfolding aexp_edge_list_def
      by (metis append_Nil2 empty_iff empty_set insert_iff list.set(2))
  qed
qed

lemma not_kill_set_AE_iff_fv_arith_def_edge_disjoint:
  "fv_arith a \<inter> def_edge e = {} \<longleftrightarrow> a \<notin> kill_set_AE e"
proof -
  obtain q \<alpha> q' where e_split: "e = (q, \<alpha>, q')"
    by (cases e)
  then show ?thesis
     by (cases \<alpha>) auto
qed

lemma gen_set_AE_AE_iff_fv_arith_def_edge_disjoint_and_aexp_edge:
  "a \<in> aexp_edge e \<and> fv_arith a \<inter> def_edge e = {} \<longleftrightarrow> a \<in> gen_set_AE e"
proof -
  obtain q \<alpha> q' where e_split: "e = (q, \<alpha>, q')"
    by (cases e)
  then show ?thesis
    by (cases \<alpha>) auto
qed

lemma aexp_edge_list_S_hat_edge_list':
  assumes "aexp_edge_list \<pi> a"
  shows "a \<in> fw_must.S_hat_edge_list \<pi> d_init_AE"
  using assms
proof (induction \<pi> rule: rev_induct)
  case Nil
  then have False
    unfolding aexp_edge_list_def by auto
  then show ?case
    by metis
next
  case (snoc e \<pi>)
  have fvae: "fv_arith a \<inter> def_edge e = {}"
    using snoc(2) empty_inter_fv_arith_def_edge by metis

  have "aexp_edge_list \<pi> a \<or> a \<in> aexp_edge e"
    using snoc(2)
    by (simp add: aexp_edge_list_append_singleton)
  then show ?case
  proof
    assume "aexp_edge_list \<pi> a"
    then have "a \<in> fw_must.S_hat_edge_list \<pi> d_init_AE"
      using snoc by auto
    moreover
    have "a \<notin> kill_set_AE e"
      using fvae not_kill_set_AE_iff_fv_arith_def_edge_disjoint by auto
    ultimately
    show ?case
      using fw_must.S_hat_def by auto
  next
    assume "a \<in> aexp_edge e"
    then have "a \<in> gen_set_AE e"
      using fvae gen_set_AE_AE_iff_fv_arith_def_edge_disjoint_and_aexp_edge by metis
    then show ?case
      using fw_must.S_hat_def by auto
  qed
qed

lemma aexp_edge_list_S_hat_edge_list_iff:
  "aexp_edge_list \<pi> a \<longleftrightarrow> a \<in> fw_must.S_hat_edge_list \<pi> d_init_AE"
  using S_hat_edge_list_aexp_edge_list aexp_edge_list_S_hat_edge_list' by blast

lemma aexp_path_S_hat_path_iff:
  "a \<in> aexp_path \<pi> \<longleftrightarrow> a \<in> fw_must.S_hat_path \<pi> d_init_AE"
  using S_hat_edge_list_aexp_edge_list aexp_edge_list_S_hat_edge_list' aexp_path_def fw_must.S_hat_path_def by blast

definition summarizes_AE :: "(pred, ('n, 'a, 'v arith) cst) pred_val \<Rightarrow> bool" where
   "summarizes_AE \<rho> \<longleftrightarrow>
     (\<forall>q d.
         \<rho> \<Turnstile>\<^sub>l\<^sub>h must\<langle>[q, d]\<rangle>. \<longrightarrow>
          (\<forall>\<pi>. \<pi> \<in> path_with_word_from_to start (the_Node\<^sub>i\<^sub>d q) \<longrightarrow> (the_Elem\<^sub>i\<^sub>d d) \<in> aexp_path \<pi>))"

theorem AE_sound:
  assumes "\<rho> \<Turnstile>\<^sub>l\<^sub>s\<^sub>t (fw_must.ana_pg_fw_must) s_BV"
  shows "summarizes_AE \<rho>"
proof -
  from assms have "fw_must.summarizes_fw_must \<rho>"
    using fw_must.sound_ana_pg_fw_must by auto
  then show ?thesis
    unfolding summarizes_AE_def fw_must.summarizes_fw_must_def edge_set_def edge_set_def
      end_def end_def aexp_path_S_hat_path_iff start_def start_def by force
qed

end

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               November 2004               |
            |                   June 2005  (modified)   |
            |                   July 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                  April 2016  (modified)   |
            |                                           |            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory Infra_real
imports Infra_common
begin

(*****************************************************
                    Real number
 *****************************************************)

(* this lemma real_mult_less_mono
   was given in Isabelle 2005, but is removed in Isabelle 2007 *)

lemma real_mult_less_mono:
     "[| u<v;  x<y;  (0::real) < v;  0 < x |] ==> u*x < v* y"
by (simp add: Rings.mult_strict_mono order_less_imp_le)
(* by (simp add: Ring_and_Field.mult_strict_mono order_less_imp_le)     isabelle2009-1 *)

(* mult_commute for Isabelle 2016 *)
lemma mult_commute: "(x::real) * y = y * x"
apply (simp)
done

lemma real_mult_add_distrib: "(x::real) * (y + z) = x * y + x * z"
apply (subgoal_tac "x * (y + z) = (y + z) * x")
 (* apply (simp add: real_add_mult_distrib)   isabelle 2011 *)
(* apply (simp add: distrib)  Isabelle 2013 *)
apply (simp add: distrib_left)
apply (simp add: mult_commute)
done

lemma real_mult_order_eq : "[| 0 <= x; 0 <= y |] ==> (0::real) <= x * y"
apply (case_tac "x = 0", simp)
apply (case_tac "y = 0", simp)
apply (subgoal_tac "0 < x * y")
apply (simp)
(* apply (simp add: real_mult_order)  isabelle 2011 *)
apply (simp add: zero_less_mult_iff)
done

lemma real_div_le_eq:
   "0 < (z::real) ==> (x <= y / z) = (x * z <= y)"
apply (rule iffI)
apply (insert mult_right_mono[of x "y/z" z], simp)
apply (insert real_mult_le_cancel_iff1[of z x "y/z"], simp)
done

lemma real_div_less_eq:
   "0 < (z::real) ==> (x < y / z) = (x * z < y)"
apply (rule iffI)
apply (insert real_mult_less_iff1[of z x "y/z"], simp)
apply (insert mult_less_cancel_right[of x "y/z" z], simp)
done

lemma real_less_div_eq:
   "0 < (z::real) ==> (x / z < y) = (x < y * z)"
apply (rule iffI)
apply (insert real_mult_less_iff1[of z "x/z" y], simp)
apply (insert mult_less_cancel_right[of "x/z" y z], simp)
done

lemma real_mult_div_commute:
     "[| (0::real) <= x ; 0 < y ; 0 < z ; 0 < r |]
        ==> (x < y * z / r) = (r * x / z < y)"
apply (simp add: real_div_less_eq)
apply (simp add: real_less_div_eq)
apply (simp add: mult_commute)
done

lemma real_mult_div_commuteI:
     "[| (0::real) <= x ; 0 < y ; 0 < z ; 0 < r ; x < y * z / r |]
        ==> (r * x / z < y)"
apply (simp add: real_mult_div_commute)
done

lemma real_mult_less_iff2: "(0::real) < z ==> (z*x < z*y) = (x < y)"
by (simp add: mult_commute)

lemma real_mult_less_if2: "[| (0::real) < z ; (x::real) < y |] ==> z*x < z*y"
by (simp add: real_mult_less_iff2)

lemma real_mult_less_if1: "[| (0::real) < z ; (x::real) < y |] ==> x*z < y*z"
by (simp)

(*** rev_power_decreasing ***)

lemma rev_power_decreasing:
  "[| (0::real) < r ; r < 1 ; r ^ n <= r ^ m |] ==> m <= n"

apply (case_tac "m <= n")
 apply (simp)

(* else n < m --> contradiction *)
apply (insert power_decreasing[of "Suc n" m r])
apply (simp)
apply (subgoal_tac "r * r ^ n <  1 * r ^ n")
apply (simp)
apply (rule real_mult_less_if1)
by (simp_all)

(*** rev_power_decreasing_strict ***)

lemma rev_power_decreasing_strict :
  "[| (0::real) < r ; r < 1 ; r ^ n < r ^ m |] ==> m < n"
apply (case_tac "m < n")
 apply (simp)

(* else n <= m --> contradiction *)
apply (insert power_decreasing[of n m r])
by (simp)

end