(* D. Fuenmayor and A. Steen, August 2021 *)
(* This file contains experiments with and verification of properties of labelling-based semantics
   for argumentation frameworks. *)
(* Auxiliary references:
 [BCG 2011] Baroni, P., M. Caminada and M. Giacomin, An introduction to argumentation semantics,
            Knowledge Engineering Review (2011)
 [Dung 1995] Dung, P.M., On the acceptability of arguments and its fundamental role in nonmonotonic reasoning,
            logic programming and n-person games, Artificial Intelligence. (1995)
*)
theory "lab-properties"
  imports labellings correspondence "ext-properties"
begin

(******************** Admissible and conflict-free **********************)

(* There always exists an admissible Labelling (label, e.g., all arguments as Undec). *)
lemma exAdmissible: \<open>\<exists>Lab. admissibleLab\<^sup>\<A> att Lab\<close> unfolding Defs by auto
(* See here: *)
lemma fixes att :: \<open>'a Rel\<close> and Lab :: \<open>'a Labelling\<close>
      assumes \<open>\<forall>x. \<A> x \<longrightarrow> undec Lab x\<close> (* give every argument the label Undec *)
      shows \<open>admissibleLab\<^sup>\<A> att Lab\<close> using assms unfolding Defs by simp

(* every admissible labelling is conflict-free but not the other way round*)
lemma admissibleLabConflictfree: \<open>admissibleLab\<^sup>\<A> att Lab \<Longrightarrow> conflictfreeLab\<^sup>\<A> att Lab\<close>
  by (simp add: admissibleLab_def conflictfreeLab_def inset_def legallyIn_def legallyOut_def outset_def)
lemma \<open>conflictfreeLab\<^sup>\<A> att Lab \<Longrightarrow> admissibleLab\<^sup>\<A> att Lab\<close> nitpick oops

(*For admissible labellings, legally-undecided implies undecided but not the other way round*)
lemma admissibleLabLegUndec: \<open>admissibleLab\<^sup>\<A> att Lab \<Longrightarrow> \<forall>x. \<A> x \<longrightarrow> legallyUndec\<^sup>\<A> att Lab x \<longrightarrow> undec Lab x\<close>
  unfolding admissibleLab_def by (meson Label.exhaust inset_def legallyUndec_def outset_def undecset_def)

lemma \<open>admissibleLab\<^sup>\<A> att Lab \<Longrightarrow> \<forall>x. \<A> x \<longrightarrow> undec Lab x \<longrightarrow> legallyUndec\<^sup>\<A> att Lab x\<close> nitpick oops

(*OTOH, for admissible labellings, legally-in/out still do not imply in/out*)
lemma \<open>admissibleLab\<^sup>\<A> att Lab \<Longrightarrow> \<forall>x. \<A> x \<longrightarrow> legallyIn\<^sup>\<A> att Lab x \<longrightarrow> in Lab x\<close> nitpick oops
lemma \<open>admissibleLab\<^sup>\<A> att Lab \<Longrightarrow> \<forall>x. \<A> x \<longrightarrow> legallyOut\<^sup>\<A> att Lab x \<longrightarrow> out Lab x\<close> nitpick oops

lemma DungFundLemma1Lab: \<open>admissibleLab\<^sup>\<A> att Lab \<and> defends\<^sup>\<A> att (in Lab) a \<longrightarrow>
                                admissibleLab\<^sup>\<A> att ( \<lambda>x. if (x = a) then In else
                                                     (if (att x a) then Out else (Lab x)) )\<close>
  unfolding defends_rel_def admissibleLab_def
  by (smt (z3) Label.distinct(1) inset_def legallyIn_def legallyOut_def outset_def)
(********************************** Complete **************************************)

(* For complete labellings, legally-in/out does indeed imply in/out-labelled. *)
lemma completeLabLegIn:  \<open>completeLab\<^sup>\<A> att Lab \<Longrightarrow> \<forall>x. \<A> x \<longrightarrow> legallyIn\<^sup>\<A> att Lab x \<longrightarrow> in Lab x\<close>
  unfolding Defs using Label.exhaust by metis
lemma completeLabLegOut: \<open>completeLab\<^sup>\<A> att Lab \<Longrightarrow> \<forall>x. \<A> x \<longrightarrow> legallyOut\<^sup>\<A> att Lab x \<longrightarrow> out Lab x\<close>
  unfolding Defs using Label.exhaust by metis

(*in-sets of complete labellings are fixed points of the characteristic function*)
lemma completeLabInFP: "completeLab\<^sup>\<A> att Lab \<Longrightarrow> fixpoint\<^sup>\<A> (\<F>\<^sup>\<A> att) (in Lab)"
  unfolding fixpoint_rel_def using completeLab2_def complete_defEq
  by (smt (verit, ccfv_threshold) defends_rel_def legallyIn_def legallyOut_def)

lemma completeLabInFP': "completeLab\<^sup>\<A> att Lab \<Longrightarrow> fixpoint\<^sup>\<A> (\<F>\<^sup>\<A> att) (\<A> \<inter> (in Lab))"
unfolding fixpoint_rel_def using completeLab2_def complete_defEq
  by (smt (verit, ccfv_threshold) defends_rel_def legallyIn_def legallyOut_def)

(* lemma \<open>\<exists>Lab. fixpoint\<^sup>\<A> (\<F>\<^sup>\<A> att) (in Lab)\<close> oops (*TODO*)  *)

(* complete labellings always exist *)
lemma \<open>\<exists>Lab. completeLab\<^sup>\<A> att Lab\<close> oops (*See adequacy.thy*)

(* every complete labelling is admissible but not the other way round *)
lemma completeLabAdmissible: \<open>completeLab\<^sup>\<A> att Lab \<Longrightarrow> admissibleLab\<^sup>\<A> att Lab\<close> by (simp add: completeLab_def)
lemma \<open>admissibleLab\<^sup>\<A> att Lab \<Longrightarrow> completeLab\<^sup>\<A> att Lab\<close> nitpick oops

(* For complete labellings we have that in/out-sets completely determine the labelling*)
lemma completeLabInLab: \<open>completeLab\<^sup>\<A> att L1 \<Longrightarrow> completeLab\<^sup>\<A> att L2 \<Longrightarrow> in(L1) \<approx>\<^sup>\<A> in(L2) \<longrightarrow> (\<forall>x. \<A> x \<longrightarrow> L1(x) = L2(x))\<close>
  unfolding completeLab2_def complete_defEq by (smt (verit, best) Label.exhaust inset_def legallyOut_def outset_def)

lemma completeLabOutLab: \<open>completeLab\<^sup>\<A> att L1 \<Longrightarrow> completeLab\<^sup>\<A> att L2 \<Longrightarrow> out(L1) \<approx>\<^sup>\<A> out(L2) \<longrightarrow> (\<forall>x. \<A> x \<longrightarrow> L1(x) = L2(x))\<close>
  unfolding completeLab2_def complete_defEq by (smt (verit, best) Label.exhaust inset_def legallyIn_def outset_def)

lemma \<open>completeLab\<^sup>\<A> att L1 \<Longrightarrow> completeLab\<^sup>\<A> att L2 \<Longrightarrow> undec(L1) \<approx>\<^sup>\<A> undec(L2) \<longrightarrow> (\<forall>x. \<A> x \<longrightarrow> L1(x) = L2(x))\<close> nitpick oops

(* For complete labellings, every in-set which is minimal is the least in-set.
(this result is key and has somehow to do with the fact that complete extensions are fixed points of a monotonic function)*)
lemma completeLabMinLeastIn: \<open>minimal\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab in \<longrightarrow> least\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab in\<close>
  unfolding completeLab2_def complete_defEq using completeLabInFP oops (* nitpick oops (*TODO*) *)
(*(these two below may hold too, but are less important)*)
lemma \<open>minimal\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab out \<longrightarrow> least\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab out\<close> oops
lemma \<open>maximal\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab undec \<longrightarrow> greatest\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab undec\<close> oops

(*Lemma 1 from [BCG2011] *)
lemma \<open>completeLab\<^sup>\<A> att Lab1 \<Longrightarrow> completeLab\<^sup>\<A> att Lab2 \<Longrightarrow> ((in Lab1) \<subseteq>\<^sup>\<A> (in Lab2)) \<longleftrightarrow> ((out Lab1) \<subseteq>\<^sup>\<A> (out Lab2))\<close>
  unfolding Defs by (smt (verit) Label.exhaust inset_def legallyIn_def legallyOut_def legallyUndec_def outset_def)

(*Prop 5 from [BCG2011], only partially proven so far *)
lemma prop5_1iff2: \<open>minimal\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab out = minimal\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab in\<close>
  unfolding minimal_rel_def using complete_defEq completeLab2_def by (smt (z3) Label.exhaust legallyIn_def legallyOut_def)

(* some of the following still required *)
lemma prop5_1to3: \<open>minimal\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab in \<longrightarrow> maximal\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab undec\<close> oops (*TODO*)
lemma prop5_2to3: \<open>minimal\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab out \<longrightarrow> maximal\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab undec\<close> oops (*TODO*)
lemma prop5_3to1: \<open>maximal\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab undec \<longrightarrow> minimal\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab in\<close> oops (*TODO*)
lemma prop5_3to2: \<open>maximal\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab undec \<longrightarrow> minimal\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab out\<close> oops (*TODO*)

(*However, we can prove weaker variants of some of the above*)
lemma prop5_2to3_weak: \<open>least\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab out \<longrightarrow> greatest\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab undec\<close>
  unfolding least_rel_def greatest_rel_def by (smt (verit, ccfv_SIG) Label.exhaust completeLab2_def complete_defEq inset_def legallyIn_def outset_def undecset_def)

lemma prop5_3to2_weak: \<open>greatest\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab undec \<longrightarrow> minimal\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab out\<close>
  unfolding minimal_rel_def greatest_rel_def
  by (smt (verit, best) admissibleLabConflictfree Label.exhaust conflictfreeLab_def inset_def legallyOut_def outset_def undecset_def completeLabAdmissible)

(* Prop 2 BCG*)
lemma complete_iff_inoutlegal: \<open>completeLab\<^sup>\<A> att Lab \<longleftrightarrow> (\<forall>\<^sup>\<A> (\<lambda> a. ((Lab a) = In) \<longleftrightarrow> \<forall>\<^sup>\<A> (\<lambda>b. att b a \<longrightarrow> (Lab b) = Out)) ) \<and> (\<forall>\<^sup>\<A> (\<lambda> a. ((Lab a) = Out) \<longleftrightarrow> \<exists>\<^sup>\<A> (\<lambda>b. att b a \<and> (Lab b) = In)) )\<close>
proof
  show \<open>completeLab\<^sup>\<A> att Lab \<Longrightarrow> (\<forall>\<^sup>\<A> (\<lambda> a. ((Lab a) = In) \<longleftrightarrow> \<forall>\<^sup>\<A> (\<lambda>b. att b a \<longrightarrow> (Lab b) = Out)) ) \<and> (\<forall>\<^sup>\<A> (\<lambda> a. ((Lab a) = Out) \<longleftrightarrow> \<exists>\<^sup>\<A> (\<lambda>b. att b a \<and> (Lab b) = In)) )\<close>
  unfolding completeLab_def  admissibleLab_def
  by (smt (z3) Label.exhaust inset_def legallyIn_def legallyOut_def legallyUndec_def outset_def undecset_def)
next
  show \<open> (\<forall>\<^sup>\<A> (\<lambda> a. ((Lab a) = In) \<longleftrightarrow> \<forall>\<^sup>\<A> (\<lambda>b. att b a \<longrightarrow> (Lab b) = Out)) ) \<and> (\<forall>\<^sup>\<A> (\<lambda> a. ((Lab a) = Out) \<longleftrightarrow> \<exists>\<^sup>\<A> (\<lambda>b. att b a \<and> (Lab b) = In)) ) \<Longrightarrow> completeLab\<^sup>\<A> att Lab\<close>
    by (smt (verit, del_insts) Label.distinct(3) Label.distinct(5) admissibleLab_def completeLab_def inset_def legallyIn_def legallyOut_def legallyUndec_def outset_def undecset_def)
qed

(*********************************** Grounded and Preferred ********************************)

(* the two provided definitions of grounded labellings are equivalent *)
lemma grounded_defEq: \<open>groundedLab\<^sup>\<A> att Lab \<longleftrightarrow> groundedLab2\<^sup>\<A> att Lab\<close>
  unfolding groundedLab_def groundedLab2_def
  by (smt (verit) Lab2Ext_def complete_LE grounded_LE groundedLab_def groundedExt2_def groundedExt_defEq1 id_apply least_rel_def minimal_rel_def)

(* grounded labellings always exist *)
lemma \<open>\<exists>Lab. groundedLab\<^sup>\<A> att Lab\<close> oops (*TODO*)

(* Side comment from [BCG2011] that grounded labellings are unique *)
lemma grounded_unique: \<open>groundedLab\<^sup>\<A> att Lab1 \<Longrightarrow> groundedLab\<^sup>\<A> att Lab2 \<Longrightarrow> \<forall>x. \<A> x \<longrightarrow> Lab1(x) = Lab2(x)\<close>
  unfolding grounded_defEq least_rel_def
  by (smt (verit, del_insts) completeLabInLab groundedLab2_def least_rel_def)

(* preferred labellings always exist *)
lemma \<open>\<exists>Lab. preferredLab\<^sup>\<A> att Lab\<close> oops (*TODO*)

(************TODO **************)

(*Prop 8 from [BCG2011]
 For complete labellings, being maximal/greatest wrt In is equivalent to being maximal/greatest wrt Out*)
lemma prop8: \<open>maximal\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab in \<longleftrightarrow> maximal\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab out\<close> unfolding maximal_rel_def
  by (smt (z3) complete_defEq completeLab2_def legallyIn_def legallyOut_def)

lemma prop8': \<open>greatest\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab in \<longleftrightarrow> greatest\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab out\<close> unfolding greatest_rel_def
  by (smt (z3) complete_defEq completeLab2_def legallyIn_def legallyOut_def)

(* In fact, being greatest wrt In implies being least wrt Undec, but not the other way round*)
lemma \<open>greatest\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab in \<longrightarrow> least\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab undec\<close> unfolding greatest_rel_def least_rel_def
  by (smt (z3) admissibleLabLegUndec completeLab_def completeLab2_def complete_defEq legallyOut_def legallyUndec_def)

lemma \<open>least\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab undec \<longrightarrow> greatest\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab in\<close>  oops

(* Moreover, being minimal wrt Undec implies being maximal wrt In, but not the other way round (cf. semi-stable labellings)*)
lemma \<open>minimal\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab undec \<longrightarrow> maximal\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab in\<close> unfolding minimal_rel_def maximal_rel_def
  by (smt (verit, ccfv_SIG) Label.exhaust complete_defEq completeLab2_def inset_def legallyOut_def outset_def undecset_def)

lemma \<open>maximal\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab in \<longrightarrow> minimal\<^sup>\<A> (completeLab\<^sup>\<A> att) Lab undec\<close>  oops

(* Prop. 10 from [BCG2011]
 If no argument is labelled Undec then the notions of conflict-free, admissible, complete and preferred collapse *)
lemma prop10_1to2: \<open>\<forall>x. Lab(x) \<noteq> Undec \<Longrightarrow> conflictfreeLab\<^sup>\<A> att Lab \<longrightarrow> admissibleLab\<^sup>\<A> att Lab\<close>
  by (smt (verit, ccfv_threshold) Label.exhaust inset_def admissibleLab_def conflictfreeLab_def legallyIn_def legallyOut_def outset_def)
lemma prop10_2to3: \<open>\<forall>x. Lab(x) \<noteq> Undec \<Longrightarrow> admissibleLab\<^sup>\<A> att Lab \<longrightarrow> completeLab\<^sup>\<A> att Lab\<close>
  by (simp add: completeLab_def undecset_def)
lemma prop10_3to4: \<open>\<forall>x. Lab(x) \<noteq> Undec \<Longrightarrow> completeLab\<^sup>\<A> att Lab \<longrightarrow>  preferredLab\<^sup>\<A> att Lab\<close> unfolding preferredLab_def maximal_rel_def
  by (smt (verit, ccfv_SIG) Label.exhaust completeLab2_def complete_defEq inset_def legallyOut_def outset_def)
lemma prop10_4to1: \<open>\<forall>x. Lab(x) \<noteq> Undec \<Longrightarrow> preferredLab\<^sup>\<A> att Lab \<longrightarrow> conflictfreeLab\<^sup>\<A> att Lab\<close>
  by (simp add: preferredLab_def admissibleLabConflictfree completeLab_def maximal_rel_def)

(***************************** Ideal ************************)

(************************************* Stable, semi-stable and stage ************************)

(* the (nonempty) AF in which every arguments attacks itself does not have a stable labelling *)
lemma stableLem01: \<open>\<exists>x. \<A> x \<longrightarrow> (\<forall>Lab. \<not>stableLab\<^sup>\<A> (\<lambda>x y. x = y) Lab)\<close>
  unfolding stableLab_def completeLab_def by (metis (full_types) Label.exhaust admissibleLabConflictfree completeLab2_def completeLab_def complete_defEq conflictfreeLab_def inset_def legallyIn_def outset_def)

(* stable labellings do not exist necessarily *)
corollary \<open>\<exists>x. \<A> x \<longrightarrow> (\<exists>att. \<forall>Lab. \<not>stableLab\<^sup>\<A> att Lab)\<close> using stableLem01 by auto

(*Lemma 14 from Dung. S is a stable extension iff S = {A | A is not attacked by S}.
Adapted to Labelings: It's weaker as we have to deal with Undec as well. *)
lemma lem14Dung: "stableLab\<^sup>\<A> att Lab \<longrightarrow> (\<forall>a. \<A> a \<longrightarrow> (in(Lab) a \<longleftrightarrow> \<not>(\<exists>b. \<A> b \<and> in(Lab) b \<and> att b a)))" unfolding stableLab_def complete_defEq
  by (metis (full_types) Label.distinct(1) Label.exhaust completeLab2_def inset_def legallyOut_def outset_def)

(*Lemma 15 from Dung. Every stable extension is a preferred extension, but not vice versa.
Adapted to Labellings *)
lemma lem15Dung: \<open>stableLab\<^sup>\<A> att Lab \<Longrightarrow> preferredLab\<^sup>\<A> att Lab\<close>
  by (smt (verit, ccfv_SIG) completeLabAdmissible Lab2Ext_def admissibleLabConflictfree conflictfreeExt_def conflictfree_LE preferredLab_def stableLab_def lem14Dung maximal_rel_def)

lemma \<open>preferredLab\<^sup>\<A> att Lab \<Longrightarrow> stableLab\<^sup>\<A> att Lab\<close>  oops

(* semistable labellings always exist *)
lemma \<open>\<exists>Lab. semistableLab\<^sup>\<A> att Lab\<close> oops (*TODO*)

end


subsection\<open>Pedersen Commitment Scheme\<close>

text\<open>The Pedersen commitment scheme \cite{BLP:conf/crypto/Pedersen91} is a commitment scheme based on a cyclic group. We use the
construction of cyclic groups from CryptHOL to formalise the commitment scheme. We prove perfect hiding
and computational binding, with a reduction to the discrete log problem. We a proof of the Pedersen commitment scheme
is realised in the instantiation of the Schnorr \<open>\<Sigma>\<close>-protocol with the general construction of commitment schemes
from \<open>\<Sigma>\<close>-protocols. The commitment scheme that is realised there however take the inverse of the message in the commitment
phase due to the construction of the simulator in the \<open>\<Sigma>\<close>-protocol proof. The two schemes are in some way equal however
as we do not have a well defined notion of equality for commitment schemes we keep this section of the formalisation. This
also serves as reference to the formal proof of the Pedersen commitment scheme we provide in \cite{DBLP:conf/post/ButlerAG19}.\<close>

theory Pedersen imports
  Commitment_Schemes
  "HOL-Number_Theory.Cong"
  Cyclic_Group_Ext
  Discrete_Log
  Number_Theory_Aux
  Uniform_Sampling
begin

locale pedersen_base =
  fixes \<G> :: "'grp cyclic_group" (structure)
  assumes prime_order: "prime (order \<G>)"
begin

lemma order_gt_0 [simp]: "order \<G> > 0"
  by (simp add: prime_gt_0_nat prime_order)

type_synonym 'grp' ck = "'grp'"
type_synonym 'grp' vk = "'grp'"
type_synonym plain = "nat"
type_synonym 'grp' commit = "'grp'"
type_synonym opening = "nat"

definition key_gen :: "('grp ck \<times> 'grp vk) spmf"
where
  "key_gen = do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    let h = \<^bold>g [^] x;
    return_spmf (h, h)
  }"

definition commit :: "'grp ck \<Rightarrow> plain \<Rightarrow> ('grp commit \<times> opening) spmf"
where
  "commit ck m = do {
    d :: nat \<leftarrow> sample_uniform (order \<G>);
    let c = (\<^bold>g [^] d) \<otimes> (ck [^] m);
    return_spmf (c,d)
  }"

definition commit_inv :: "'grp ck \<Rightarrow> plain \<Rightarrow> ('grp commit \<times> opening) spmf"
where
  "commit_inv ck m = do {
    d :: nat \<leftarrow> sample_uniform (order \<G>);
    let c = (\<^bold>g [^] d) \<otimes> (inv ck [^] m);
    return_spmf (c,d)
  }"

definition verify :: "'grp vk \<Rightarrow> plain \<Rightarrow> 'grp commit \<Rightarrow> opening \<Rightarrow> bool"
where
  "verify v_key m c d = (c = (\<^bold>g [^] d \<otimes>  v_key [^] m))"

definition valid_msg :: "plain \<Rightarrow> bool"
  where "valid_msg msg \<equiv> (msg < order \<G>)"

definition dis_log_\ :: "('grp ck, plain, 'grp commit, opening) bind_adversary \<Rightarrow> 'grp ck \<Rightarrow> nat spmf"
where "dis_log_\ \ h = do {
  (c, m, d, m', d') \<leftarrow> \ h;
  _ :: unit \<leftarrow> assert_spmf (m \<noteq> m'  \<and> valid_msg m \<and> valid_msg m');
  _ :: unit \<leftarrow> assert_spmf (c = \<^bold>g [^] d \<otimes> h [^] m \<and> c = \<^bold>g [^] d' \<otimes> h [^] m');
  return_spmf  (if (m > m') then (nat ((int d' - int d) * inverse (m - m') (order \<G>) mod order \<G>)) else
                  (nat ((int d - int d') * inverse (m' - m) (order \<G>) mod order \<G>)))}"

sublocale ped_commit: abstract_commitment key_gen commit verify valid_msg .

sublocale discrete_log: dis_log _
  unfolding dis_log_def by(simp)

end

locale pedersen = pedersen_base + cyclic_group \<G>
begin

lemma mod_one_cancel: assumes "[int y * z * x = y' * x] (mod order \<G>)" and "[z * x = 1] (mod order \<G>)"
  shows "[int y = y' * x] (mod order \<G>)"
  by (metis assms Groups.mult_ac(2) cong_scalar_right cong_sym_eq cong_trans more_arith_simps(11) more_arith_simps(5))

lemma dis_log_break:
  fixes d d' m m' :: nat
  assumes c: " \<^bold>g [^] d' \<otimes> (\<^bold>g [^] y) [^] m' = \<^bold>g [^] d \<otimes> (\<^bold>g [^] y) [^] m"
    and y_less_order: "y < order \<G>"
    and m_ge_m': "m > m'"
    and m: "m < order \<G>"
  shows "y = nat ((int d' - int d) * (fst (bezw ((m - m')) (order \<G>))) mod order \<G>)"
proof -
  have mm': "\<not> [m = m'] (mod order \<G>)"
    using m m_ge_m' basic_trans_rules(19) cong_less_modulus_unique_nat by blast
  hence gcd: "int (gcd ((m - m')) (order \<G>)) = 1"
    using assms(3) assms(4) prime_field prime_order by auto
  have "\<^bold>g [^] (d + y * m) = \<^bold>g [^] (d' + y * m')"
    using c by (simp add: nat_pow_mult nat_pow_pow)
  hence "[d + y * m = d' + y * m'] (mod order \<G>)"
    by(simp add: pow_generator_eq_iff_cong finite_carrier)
  hence "[int d + int y * int m = int d' + int y * int m'] (mod order \<G>)"
    using cong_int_iff by force
  from cong_diff[OF this cong_refl, of "int d + int y * int m'"]
  have "[int y * int (m - m') = int d' - int d] (mod order \<G>)" using m_ge_m'
    by(simp add: int_distrib of_nat_diff)
  hence *: "[int y * int (m - m') * (fst (bezw ((m - m')) (order \<G>))) = (int d' - int d) * (fst (bezw ((m - m')) (order \<G>)))] (mod order \<G>)"
    by (simp add: cong_scalar_right)
  hence "[int y * (int (m - m') * (fst (bezw ((m - m')) (order \<G>)))) = (int d' - int d) * (fst (bezw ((m - m')) (order \<G>)))] (mod order \<G>)"
    by (simp add: more_arith_simps(11))
  hence "[int y * 1 = (int d' - int d) * (fst (bezw ((m - m')) (order \<G>)))] (mod order \<G>)"
    using inverse gcd
    by (smt Groups.mult_ac(2) Number_Theory_Aux.inverse Totient.of_nat_eq_1_iff * cong_def int_ops(9) mod_mult_right_eq mod_one_cancel)
  hence "[int y = (int d' - int d) * (fst (bezw ((m - m')) (order \<G>)))] (mod order \<G>)" by simp
  hence "y mod order \<G> = (int d' - int d) * (fst (bezw ((m - m')) (order \<G>))) mod order \<G>"
    using cong_def zmod_int by auto
  thus ?thesis using y_less_order by simp
qed

lemma dis_log_break':
  assumes "y < order \<G>"
    and "\<not> m' < m"
    and "m \<noteq> m'"
    and m: "m' < order \<G>"
    and "\<^bold>g [^] d \<otimes> (\<^bold>g [^] y) [^] m = \<^bold>g [^] d' \<otimes> (\<^bold>g [^] y) [^] m'"
  shows "y = nat ((int d - int d') * fst (bezw ((m' - m)) (order \<G>)) mod int (order \<G>))"
proof-
  have "m' > m" using assms
    using group_eq_pow_eq_mod nat_neq_iff order_gt_0  by blast
  thus ?thesis
    using dis_log_break[of d y m d' m' ]assms cong_sym_eq assms by blast
qed

lemma set_spmf_samp_uni [simp]: "set_spmf (sample_uniform (order \<G>)) = {x. x < order \<G>}"
  by(auto simp add: sample_uniform_def)

lemma correct:
  shows "spmf (ped_commit.correct_game m) True  = 1"
  using finite_carrier order_gt_0_iff_finite
  apply(simp add: abstract_commitment.correct_game_def Let_def commit_def verify_def)
    by(simp add: key_gen_def Let_def bind_spmf_const cong: bind_spmf_cong_simp)

theorem abstract_correct:
  shows "ped_commit.correct"
  unfolding abstract_commitment.correct_def using correct by simp

lemma perfect_hiding:
  shows "spmf (ped_commit.hiding_game_ind_cpa \) True - 1/2 = 0"
  including monad_normalisation
proof -
  obtain \1 \2 where [simp]: "\ = (\1, \2)" by(cases \)
  note [simp] = Let_def split_def
  have "ped_commit.hiding_game_ind_cpa (\1, \2) = TRY do {
    (ck,vk) \<leftarrow> key_gen;
    ((m0, m1), \<sigma>) \<leftarrow> \1 vk;
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    b \<leftarrow> coin_spmf;
    (c,d) \<leftarrow> commit ck (if b then m0 else m1);
    b' \<leftarrow> \2 c \<sigma>;
    return_spmf (b' = b)} ELSE coin_spmf"
      by(simp add: abstract_commitment.hiding_game_ind_cpa_def)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    let h = \<^bold>g [^] x;
    ((m0, m1), \<sigma>) \<leftarrow> \1 h;
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
     b \<leftarrow> coin_spmf;
    d :: nat \<leftarrow> sample_uniform (order \<G>);
    let c = ((\<^bold>g [^] d) \<otimes> (h [^] (if b then m0 else m1)));
    b' \<leftarrow> \2 c \<sigma>;
    return_spmf (b' = b)} ELSE coin_spmf"
      by(simp add: commit_def key_gen_def)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    let h = (\<^bold>g [^] x);
    ((m0, m1), \<sigma>) \<leftarrow> \1 h;
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    b \<leftarrow> coin_spmf;
    z \<leftarrow> map_spmf (\<lambda>z.  \<^bold>g [^] z \<otimes> (h [^] (if b then m0 else m1))) (sample_uniform (order \<G>));
    guess :: bool \<leftarrow> \2 z \<sigma>;
    return_spmf(guess = b)} ELSE coin_spmf"
      by(simp add: bind_map_spmf o_def)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    let h = (\<^bold>g [^] x);
    ((m0, m1), \<sigma>) \<leftarrow> \1 h;
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    b \<leftarrow> coin_spmf;
    z \<leftarrow> map_spmf (\<lambda>z. \<^bold>g [^] z) (sample_uniform (order \<G>));
    guess :: bool \<leftarrow> \2 z \<sigma>;
    return_spmf(guess = b)} ELSE coin_spmf"
    by(simp add: sample_uniform_one_time_pad)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    let h = (\<^bold>g [^] x);
    ((m0, m1), \<sigma>) \<leftarrow> \1 h;
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    z \<leftarrow> map_spmf (\<lambda>z.  \<^bold>g [^] z)  (sample_uniform (order \<G>));
    guess :: bool \<leftarrow> \2 z \<sigma>;
    map_spmf((=) guess) coin_spmf} ELSE coin_spmf"
      by(simp add: map_spmf_conv_bind_spmf)
  also have "... = coin_spmf"
     by(auto simp add: bind_spmf_const map_eq_const_coin_spmf try_bind_spmf_lossless2' scale_bind_spmf weight_spmf_le_1 scale_scale_spmf)
  ultimately show ?thesis by(simp add: spmf_of_set)
qed

theorem abstract_perfect_hiding:
  shows "ped_commit.perfect_hiding_ind_cpa \"
proof-
  have "spmf (ped_commit.hiding_game_ind_cpa \) True - 1/2 = 0"
    using perfect_hiding by fastforce
  thus ?thesis
    by(simp add: abstract_commitment.perfect_hiding_ind_cpa_def abstract_commitment.hiding_advantage_ind_cpa_def)
qed

lemma bind_output_cong:
  assumes "x < order \<G>"
  shows "(x = nat ((int b - int ab) * fst (bezw (aa - ac) (order \<G>)) mod int (order \<G>)))
            \<longleftrightarrow> [x = nat ((int b - int ab) * fst (bezw (aa - ac) (order \<G>)) mod int (order \<G>))] (mod order \<G>)"
  using assms cong_less_modulus_unique_nat nat_less_iff by auto

lemma bind_game_eq_dis_log:
  shows "ped_commit.bind_game \ = discrete_log.dis_log (dis_log_\ \)"
proof-
  note [simp] = Let_def split_def
  have "ped_commit.bind_game \ = TRY do {
    (ck,vk) \<leftarrow> key_gen;
    (c, m, d, m', d') \<leftarrow> \ ck;
    _ :: unit \<leftarrow> assert_spmf(m \<noteq> m' \<and> valid_msg m \<and> valid_msg m');
    let b = verify vk m c d;
    let b' = verify vk m' c d';
    _ :: unit \<leftarrow> assert_spmf (b \<and> b');
    return_spmf True} ELSE return_spmf False"
    by(simp add: abstract_commitment.bind_game_alt_def)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (Coset.order \<G>);
    (c, m, d, m', d') \<leftarrow> \ (\<^bold>g [^] x);
    _ :: unit \<leftarrow> assert_spmf (m \<noteq> m' \<and> valid_msg m \<and> valid_msg m');
    _ :: unit \<leftarrow> assert_spmf (c = \<^bold>g [^] d \<otimes>  (\<^bold>g [^] x) [^] m \<and> c = \<^bold>g [^] d' \<otimes> (\<^bold>g [^] x) [^] m');
    return_spmf True} ELSE return_spmf False"
    by(simp add: verify_def key_gen_def)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    (c, m, d, m', d') \<leftarrow> \ (\<^bold>g [^] x);
    _ :: unit \<leftarrow> assert_spmf (m \<noteq> m' \<and> valid_msg m \<and> valid_msg m');
    _ :: unit \<leftarrow> assert_spmf (c = \<^bold>g [^] d \<otimes>  (\<^bold>g [^] x) [^] m \<and> c = \<^bold>g [^] d' \<otimes> (\<^bold>g [^] x) [^] m');
    return_spmf (x = (if (m > m') then (nat ((int d' - int d) * (fst (bezw ((m - m')) (order \<G>))) mod order \<G>)) else
                  (nat ((int d - int d') * (fst (bezw ((m' - m)) (order \<G>))) mod order \<G>))))} ELSE return_spmf False"
    apply(intro try_spmf_cong bind_spmf_cong[OF refl]; clarsimp?)
     apply(auto simp add: valid_msg_def)
     apply(intro bind_spmf_cong[OF refl]; clarsimp?)+
     apply(simp add: dis_log_break)
    apply(intro bind_spmf_cong[OF refl]; clarsimp?)+
    by(simp add: dis_log_break')
  ultimately show ?thesis
    apply(simp add: discrete_log.dis_log_def dis_log_\_def cong: bind_spmf_cong_simp)
    apply(intro try_spmf_cong bind_spmf_cong[OF refl]; clarsimp?)+
    using bind_output_cong by auto
qed

theorem pedersen_bind: "ped_commit.bind_advantage \ = discrete_log.advantage (dis_log_\ \)"
  unfolding abstract_commitment.bind_advantage_def discrete_log.advantage_def
  using bind_game_eq_dis_log by simp

end

locale pedersen_asymp =
  fixes \<G> :: "nat \<Rightarrow> 'grp cyclic_group"
  assumes pedersen: "\<And>\<eta>. pedersen (\<G> \<eta>)"
begin

sublocale pedersen "\<G> \<eta>" for \<eta> by(simp add: pedersen)

theorem pedersen_correct_asym:
 shows "ped_commit.correct n"
  using abstract_correct by simp

theorem pedersen_perfect_hiding_asym:
  shows "ped_commit.perfect_hiding_ind_cpa n (\ n)"
    by (simp add: abstract_perfect_hiding)

theorem pedersen_bind_asym:
  shows "negligible (\<lambda> n. ped_commit.bind_advantage n (\ n))
            \<longleftrightarrow> negligible (\<lambda> n. discrete_log.advantage n (dis_log_\ n (\ n)))"
  by(simp add: pedersen_bind)

end

end


(*  Title:      HOL/ex/CTL.thy
    Author:     Gertrud Bauer
*)

section {* CTL formulae *}

theory CTL
imports Main
begin

text {*
  We formalize basic concepts of Computational Tree Logic (CTL)
  @{cite "McMillan-PhDThesis" and "McMillan-LectureNotes"} within the
  simply-typed set theory of HOL.

  By using the common technique of ``shallow embedding'', a CTL
  formula is identified with the corresponding set of states where it
  holds.  Consequently, CTL operations such as negation, conjunction,
  disjunction simply become complement, intersection, union of sets.
  We only require a separate operation for implication, as point-wise
  inclusion is usually not encountered in plain set-theory.
*}

lemmas [intro!] = Int_greatest Un_upper2 Un_upper1 Int_lower1 Int_lower2

type_synonym 'a ctl = "'a set"

definition
  imp :: "'a ctl \<Rightarrow> 'a ctl \<Rightarrow> 'a ctl"    (infixr "\<rightarrow>" 75) where
  "p \<rightarrow> q = - p \<union> q"

lemma [intro!]: "p \<inter> p \<rightarrow> q \<subseteq> q" unfolding imp_def by auto
lemma [intro!]: "p \<subseteq> (q \<rightarrow> p)" unfolding imp_def by rule

text {*
  \smallskip The CTL path operators are more interesting; they are
  based on an arbitrary, but fixed model @{text \<M>}, which is simply
  a transition relation over states @{typ "'a"}.
*}

axiomatization \<M> :: "('a \<times> 'a) set"

text {*
  The operators @{text \<EX>}, @{text \<EF>}, @{text \<EG>} are taken
  as primitives, while @{text \<AX>}, @{text \<AF>}, @{text \<AG>} are
  defined as derived ones.  The formula @{text "\<EX> p"} holds in a
  state @{term s}, iff there is a successor state @{term s'} (with
  respect to the model @{term \<M>}), such that @{term p} holds in
  @{term s'}.  The formula @{text "\<EF> p"} holds in a state @{term
  s}, iff there is a path in @{text \<M>}, starting from @{term s},
  such that there exists a state @{term s'} on the path, such that
  @{term p} holds in @{term s'}.  The formula @{text "\<EG> p"} holds
  in a state @{term s}, iff there is a path, starting from @{term s},
  such that for all states @{term s'} on the path, @{term p} holds in
  @{term s'}.  It is easy to see that @{text "\<EF> p"} and @{text
  "\<EG> p"} may be expressed using least and greatest fixed points
  @{cite "McMillan-PhDThesis"}.
*}

definition
  EX  ("\<EX> _" [80] 90) where "\<EX> p = {s. \<exists>s'. (s, s') \<in> \<M> \<and> s' \<in> p}"
definition
  EF ("\<EF> _" [80] 90)  where "\<EF> p = lfp (\<lambda>s. p \<union> \<EX> s)"
definition
  EG ("\<EG> _" [80] 90)  where "\<EG> p = gfp (\<lambda>s. p \<inter> \<EX> s)"

text {*
  @{text "\<AX>"}, @{text "\<AF>"} and @{text "\<AG>"} are now defined
  dually in terms of @{text "\<EX>"}, @{text "\<EF>"} and @{text
  "\<EG>"}.
*}

definition
  AX  ("\<AX> _" [80] 90) where "\<AX> p = - \<EX> - p"
definition
  AF  ("\<AF> _" [80] 90) where "\<AF> p = - \<EG> - p"
definition
  AG  ("\<AG> _" [80] 90) where "\<AG> p = - \<EF> - p"

lemmas [simp] = EX_def EG_def AX_def EF_def AF_def AG_def

subsection {* Basic fixed point properties *}

text {*
  First of all, we use the de-Morgan property of fixed points
*}

lemma lfp_gfp: "lfp f = - gfp (\<lambda>s::'a set. - (f (- s)))"
proof
  show "lfp f \<subseteq> - gfp (\<lambda>s. - f (- s))"
  proof
    fix x assume l: "x \<in> lfp f"
    show "x \<in> - gfp (\<lambda>s. - f (- s))"
    proof
      assume "x \<in> gfp (\<lambda>s. - f (- s))"
      then obtain u where "x \<in> u" and "u \<subseteq> - f (- u)"
        by (auto simp add: gfp_def)
      then have "f (- u) \<subseteq> - u" by auto
      then have "lfp f \<subseteq> - u" by (rule lfp_lowerbound)
      from l and this have "x \<notin> u" by auto
      with `x \<in> u` show False by contradiction
    qed
  qed
  show "- gfp (\<lambda>s. - f (- s)) \<subseteq> lfp f"
  proof (rule lfp_greatest)
    fix u assume "f u \<subseteq> u"
    then have "- u \<subseteq> - f u" by auto
    then have "- u \<subseteq> - f (- (- u))" by simp
    then have "- u \<subseteq> gfp (\<lambda>s. - f (- s))" by (rule gfp_upperbound)
    then show "- gfp (\<lambda>s. - f (- s)) \<subseteq> u" by auto
  qed
qed

lemma lfp_gfp': "- lfp f = gfp (\<lambda>s::'a set. - (f (- s)))"
  by (simp add: lfp_gfp)

lemma gfp_lfp': "- gfp f = lfp (\<lambda>s::'a set. - (f (- s)))"
  by (simp add: lfp_gfp)

text {*
  in order to give dual fixed point representations of @{term "AF p"}
  and @{term "AG p"}:
*}

lemma AF_lfp: "\<AF> p = lfp (\<lambda>s. p \<union> \<AX> s)" by (simp add: lfp_gfp)
lemma AG_gfp: "\<AG> p = gfp (\<lambda>s. p \<inter> \<AX> s)" by (simp add: lfp_gfp)

lemma EF_fp: "\<EF> p = p \<union> \<EX> \<EF> p"
proof -
  have "mono (\<lambda>s. p \<union> \<EX> s)" by rule auto
  then show ?thesis by (simp only: EF_def) (rule lfp_unfold)
qed

lemma AF_fp: "\<AF> p = p \<union> \<AX> \<AF> p"
proof -
  have "mono (\<lambda>s. p \<union> \<AX> s)" by rule auto
  then show ?thesis by (simp only: AF_lfp) (rule lfp_unfold)
qed

lemma EG_fp: "\<EG> p = p \<inter> \<EX> \<EG> p"
proof -
  have "mono (\<lambda>s. p \<inter> \<EX> s)" by rule auto
  then show ?thesis by (simp only: EG_def) (rule gfp_unfold)
qed

text {*
  From the greatest fixed point definition of @{term "\<AG> p"}, we
  derive as a consequence of the Knaster-Tarski theorem on the one
  hand that @{term "\<AG> p"} is a fixed point of the monotonic
  function @{term "\<lambda>s. p \<inter> \<AX> s"}.
*}

lemma AG_fp: "\<AG> p = p \<inter> \<AX> \<AG> p"
proof -
  have "mono (\<lambda>s. p \<inter> \<AX> s)" by rule auto
  then show ?thesis by (simp only: AG_gfp) (rule gfp_unfold)
qed

text {*
  This fact may be split up into two inequalities (merely using
  transitivity of @{text "\<subseteq>" }, which is an instance of the overloaded
  @{text "\<le>"} in Isabelle/HOL).
*}

lemma AG_fp_1: "\<AG> p \<subseteq> p"
proof -
  note AG_fp also have "p \<inter> \<AX> \<AG> p \<subseteq> p" by auto
  finally show ?thesis .
qed

lemma AG_fp_2: "\<AG> p \<subseteq> \<AX> \<AG> p"
proof -
  note AG_fp also have "p \<inter> \<AX> \<AG> p \<subseteq> \<AX> \<AG> p" by auto
  finally show ?thesis .
qed

text {*
  On the other hand, we have from the Knaster-Tarski fixed point
  theorem that any other post-fixed point of @{term "\<lambda>s. p \<inter> AX s"} is
  smaller than @{term "AG p"}.  A post-fixed point is a set of states
  @{term q} such that @{term "q \<subseteq> p \<inter> AX q"}.  This leads to the
  following co-induction principle for @{term "AG p"}.
*}

lemma AG_I: "q \<subseteq> p \<inter> \<AX> q \<Longrightarrow> q \<subseteq> \<AG> p"
  by (simp only: AG_gfp) (rule gfp_upperbound)

subsection {* The tree induction principle \label{sec:calc-ctl-tree-induct} *}

text {*
  With the most basic facts available, we are now able to establish a
  few more interesting results, leading to the \emph{tree induction}
  principle for @{text AG} (see below).  We will use some elementary
  monotonicity and distributivity rules.
*}

lemma AX_int: "\<AX> (p \<inter> q) = \<AX> p \<inter> \<AX> q" by auto
lemma AX_mono: "p \<subseteq> q \<Longrightarrow> \<AX> p \<subseteq> \<AX> q" by auto
lemma AG_mono: "p \<subseteq> q \<Longrightarrow> \<AG> p \<subseteq> \<AG> q"
  by (simp only: AG_gfp, rule gfp_mono) auto

text {*
  The formula @{term "AG p"} implies @{term "AX p"} (we use
  substitution of @{text "\<subseteq>"} with monotonicity).
*}

lemma AG_AX: "\<AG> p \<subseteq> \<AX> p"
proof -
  have "\<AG> p \<subseteq> \<AX> \<AG> p" by (rule AG_fp_2)
  also have "\<AG> p \<subseteq> p" by (rule AG_fp_1) moreover note AX_mono
  finally show ?thesis .
qed

text {*
  Furthermore we show idempotency of the @{text "\<AG>"} operator.
  The proof is a good example of how accumulated facts may get
  used to feed a single rule step.
*}

lemma AG_AG: "\<AG> \<AG> p = \<AG> p"
proof
  show "\<AG> \<AG> p \<subseteq> \<AG> p" by (rule AG_fp_1)
next
  show "\<AG> p \<subseteq> \<AG> \<AG> p"
  proof (rule AG_I)
    have "\<AG> p \<subseteq> \<AG> p" ..
    moreover have "\<AG> p \<subseteq> \<AX> \<AG> p" by (rule AG_fp_2)
    ultimately show "\<AG> p \<subseteq> \<AG> p \<inter> \<AX> \<AG> p" ..
  qed
qed

text {*
  \smallskip We now give an alternative characterization of the @{text
  "\<AG>"} operator, which describes the @{text "\<AG>"} operator in
  an ``operational'' way by tree induction: In a state holds @{term
  "AG p"} iff in that state holds @{term p}, and in all reachable
  states @{term s} follows from the fact that @{term p} holds in
  @{term s}, that @{term p} also holds in all successor states of
  @{term s}.  We use the co-induction principle @{thm [source] AG_I}
  to establish this in a purely algebraic manner.
*}

theorem AG_induct: "p \<inter> \<AG> (p \<rightarrow> \<AX> p) = \<AG> p"
proof
  show "p \<inter> \<AG> (p \<rightarrow> \<AX> p) \<subseteq> \<AG> p"  (is "?lhs \<subseteq> _")
  proof (rule AG_I)
    show "?lhs \<subseteq> p \<inter> \<AX> ?lhs"
    proof
      show "?lhs \<subseteq> p" ..
      show "?lhs \<subseteq> \<AX> ?lhs"
      proof -
        {
          have "\<AG> (p \<rightarrow> \<AX> p) \<subseteq> p \<rightarrow> \<AX> p" by (rule AG_fp_1)
          also have "p \<inter> p \<rightarrow> \<AX> p \<subseteq> \<AX> p" ..
          finally have "?lhs \<subseteq> \<AX> p" by auto
        }
        moreover
        {
          have "p \<inter> \<AG> (p \<rightarrow> \<AX> p) \<subseteq> \<AG> (p \<rightarrow> \<AX> p)" ..
          also have "\<dots> \<subseteq> \<AX> \<dots>" by (rule AG_fp_2)
          finally have "?lhs \<subseteq> \<AX> \<AG> (p \<rightarrow> \<AX> p)" .
        }
        ultimately have "?lhs \<subseteq> \<AX> p \<inter> \<AX> \<AG> (p \<rightarrow> \<AX> p)" ..
        also have "\<dots> = \<AX> ?lhs" by (simp only: AX_int)
        finally show ?thesis .
      qed
    qed
  qed
next
  show "\<AG> p \<subseteq> p \<inter> \<AG> (p \<rightarrow> \<AX> p)"
  proof
    show "\<AG> p \<subseteq> p" by (rule AG_fp_1)
    show "\<AG> p \<subseteq> \<AG> (p \<rightarrow> \<AX> p)"
    proof -
      have "\<AG> p = \<AG> \<AG> p" by (simp only: AG_AG)
      also have "\<AG> p \<subseteq> \<AX> p" by (rule AG_AX) moreover note AG_mono
      also have "\<AX> p \<subseteq> (p \<rightarrow> \<AX> p)" .. moreover note AG_mono
      finally show ?thesis .
    qed
  qed
qed

subsection {* An application of tree induction \label{sec:calc-ctl-commute} *}

text {*
  Further interesting properties of CTL expressions may be
  demonstrated with the help of tree induction; here we show that
  @{text \<AX>} and @{text \<AG>} commute.
*}

theorem AG_AX_commute: "\<AG> \<AX> p = \<AX> \<AG> p"
proof -
  have "\<AG> \<AX> p = \<AX> p \<inter> \<AX> \<AG> \<AX> p" by (rule AG_fp)
  also have "\<dots> = \<AX> (p \<inter> \<AG> \<AX> p)" by (simp only: AX_int)
  also have "p \<inter> \<AG> \<AX> p = \<AG> p"  (is "?lhs = _")
  proof
    have "\<AX> p \<subseteq> p \<rightarrow> \<AX> p" ..
    also have "p \<inter> \<AG> (p \<rightarrow> \<AX> p) = \<AG> p" by (rule AG_induct)
    also note Int_mono AG_mono
    ultimately show "?lhs \<subseteq> \<AG> p" by fast
  next
    have "\<AG> p \<subseteq> p" by (rule AG_fp_1)
    moreover
    {
      have "\<AG> p = \<AG> \<AG> p" by (simp only: AG_AG)
      also have "\<AG> p \<subseteq> \<AX> p" by (rule AG_AX)
      also note AG_mono
      ultimately have "\<AG> p \<subseteq> \<AG> \<AX> p" .
    }
    ultimately show "\<AG> p \<subseteq> ?lhs" ..
  qed
  finally show ?thesis .
qed

end


(*  Title:      ZF/Induct/PropLog.thy
    Author:     Tobias Nipkow & Lawrence C Paulson
    Copyright   1993  University of Cambridge
*)

section \<open>Meta-theory of propositional logic\<close>

theory PropLog imports Main begin

text \<open>
  Datatype definition of propositional logic formulae and inductive
  definition of the propositional tautologies.

  Inductive definition of propositional logic.  Soundness and
  completeness w.r.t.\ truth-tables.

  Prove: If \<open>H |= p\<close> then \<open>G |= p\<close> where \<open>G \<in>
  Fin(H)\<close>
\<close>

subsection \<open>The datatype of propositions\<close>

consts
  propn :: i

datatype propn =
    Fls
  | Var ("n \<in> nat")    ("#_" [100] 100)
  | Imp ("p \<in> propn", "q \<in> propn")    (infixr "=>" 90)

subsection \<open>The proof system\<close>

consts thms     :: "i => i"

abbreviation
  thms_syntax :: "[i,i] => o"    (infixl "|-" 50)
  where "H |- p == p \<in> thms(H)"

inductive
  domains "thms(H)" \<subseteq> "propn"
  intros
    H:  "[| p \<in> H;  p \<in> propn |] ==> H |- p"
    K:  "[| p \<in> propn;  q \<in> propn |] ==> H |- p=>q=>p"
    S:  "[| p \<in> propn;  q \<in> propn;  r \<in> propn |]
         ==> H |- (p=>q=>r) => (p=>q) => p=>r"
    DN: "p \<in> propn ==> H |- ((p=>Fls) => Fls) => p"
    MP: "[| H |- p=>q;  H |- p;  p \<in> propn;  q \<in> propn |] ==> H |- q"
  type_intros "propn.intros"

declare propn.intros [simp]

subsection \<open>The semantics\<close>

subsubsection \<open>Semantics of propositional logic.\<close>

consts
  is_true_fun :: "[i,i] => i"
primrec
  "is_true_fun(Fls, t) = 0"
  "is_true_fun(Var(v), t) = (if v \<in> t then 1 else 0)"
  "is_true_fun(p=>q, t) = (if is_true_fun(p,t) = 1 then is_true_fun(q,t) else 1)"

definition
  is_true :: "[i,i] => o"  where
  "is_true(p,t) == is_true_fun(p,t) = 1"
  \<comment> \<open>this definition is required since predicates can't be recursive\<close>

lemma is_true_Fls [simp]: "is_true(Fls,t) \<longleftrightarrow> False"
  by (simp add: is_true_def)

lemma is_true_Var [simp]: "is_true(#v,t) \<longleftrightarrow> v \<in> t"
  by (simp add: is_true_def)

lemma is_true_Imp [simp]: "is_true(p=>q,t) \<longleftrightarrow> (is_true(p,t)\<longrightarrow>is_true(q,t))"
  by (simp add: is_true_def)

subsubsection \<open>Logical consequence\<close>

text \<open>
  For every valuation, if all elements of \<open>H\<close> are true then so
  is \<open>p\<close>.
\<close>

definition
  logcon :: "[i,i] => o"    (infixl "|=" 50)  where
  "H |= p == \<forall>t. (\<forall>q \<in> H. is_true(q,t)) \<longrightarrow> is_true(p,t)"

text \<open>
  A finite set of hypotheses from \<open>t\<close> and the \<open>Var\<close>s in
  \<open>p\<close>.
\<close>

consts
  hyps :: "[i,i] => i"
primrec
  "hyps(Fls, t) = 0"
  "hyps(Var(v), t) = (if v \<in> t then {#v} else {#v=>Fls})"
  "hyps(p=>q, t) = hyps(p,t) \<union> hyps(q,t)"

subsection \<open>Proof theory of propositional logic\<close>

lemma thms_mono: "G \<subseteq> H ==> thms(G) \<subseteq> thms(H)"
  apply (unfold thms.defs)
  apply (rule lfp_mono)
    apply (rule thms.bnd_mono)+
  apply (assumption | rule univ_mono basic_monos)+
  done

lemmas thms_in_pl = thms.dom_subset [THEN subsetD]

inductive_cases ImpE: "p=>q \<in> propn"

lemma thms_MP: "[| H |- p=>q;  H |- p |] ==> H |- q"
  \<comment> \<open>Stronger Modus Ponens rule: no typechecking!\<close>
  apply (rule thms.MP)
     apply (erule asm_rl thms_in_pl thms_in_pl [THEN ImpE])+
  done

lemma thms_I: "p \<in> propn ==> H |- p=>p"
  \<comment> \<open>Rule is called \<open>I\<close> for Identity Combinator, not for Introduction.\<close>
  apply (rule thms.S [THEN thms_MP, THEN thms_MP])
      apply (rule_tac [5] thms.K)
       apply (rule_tac [4] thms.K)
         apply simp_all
  done

subsubsection \<open>Weakening, left and right\<close>

lemma weaken_left: "[| G \<subseteq> H;  G|-p |] ==> H|-p"
  \<comment> \<open>Order of premises is convenient with \<open>THEN\<close>\<close>
  by (erule thms_mono [THEN subsetD])

lemma weaken_left_cons: "H |- p ==> cons(a,H) |- p"
  by (erule subset_consI [THEN weaken_left])

lemmas weaken_left_Un1  = Un_upper1 [THEN weaken_left]
lemmas weaken_left_Un2  = Un_upper2 [THEN weaken_left]

lemma weaken_right: "[| H |- q;  p \<in> propn |] ==> H |- p=>q"
  by (simp_all add: thms.K [THEN thms_MP] thms_in_pl)

subsubsection \<open>The deduction theorem\<close>

theorem deduction: "[| cons(p,H) |- q;  p \<in> propn |] ==>  H |- p=>q"
  apply (erule thms.induct)
      apply (blast intro: thms_I thms.H [THEN weaken_right])
     apply (blast intro: thms.K [THEN weaken_right])
    apply (blast intro: thms.S [THEN weaken_right])
   apply (blast intro: thms.DN [THEN weaken_right])
  apply (blast intro: thms.S [THEN thms_MP [THEN thms_MP]])
  done

subsubsection \<open>The cut rule\<close>

lemma cut: "[| H|-p;  cons(p,H) |- q |] ==>  H |- q"
  apply (rule deduction [THEN thms_MP])
    apply (simp_all add: thms_in_pl)
  done

lemma thms_FlsE: "[| H |- Fls; p \<in> propn |] ==> H |- p"
  apply (rule thms.DN [THEN thms_MP])
   apply (rule_tac [2] weaken_right)
    apply (simp_all add: propn.intros)
  done

lemma thms_notE: "[| H |- p=>Fls;  H |- p;  q \<in> propn |] ==> H |- q"
  by (erule thms_MP [THEN thms_FlsE])

subsubsection \<open>Soundness of the rules wrt truth-table semantics\<close>

theorem soundness: "H |- p ==> H |= p"
  apply (unfold logcon_def)
  apply (induct set: thms)
      apply auto
  done

subsection \<open>Completeness\<close>

subsubsection \<open>Towards the completeness proof\<close>

lemma Fls_Imp: "[| H |- p=>Fls; q \<in> propn |] ==> H |- p=>q"
  apply (frule thms_in_pl)
  apply (rule deduction)
   apply (rule weaken_left_cons [THEN thms_notE])
     apply (blast intro: thms.H elim: ImpE)+
  done

lemma Imp_Fls: "[| H |- p;  H |- q=>Fls |] ==> H |- (p=>q)=>Fls"
  apply (frule thms_in_pl)
  apply (frule thms_in_pl [of concl: "q=>Fls"])
  apply (rule deduction)
   apply (erule weaken_left_cons [THEN thms_MP])
   apply (rule consI1 [THEN thms.H, THEN thms_MP])
    apply (blast intro: weaken_left_cons elim: ImpE)+
  done

lemma hyps_thms_if:
    "p \<in> propn ==> hyps(p,t) |- (if is_true(p,t) then p else p=>Fls)"
  \<comment> \<open>Typical example of strengthening the induction statement.\<close>
  apply simp
  apply (induct_tac p)
    apply (simp_all add: thms_I thms.H)
  apply (safe elim!: Fls_Imp [THEN weaken_left_Un1] Fls_Imp [THEN weaken_left_Un2])
  apply (blast intro: weaken_left_Un1 weaken_left_Un2 weaken_right Imp_Fls)+
  done

lemma logcon_thms_p: "[| p \<in> propn;  0 |= p |] ==> hyps(p,t) |- p"
  \<comment> \<open>Key lemma for completeness; yields a set of assumptions satisfying \<open>p\<close>\<close>
  apply (drule hyps_thms_if)
  apply (simp add: logcon_def)
  done

text \<open>
  For proving certain theorems in our new propositional logic.
\<close>

lemmas propn_SIs = propn.intros deduction
  and propn_Is = thms_in_pl thms.H thms.H [THEN thms_MP]

text \<open>
  The excluded middle in the form of an elimination rule.
\<close>

lemma thms_excluded_middle:
    "[| p \<in> propn;  q \<in> propn |] ==> H |- (p=>q) => ((p=>Fls)=>q) => q"
  apply (rule deduction [THEN deduction])
    apply (rule thms.DN [THEN thms_MP])
     apply (best intro!: propn_SIs intro: propn_Is)+
  done

lemma thms_excluded_middle_rule:
  "[| cons(p,H) |- q;  cons(p=>Fls,H) |- q;  p \<in> propn |] ==> H |- q"
  \<comment> \<open>Hard to prove directly because it requires cuts\<close>
  apply (rule thms_excluded_middle [THEN thms_MP, THEN thms_MP])
     apply (blast intro!: propn_SIs intro: propn_Is)+
  done

subsubsection \<open>Completeness -- lemmas for reducing the set of assumptions\<close>

text \<open>
  For the case @{prop "hyps(p,t)-cons(#v,Y) |- p"} we also have @{prop
  "hyps(p,t)-{#v} \<subseteq> hyps(p, t-{v})"}.
\<close>

lemma hyps_Diff:
    "p \<in> propn ==> hyps(p, t-{v}) \<subseteq> cons(#v=>Fls, hyps(p,t)-{#v})"
  by (induct set: propn) auto

text \<open>
  For the case @{prop "hyps(p,t)-cons(#v => Fls,Y) |- p"} we also have
  @{prop "hyps(p,t)-{#v=>Fls} \<subseteq> hyps(p, cons(v,t))"}.
\<close>

lemma hyps_cons:
    "p \<in> propn ==> hyps(p, cons(v,t)) \<subseteq> cons(#v, hyps(p,t)-{#v=>Fls})"
  by (induct set: propn) auto

text \<open>Two lemmas for use with \<open>weaken_left\<close>\<close>

lemma cons_Diff_same: "B-C \<subseteq> cons(a, B-cons(a,C))"
  by blast

lemma cons_Diff_subset2: "cons(a, B-{c}) - D \<subseteq> cons(a, B-cons(c,D))"
  by blast

text \<open>
  The set @{term "hyps(p,t)"} is finite, and elements have the form
  @{term "#v"} or @{term "#v=>Fls"}; could probably prove the stronger
  @{prop "hyps(p,t) \<in> Fin(hyps(p,0) \<union> hyps(p,nat))"}.
\<close>

lemma hyps_finite: "p \<in> propn ==> hyps(p,t) \<in> Fin(\<Union>v \<in> nat. {#v, #v=>Fls})"
  by (induct set: propn) auto

lemmas Diff_weaken_left = Diff_mono [OF _ subset_refl, THEN weaken_left]

text \<open>
  Induction on the finite set of assumptions @{term "hyps(p,t0)"}.  We
  may repeatedly subtract assumptions until none are left!
\<close>

lemma completeness_0_lemma [rule_format]:
    "[| p \<in> propn;  0 |= p |] ==> \<forall>t. hyps(p,t) - hyps(p,t0) |- p"
  apply (frule hyps_finite)
  apply (erule Fin_induct)
   apply (simp add: logcon_thms_p Diff_0)
  txt \<open>inductive step\<close>
  apply safe
   txt \<open>Case @{prop "hyps(p,t)-cons(#v,Y) |- p"}\<close>
   apply (rule thms_excluded_middle_rule)
     apply (erule_tac [3] propn.intros)
    apply (blast intro: cons_Diff_same [THEN weaken_left])
   apply (blast intro: cons_Diff_subset2 [THEN weaken_left]
     hyps_Diff [THEN Diff_weaken_left])
  txt \<open>Case @{prop "hyps(p,t)-cons(#v => Fls,Y) |- p"}\<close>
  apply (rule thms_excluded_middle_rule)
    apply (erule_tac [3] propn.intros)
   apply (blast intro: cons_Diff_subset2 [THEN weaken_left]
     hyps_cons [THEN Diff_weaken_left])
  apply (blast intro: cons_Diff_same [THEN weaken_left])
  done

subsubsection \<open>Completeness theorem\<close>

lemma completeness_0: "[| p \<in> propn;  0 |= p |] ==> 0 |- p"
  \<comment> \<open>The base case for completeness\<close>
  apply (rule Diff_cancel [THEN subst])
  apply (blast intro: completeness_0_lemma)
  done

lemma logcon_Imp: "[| cons(p,H) |= q |] ==> H |= p=>q"
  \<comment> \<open>A semantic analogue of the Deduction Theorem\<close>
  by (simp add: logcon_def)

lemma completeness:
     "H \<in> Fin(propn) ==> p \<in> propn \<Longrightarrow> H |= p \<Longrightarrow> H |- p"
  apply (induct arbitrary: p set: Fin)
   apply (safe intro!: completeness_0)
  apply (rule weaken_left_cons [THEN thms_MP])
   apply (blast intro!: logcon_Imp propn.intros)
  apply (blast intro: propn_Is)
  done

theorem thms_iff: "H \<in> Fin(propn) ==> H |- p \<longleftrightarrow> H |= p \<and> p \<in> propn"
  by (blast intro: soundness completeness thms_in_pl)

end


theory exportation imports Main begin

text {*
  Proving the exportation rule in propositional calculus
*}

lemma "((P\<and>Q)\<longrightarrow>R) = (P\<longrightarrow>(Q\<longrightarrow>R))"
  apply(rule iffI)
   apply(rule impI)+
   apply(erule impE)
    apply(rule conjI)
     apply assumption+
  apply(rule impI)+
  apply(erule impE)
   apply (erule conjE)
   apply assumption
  apply(erule conjE)
  apply (erule impE)
   apply assumption+
  done


theory Concrete_Semantics_2_2_ex7
imports Main
begin

datatype 'a tree2 = Tip 'a | Node "'a tree2" 'a "'a tree2"

fun mirror :: "'a tree2 => 'a tree2" where
"mirror (Tip x) = Tip x" |
"mirror (Node l a r) = Node (mirror r) a (mirror l)"

(*Preorder <root> <left> <right>*)
fun pre_order :: "'a tree2 => 'a list" where
"pre_order (Tip x) = [x]" |
"pre_order (Node l a r) = [a] @ (pre_order l) @ (pre_order(r))"

(*Postorder <left> <right> <root>*)
fun post_order :: "'a tree2 => 'a list" where
"post_order (Tip x) = [x]" |
"post_order (Node l a r) = (post_order l) @ (post_order(r)) @ [a]"

(*
 1. \<And>t1 x2 t2.
       pre_order (mirror t1) = rev (post_order t1) \<Longrightarrow>
       pre_order (mirror t2) = rev (post_order t2) \<Longrightarrow>
       rev (post_order t2) @ x2 # rev (post_order t1) =
       rev (post_order t1) @ x2 # rev (post_order t2)
*)
lemma "pre_order (mirror t) = rev (post_order t)"
apply(induction t)
apply(auto)
done

end