section \<open>WS1S Interpretations\<close>

(*<*)
theory WS1S_Prelim
imports
  FSet_More
  Deriving.Compare_Instances
  "List-Index.List_Index"
begin

hide_const (open) cut
(*>*)

definition "eval P x = (x |\<in>| P)"
definition "downshift P = (\<lambda>x. x - Suc 0) |`| (P |-| {|0|})"
definition "upshift P = Suc |`| P"
definition "lift bs i P = (if bs ! i then finsert 0 (upshift P) else upshift P)"
definition "snoc n bs i P = (if bs ! i then finsert n P else P)"
definition "cut n P = ffilter (\<lambda>i. i < n) P"
definition "len P = (if P = {||} then 0 else Suc (fMax P))"

datatype order = FO | SO
derive linorder order
instantiation order :: enum begin
  definition "enum_order = [FO, SO]"
  definition "enum_all_order P = (P FO \<and> P SO)"
  definition "enum_ex_order P = (P FO \<or> P SO)"
  lemmas enum_defs = enum_order_def enum_all_order_def enum_ex_order_def
  instance proof qed (auto simp: enum_defs, (metis (full_types) order.exhaust)+)
end

typedef idx = "UNIV :: (nat \<times> nat) set" by (rule UNIV_witness)

setup_lifting type_definition_idx

lift_definition SUC :: "order \<Rightarrow> idx \<Rightarrow> idx" is
  "\<lambda>ord (m, n). case ord of FO \<Rightarrow> (Suc m, n) | SO \<Rightarrow> (m, Suc n)" .
lift_definition LESS :: "order \<Rightarrow> nat \<Rightarrow> idx \<Rightarrow> bool" is
  "\<lambda>ord l (m, n). case ord of FO \<Rightarrow> l < m | SO \<Rightarrow> l < n" .
abbreviation "LEQ ord l idx \<equiv> LESS ord l (SUC ord idx)"

definition "MSB Is \<equiv>
  if \<forall>P \<in> set Is. P = {||} then 0 else Suc (Max (\<Union>P \<in> set Is. fset P))"

lemma MSB_Nil[simp]: "MSB [] = 0"
  unfolding MSB_def by simp

lemma MSB_Cons[simp]: "MSB (I # Is) = max (if I = {||} then 0 else Suc (fMax I)) (MSB Is)"
  unfolding MSB_def including fset.lifting
  by transfer (auto simp: Max_Un list_all_iff Sup_bot_conv(2)[symmetric] simp del: Sup_bot_conv(2))

lemma MSB_append[simp]: "MSB (I1 @ I2) = max (MSB I1) (MSB I2)"
  by (induct I1) auto

lemma MSB_insert_nth[simp]:
  "MSB (insert_nth n P Is) = max (if P = {||} then 0 else Suc (fMax P)) (MSB Is)"
  by (subst (2) append_take_drop_id[of n Is, symmetric])
    (simp only: insert_nth_take_drop MSB_append MSB_Cons MSB_Nil)

lemma MSB_mono: "set I1 \<subseteq> set I2 \<Longrightarrow> MSB I1 \<le> MSB I2"
  unfolding MSB_def including fset.lifting
  by transfer (auto simp: list_all_iff intro!: Max_ge)

lemma MSB_map_index'_CONS[simp]:
  "MSB (map_index' i (lift bs) Is) =
  (if MSB Is = 0 \<and> (\<forall>i \<in> {i ..< i + length Is}. \<not> bs ! i) then 0 else Suc (MSB Is))"
  by (induct Is arbitrary: i)
   (auto split: if_splits simp: mono_fMax_commute[where f = Suc, symmetric] mono_def
    lift_def upshift_def,
    metis atLeastLessThan_iff le_antisym not_less_eq_eq)

lemma MSB_map_index'_SNOC[simp]:
  "MSB Is \<le> n \<Longrightarrow> MSB (map_index' i (snoc n bs) Is) =
  (if (\<forall>i \<in> {i ..< i + length Is}. \<not> bs ! i) then MSB Is else Suc n)"
  by (induct Is arbitrary: i)
    (auto split: if_splits simp: mono_fMax_commute[where f = Suc, symmetric] mono_def
    snoc_def, (metis atLeastLessThan_iff le_antisym not_less_eq_eq)+)

lemma MSB_replicate[simp]: "MSB (replicate n P) = (if P = {||} \<or> n = 0 then 0 else Suc (fMax P))"
  by (induct n) auto

typedef interp =
  "{(n :: nat, I1 :: nat fset list, I2  :: nat fset list) | n I1 I2. MSB (I1 @ I2) \<le> n}"
  by auto

setup_lifting type_definition_interp

lift_definition assigns :: "nat \<Rightarrow> interp \<Rightarrow> order \<Rightarrow> nat fset" ("_\<^bsup>_\<^esup>_" [900, 999, 999] 999)
  is "\<lambda>n (_, I1, I2) ord. case ord of FO \<Rightarrow> if n < length I1 then I1 ! n else {||}
    | SO \<Rightarrow> if n < length I2 then I2 ! n else {||}" .
lift_definition nvars :: "interp \<Rightarrow> idx" ("#\<^sub>V _" [1000] 900)
  is "\<lambda>(_, I1, I2). (length I1, length I2)" .
lift_definition Length :: "interp \<Rightarrow> nat"
  is "\<lambda>(n, _, _). n" .
lift_definition Extend :: "order \<Rightarrow> nat \<Rightarrow> interp \<Rightarrow> nat fset \<Rightarrow> interp"
  is "\<lambda>ord i (n, I1, I2) P. case ord of
      FO \<Rightarrow> (max n (if P = {||} then 0 else Suc (fMax P)), insert_nth i P I1, I2)
    | SO \<Rightarrow> (max n (if P = {||} then 0 else Suc (fMax P)), I1, insert_nth i P I2)"
  using MSB_mono by (auto simp del: insert_nth_take_drop split: order.splits)

lift_definition CONS :: "(bool list \<times> bool list) \<Rightarrow> interp \<Rightarrow> interp"
  is "\<lambda>(bs1, bs2) (n, I1, I2).
   (Suc n, map_index (lift bs1) I1, map_index (lift bs2) I2)"
  by auto

lift_definition SNOC :: "(bool list \<times> bool list) \<Rightarrow> interp \<Rightarrow> interp"
  is "\<lambda>(bs1, bs2) (n, I1, I2).
   (Suc n, map_index (snoc n bs1) I1, map_index (snoc n bs2) I2)"
  by (auto simp: Let_def)

type_synonym atom = "bool list \<times> bool list"

lift_definition zero :: "idx \<Rightarrow> atom"
  is "\<lambda>(m, n). (replicate m False, replicate n False)" .

definition "extend ord b \<equiv>
  \<lambda>(bs1, bs2). case ord of FO \<Rightarrow> (b # bs1, bs2) | SO \<Rightarrow> (bs1, b # bs2)"
lift_definition size_atom :: "bool list \<times> bool list \<Rightarrow> idx"
  is "\<lambda>(bs1, bs2). (length bs1, length bs2)" .

lift_definition \<sigma> :: "idx \<Rightarrow> atom list"
  is "(\<lambda>(n, N). map (\<lambda>bs. (take n bs, drop n bs)) (List.n_lists (n + N) [True, False]))" .

lemma fMin_fimage_Suc[simp]: "x |\<in>| A \<Longrightarrow> fMin (Suc |`| A) = Suc (fMin A)"
  by (rule fMin_eqI) (auto intro: fMin_in)

lemma fMin_eq_0[simp]: "0 |\<in>| A \<Longrightarrow> fMin A = (0 :: nat)"
  by (rule fMin_eqI) auto

lemma insert_nth_Cons[simp]:
  "insert_nth i x (y # xs) = (case i of 0 \<Rightarrow> x # y # xs | Suc i \<Rightarrow> y # insert_nth i x xs)"
  by (cases i) simp_all

lemma insert_nth_commute[simp]:
  assumes "j \<le> i" "i \<le> length xs"
  shows "insert_nth j y (insert_nth i x xs) = insert_nth (Suc i) x (insert_nth j y xs)"
  using assms by (induct xs arbitrary: i j) (auto simp del: insert_nth_take_drop split: nat.splits)

lemma SUC_SUC[simp]: "SUC ord (SUC ord' idx) = SUC ord' (SUC ord idx)"
  by transfer (auto split: order.splits)

lemma LESS_SUC[simp]:
  "LESS ord 0 (SUC ord idx)"
  "LESS ord (Suc l) (SUC ord idx) = LESS ord l idx"
  "ord \<noteq> ord' \<Longrightarrow> LESS ord l (SUC ord' idx) = LESS ord l idx"
  "LESS ord l idx \<Longrightarrow> LESS ord l (SUC ord' idx)"
  by (transfer, force split: order.splits)+

lemma nvars_Extend[simp]:
  "#\<^sub>V (Extend ord i \<AA> P) = SUC ord (#\<^sub>V \<AA>)"
  by (transfer, force split: order.splits)

lemma Length_Extend[simp]:
  "Length (Extend k i \<AA> P) = max (Length \<AA>) (if P = {||} then 0 else Suc (fMax P))"
  unfolding max_def by (split if_splits, transfer) (force split: order.splits)

lemma assigns_Extend[simp]:
  "LEQ ord i (#\<^sub>V \<AA>) \<Longrightarrow>m\<^bsup>Extend ord i \<AA> P\<^esup>ord = (if m = i then P else (if m > i then m - Suc 0 else m)\<^bsup>\<AA>\<^esup>ord)"
  "ord \<noteq> ord' \<Longrightarrow> m\<^bsup>Extend ord i \<AA> P\<^esup>ord' = m\<^bsup>\<AA>\<^esup>ord'"
  by (transfer, force simp: min_def nth_append split: order.splits)+

lemma Extend_commute_safe[simp]:
  "\<lbrakk>j \<le> i; LEQ ord i (#\<^sub>V \<AA>)\<rbrakk> \<Longrightarrow>
    Extend ord j (Extend ord i \<AA> P1) P2 = Extend ord (Suc i) (Extend ord j \<AA> P2) P1"
  by (transfer,
    force simp del: insert_nth_take_drop simp: replicate_add[symmetric] split: order.splits)

lemma Extend_commute_unsafe:
  "ord \<noteq> ord' \<Longrightarrow> Extend ord j (Extend ord' i \<AA> P1) P2 = Extend ord' i (Extend ord j \<AA> P2) P1"
  by (transfer, force simp: replicate_add[symmetric] split: order.splits)

lemma Length_CONS[simp]:
  "Length (CONS x \<AA>) = Suc (Length \<AA>)"
  by (transfer, force split: order.splits)

lemma Length_SNOC[simp]:
  "Length (SNOC x \<AA>) = Suc (Length \<AA>)"
  by (transfer, force simp: Let_def split: order.splits)

lemma nvars_CONS[simp]:
  "#\<^sub>V (CONS x \<AA>) = #\<^sub>V \<AA>"
  by (transfer, force)

lemma nvars_SNOC[simp]:
  "#\<^sub>V (SNOC x \<AA>) = #\<^sub>V \<AA>"
  by (transfer, force simp: Let_def)

lemma assigns_CONS[simp]:
  assumes "#\<^sub>V \<AA> = size_atom bs1_bs2"
  shows "LESS ord x (#\<^sub>V \<AA>) \<Longrightarrow> x\<^bsup>CONS bs1_bs2 \<AA>\<^esup>ord =
    (if case_prod case_order bs1_bs2 ord ! x then finsert 0 (upshift (x\<^bsup>\<AA>\<^esup>ord)) else upshift (x\<^bsup>\<AA>\<^esup>ord))"
  by (insert assms, transfer) (auto simp: lift_def split: order.splits)

lemma assigns_SNOC[simp]:
  assumes "#\<^sub>V \<AA> = size_atom bs1_bs2"
  shows "LESS ord x (#\<^sub>V \<AA>) \<Longrightarrow> x\<^bsup>SNOC bs1_bs2 \<AA>\<^esup>ord =
    (if case_prod case_order bs1_bs2 ord ! x then finsert (Length \<AA>) (x\<^bsup>\<AA>\<^esup>ord) else x\<^bsup>\<AA>\<^esup>ord)"
  by (insert assms, transfer) (force simp: snoc_def Let_def split: order.splits)

lemma map_index'_eq_conv[simp]:
  "map_index' i f xs = map_index' j g xs = (\<forall>k < length xs. f (i + k) (xs ! k) = g (j + k) (xs ! k))"
proof (induct xs arbitrary: i j)
  case Cons from Cons(1)[of "Suc i" "Suc j"] show ?case by (auto simp: nth_Cons split: nat.splits)
qed simp

lemma fMax_Diff_0[simp]: "Suc m |\<in>| P \<Longrightarrow> fMax (P |-| {|0|}) = fMax P"
  by (rule fMax_eqI) (auto intro: fMax_in dest: fMax_ge)

lemma Suc_fMax_pred_fimage[simp]:
  assumes "Suc p |\<in>| P" "0 |\<notin>| P"
  shows "Suc (fMax ((\<lambda>x. x - Suc 0) |`| P)) = fMax P"
  using assms by (subst mono_fMax_commute[of Suc, unfolded mono_def, simplified]) (auto simp: o_def)

lemma Extend_CONS[simp]: "#\<^sub>V \<AA> = size_atom x \<Longrightarrow> Extend ord 0 (CONS x \<AA>) P =
  CONS (extend ord (eval P 0) x) (Extend ord 0 \<AA> (downshift P))"
  by transfer (auto simp: extend_def o_def gr0_conv_Suc
    mono_fMax_commute[of Suc, symmetric, unfolded mono_def, simplified]
    lift_def upshift_def downshift_def eval_def
    dest!: fsubset_fsingletonD split: order.splits)

lemma size_atom_extend[simp]:
  "size_atom (extend ord b x) = SUC ord (size_atom x)"
  unfolding extend_def by transfer (simp split: prod.splits order.splits)

lemma size_atom_zero[simp]:
  "size_atom (zero idx) = idx"
  unfolding extend_def by transfer (simp split: prod.splits order.splits)

lemma interp_eqI:
  "\<lbrakk>Length \<AA> = Length \<BB>; #\<^sub>V \<AA> = #\<^sub>V \<BB>; \<And>m k. LESS k m (#\<^sub>V \<AA>) \<Longrightarrow> m\<^bsup>\<AA>\<^esup>k = m\<^bsup>\<BB>\<^esup>k\<rbrakk> \<Longrightarrow> \<AA> = \<BB>"
  by transfer (force split: order.splits intro!: nth_equalityI)

lemma Extend_SNOC_cut[unfolded eval_def cut_def Length_SNOC, simp]:
  "\<lbrakk>len P \<le> Length (SNOC x \<AA>); #\<^sub>V \<AA> = size_atom x\<rbrakk> \<Longrightarrow>
  Extend ord 0 (SNOC x \<AA>) P =
    SNOC (extend ord (if eval P (Length \<AA>) then True else False) x) (Extend ord 0 \<AA> (cut (Length \<AA>) P))"
  by transfer (fastforce simp: extend_def len_def cut_def ffilter_eq_fempty_iff snoc_def eval_def
    split: if_splits order.splits dest: fMax_ge fMax_boundedD intro: fMax_in)

lemma nth_replicate_simp: "replicate m x ! i = (if i < m then x else [] ! (i - m))"
  by (induct m arbitrary: i) (auto simp: nth_Cons')

lemma MSB_eq_SucD: "MSB Is = Suc x \<Longrightarrow> \<exists>P\<in>set Is. x |\<in>| P"
  using Max_in[of "\<Union>x\<in>set Is. fset x"]
  unfolding MSB_def by (force simp: fmember_def split: if_splits)

lemma append_replicate_inj:
  assumes "xs \<noteq> [] \<Longrightarrow> last xs \<noteq> x" and "ys \<noteq> [] \<Longrightarrow> last ys \<noteq> x"
  shows "xs @ replicate m x = ys @ replicate n x \<longleftrightarrow> (xs = ys \<and> m = n)"
proof safe
  from assms have assms': "xs \<noteq> [] \<Longrightarrow> rev xs ! 0 \<noteq> x" "ys \<noteq> [] \<Longrightarrow> rev ys ! 0 \<noteq> x"
    by (auto simp: hd_rev hd_conv_nth[symmetric])
  assume *: "xs @ replicate m x = ys @ replicate n x"
  then have "rev (xs @ replicate m x) = rev (ys @ replicate n x)" ..
  then have "replicate m x @ rev xs = replicate n x @ rev ys" by simp
  then have "take (max m n) (replicate m x @ rev xs) = take (max m n) (replicate n x @ rev ys)" by simp
  then have "replicate m x @ take (max m n - m) (rev xs) =
    replicate n x @ take (max m n - n) (rev ys)" by (auto simp: min_def max_def split: if_splits)
  then have "(replicate m x @ take (max m n - m) (rev xs)) ! min m n =
    (replicate n x @ take (max m n - n) (rev ys)) ! min m n" by simp
  with arg_cong[OF *, of length, simplified] assms' show "m = n"
    by (cases "xs = []" "ys = []" rule: bool.exhaust[case_product bool.exhaust])
      (auto simp: min_def nth_append split: if_splits)
  with * show "xs = ys" by auto
qed

lemma fin_lift[simp]: "m |\<in>| lift bs i (I ! i) \<longleftrightarrow> (case m of 0 \<Rightarrow> bs ! i | Suc m \<Rightarrow> m |\<in>| I ! i)"
  unfolding lift_def upshift_def by (auto split: nat.splits)

lemma ex_Length_0[simp]:
  "\<exists>\<AA>. Length \<AA> = 0 \<and> #\<^sub>V \<AA> = idx"
  by transfer (auto intro!: exI[of _ "replicate m {||}" for m])

lemma is_empty_inj[simp]: "\<lbrakk>Length \<AA> = 0; Length \<BB> = 0; #\<^sub>V \<AA> = #\<^sub>V \<BB>\<rbrakk> \<Longrightarrow> \<AA> = \<BB>"
  by transfer (simp add: list_eq_iff_nth_eq split: prod.splits,
    metis MSB_greater fMax_in less_nat_zero_code)

lemma set_\<sigma>_length_atom[simp]: "(x \<in> set (\<sigma> idx)) \<longleftrightarrow> idx = size_atom x"
  by transfer (auto simp: set_n_lists enum_UNIV image_iff intro!: exI[of _ "I1 @ I2" for I1 I2])

lemma distinct_\<sigma>[simp]: "distinct (\<sigma> idx)"
  by transfer (auto 0 4 simp: distinct_map distinct_n_lists set_n_lists inj_on_def
    intro: iffD2[OF append_eq_append_conv]
      box_equals[OF _ append_take_drop_id append_take_drop_id, of n _ n for n])

lemma fMin_less_Length[simp]: "x |\<in>| m1\<^bsup>\<AA>\<^esup>k \<Longrightarrow> fMin (m1\<^bsup>\<AA>\<^esup>k) < Length \<AA>"
  by transfer
    (force elim: order.strict_trans2[OF MSB_greater, rotated -1] intro: fMin_in split: order.splits)

lemma fMax_less_Length[simp]: "x |\<in>| m1\<^bsup>\<AA>\<^esup>k \<Longrightarrow> fMax (m1\<^bsup>\<AA>\<^esup>k) < Length \<AA>"
  by transfer
    (force elim: order.strict_trans2[OF MSB_greater, rotated -1] intro: fMax_in split: order.splits)

lemma min_Length_fMin[simp]: "x |\<in>| m1\<^bsup>\<AA>\<^esup>k \<Longrightarrow> min (Length \<AA>) (fMin (m1\<^bsup>\<AA>\<^esup>k)) = fMin (m1\<^bsup>\<AA>\<^esup>k)"
  using fMin_less_Length[of x m1 \<AA> k] unfolding fMin_def by auto

lemma max_Length_fMin[simp]: "x |\<in>| m1\<^bsup>\<AA>\<^esup>k \<Longrightarrow> max (Length \<AA>) (fMin (m1\<^bsup>\<AA>\<^esup>k)) = Length \<AA>"
  using fMin_less_Length[of x m1 \<AA> k] unfolding fMin_def by auto

lemma min_Length_fMax[simp]: "x |\<in>| m1\<^bsup>\<AA>\<^esup>k \<Longrightarrow> min (Length \<AA>) (fMax (m1\<^bsup>\<AA>\<^esup>k)) = fMax (m1\<^bsup>\<AA>\<^esup>k)"
  using fMax_less_Length[of x m1 \<AA> k] unfolding fMax_def by auto

lemma assigns_less_Length[simp]: "x |\<in>| m1\<^bsup>\<AA>\<^esup>k \<Longrightarrow> x < Length \<AA>"
  by transfer (force dest: MSB_greater split: order.splits if_splits)

lemma Length_notin_assigns[simp]: "Length \<AA> |\<notin>| m\<^bsup>\<AA>\<^esup>k"
  by (metis assigns_less_Length less_not_refl)

lemma nth_zero[simp]: "LESS ord m (#\<^sub>V \<AA>) \<Longrightarrow> \<not> case_prod case_order (zero (#\<^sub>V \<AA>)) ord ! m"
  by transfer (auto split: order.splits)

lemma in_fimage_Suc[simp]: "x |\<in>| Suc |`| A \<longleftrightarrow> (\<exists>y. y |\<in>| A \<and> x = Suc y)"
  by blast

lemma fimage_Suc_inj[simp]: "Suc |`| A = Suc |`| B \<longleftrightarrow> A = B"
  by blast

lemma MSB_eq0_D: "MSB I = 0 \<Longrightarrow> x < length I \<Longrightarrow> I ! x = {||}"
  unfolding MSB_def by (auto split: if_splits)

lemma Suc_in_fimage_Suc: "Suc x |\<in>| Suc |`| X \<longleftrightarrow> x |\<in>| X"
  by auto

lemma Suc_in_fimage_Suc_o_Suc[simp]: "Suc x |\<in>| (Suc \<circ> Suc) |`| X \<longleftrightarrow> x |\<in>| Suc |`| X"
  by auto

lemma finsert_same_eq_iff[simp]: "finsert k X = finsert k Y \<longleftrightarrow> X |-| {|k|} = Y |-| {|k|}"
  by auto

lemma fimage_Suc_o_Suc_eq_fimage_Suc_iff[simp]:
  "((Suc \<circ> Suc) |`| X = Suc |`| Y) \<longleftrightarrow> (Suc |`| X = Y)"
  by (metis fimage_Suc_inj fset.map_comp)

lemma fMax_image_Suc[simp]: "x |\<in>| P \<Longrightarrow> fMax (Suc |`| P) = Suc (fMax P)"
  by (rule fMax_eqI) (metis Suc_le_mono fMax_ge fimageE, metis fimageI fempty_iff fMax_in)

lemma fimage_Suc_eq_singleton[simp]: "(fimage Suc Z = {|y|}) \<longleftrightarrow> (\<exists>x. Z = {|x|} \<and> Suc x = y)"
  by (cases y) auto

lemma len_downshift_helper:
  "x |\<in>| P \<Longrightarrow> Suc (fMax ((\<lambda>x. x - Suc 0) |`| (P |-| {|0|}))) \<noteq> fMax P \<Longrightarrow> xa |\<in>| P \<Longrightarrow> xa = 0"
proof -
  assume a1: "xa |\<in>| P"
  assume a2: "Suc (fMax ((\<lambda>x. x - Suc 0) |`| (P |-| {|0|}))) \<noteq> fMax P"
  have "xa |\<in>| {|0|} \<longrightarrow> xa = 0" by fastforce
  moreover
  { assume "xa |\<notin>| {|0|}"
    hence "0 |\<notin>| P |-| {|0|} \<and> xa |\<notin>| {|0|}" by blast
    then obtain esk1\<^sub>1 :: "nat \<Rightarrow> nat" where "xa = 0" using a1 a2 by (metis Suc_fMax_pred_fimage fMax_Diff_0 fminus_iff not0_implies_Suc) }
  ultimately show "xa = 0" by blast
qed

lemma CONS_inj[simp]: "size_atom x = #\<^sub>V \<AA> \<Longrightarrow> size_atom y = #\<^sub>V \<AA> \<Longrightarrow> #\<^sub>V \<AA> = #\<^sub>V \<BB> \<Longrightarrow>
  CONS x \<AA> = CONS y \<BB> \<longleftrightarrow> (x = y \<and> \<AA> = \<BB>)"
  by transfer (auto simp: list_eq_iff_nth_eq lift_def upshift_def split: if_splits; blast)

lemma Suc_minus1: "Suc (x - Suc 0) = (if x = 0 then Suc 0 else x)"
  by auto

lemma fset_eq_empty_iff: "(fset X = {}) = (X = {||})"
  by (metis bot_fset.rep_eq fset_inverse)

lemma fset_le_singleton_iff: "(fset X \<subseteq> {x}) = (X = {||} \<or> X = {|x|})"
  by (metis finsert.rep_eq fset_eq_empty_iff fset_inject order_refl singleton_insert_inj_eq subset_singletonD)

lemma MSB_decreases:
  "MSB I \<le> Suc m \<Longrightarrow> MSB (map (\<lambda>X. (\<lambda>I1. I1 - Suc 0) |`| (X |-| {|0|})) I) \<le> m"
  unfolding MSB_def
  by (auto simp add: not_le less_Suc_eq_le fset_eq_empty_iff fset_le_singleton_iff
    split: if_splits dest!: iffD1[OF Max_le_iff, rotated -1] iffD1[OF Max_ge_iff, rotated -1]; force)

lemma CONS_surj[dest]: "Length \<AA> > 0 \<Longrightarrow>
  \<exists>x \<BB>. \<AA> = CONS x \<BB> \<and> #\<^sub>V \<BB> = #\<^sub>V \<AA> \<and> size_atom x = #\<^sub>V \<AA>"
  by transfer (auto simp: gr0_conv_Suc list_eq_iff_nth_eq lift_def upshift_def split: if_splits
    intro!: exI[of _ "map (\<lambda>X. 0 |\<in>| X) _"] exI[of _ "map (\<lambda>X. (\<lambda>x. x - Suc 0) |`| (X |-| {|0|})) _"],
    auto simp: MSB_decreases upshift_def Suc_minus1 fimage_iff intro: rev_fBexI split: if_splits)

(*<*)
end
(*>*)


theory topo_alexandrov
   imports sse_operation_positive_quantification
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

section \<open>Generalized specialization orderings and Alexandrov topologies\<close>

text\<open>\noindent{A topology is called 'Alexandrov' (after the Russian mathematician Pavel Alexandrov) if the intersection
(resp. union) of any (finite or infinite) family of open (resp. closed) sets is open (resp. closed);
in algebraic terms, this means that the set of fixed points of the interior (closure) operation is closed
under infinite meets (joins). Another common algebraic formulation requires the closure (interior) operation
to satisfy the infinitary variants of additivity (multiplicativity), i.e. iADDI (iMULT) as introduced before.

In the literature, the well-known Kuratowski conditions for the closure (resp. interior) operation are assumed,
namely: ADDI, EXP, NOR, IDEM (resp. MULT, dEXP, dNOR, IDEM). This makes both formulations equivalent.
However, this is not the case in general if those conditions become negotiable.}\<close>

text\<open>\noindent{Alexandrov topologies have interesting properties relating them to the semantics of modal logic.
Assuming Kuratowski conditions, Alexandrov topological operations defined on subsets of S are in one-to-one
correspondence with preorders on S; in topological terms, Alexandrov topologies are uniquely determined by
their specialization preorders. Since we do not presuppose any Kuratowski conditions to begin with, the
preorders in question are in general not even transitive. Here we just call them 'specialization relations'.
We will still call (generalized) closure/interior-like operations as such (for lack of a better name).
We explore minimal conditions under which some relevant results for the semantics of modal logic obtain.}\<close>

subsection \<open>Specialization relations\<close>

text\<open>\noindent{Specialization relations (among worlds/points) are particular cases of propositional functions with type @{text "w\<Rightarrow>\<sigma>"}.}\<close>

text\<open>\noindent{Define some relevant properties of relations: }\<close>
abbreviation "serial R  \<equiv> \<forall>x. \<exists>y. R x y"
abbreviation "reflexive R  \<equiv> \<forall>x. R x x"
abbreviation "transitive R \<equiv> \<forall>x y z. R x y \<and> R y z \<longrightarrow> R x z"
abbreviation "antisymmetric R  \<equiv> \<forall>x y. R x y \<and> R y x \<longrightarrow> x = y"
abbreviation "symmetric R  \<equiv> \<forall>x y. R x y \<longrightarrow> R y x"

text\<open>\noindent{Closure/interior operations can be derived from an arbitrary relation as operations returning down-/up-sets.}\<close>
definition Cl_rel::"(w\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<C>\<^sub>R") where "\<C>\<^sub>R R \<equiv> \<lambda>A. \<lambda>w. \<exists>v. R w v \<and> A v"
definition Int_rel::"(w\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<I>\<^sub>R") where "\<I>\<^sub>R R \<equiv> \<lambda>A. \<lambda>w. \<forall>v. R w v \<longrightarrow> A v"

text\<open>\noindent{Duality between interior and closure follows directly:}\<close>
lemma dual_rel1: "\<forall>A. (\<C>\<^sub>R R) A \<^bold>\<approx> (\<I>\<^sub>R R)\<^sup>d A" unfolding Cl_rel_def Int_rel_def dual_def conn by simp
lemma dual_rel2: "\<forall>A. (\<I>\<^sub>R R) A \<^bold>\<approx> (\<C>\<^sub>R R)\<^sup>d A" unfolding Cl_rel_def Int_rel_def dual_def conn by simp

text\<open>\noindent{We explore minimal conditions of the specialization relation under which some operation's conditions obtain.}\<close>
lemma rC1: "ADDI (\<C>\<^sub>R R)" unfolding Cl_rel_def ADDI_def conn by blast
lemma rC1i:"iADDI (\<C>\<^sub>R R)" by (smt Cl_rel_def Ra_restr_ex iADDI_def supremum_def)
lemma rC2: "reflexive R \<longrightarrow> EXP (\<C>\<^sub>R R)" unfolding EXP_def Cl_rel_def by auto
lemma rC3: "NOR (\<C>\<^sub>R R)" unfolding Cl_rel_def NOR_def conn by blast
lemma rC4: "reflexive R \<and> transitive R \<longrightarrow> IDEM (\<C>\<^sub>R R)" unfolding Cl_rel_def IDEM_def by smt
lemma rC_Barcan: "\<forall>\<pi>. (\<C>\<^sub>R R)(\<^bold>\<exists>x. \<pi> x) \<^bold>\<preceq> (\<^bold>\<exists>x. (\<C>\<^sub>R R)(\<pi> x))" unfolding Cl_rel_def by auto

lemma rI1: "MULT (\<I>\<^sub>R R)" unfolding Int_rel_def MULT_def conn by blast
lemma rI1i:"iMULT (\<I>\<^sub>R R)" by (smt Int_rel_def Ra_restr_all iMULT_def infimum_def)
lemma rI2: "reflexive R \<Longrightarrow> dEXP (\<I>\<^sub>R R)" unfolding Int_rel_def dEXP_def Int_rel_def by auto
lemma rI3: "dNOR (\<I>\<^sub>R R)" unfolding Int_rel_def dNOR_def conn by simp
lemma rI4: "reflexive R \<Longrightarrow> transitive R \<Longrightarrow> IDEM (\<I>\<^sub>R R)" unfolding IDEM_def Int_rel_def by smt
lemma rI_Barcan: "\<forall>\<pi>. (\<^bold>\<forall>x. (\<I>\<^sub>R R)(\<pi> x)) \<^bold>\<preceq> (\<I>\<^sub>R R)(\<^bold>\<forall>x. \<pi> x)" unfolding Int_rel_def by simp

text\<open>\noindent{A specialization relation can be derived from a given operation (intended as a closure-like operation).}\<close>
definition sp_rel::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(w\<Rightarrow>\<sigma>)" ("\<R>\<^sup>C") where "\<R>\<^sup>C \<C> \<equiv> \<lambda>w v. \<C> (\<lambda>u. u=v) w"

text\<open>\noindent{Preorder properties of the specialization relation follow directly from the corresponding operation's conditions.}\<close>
lemma sp_rel_reflex: "EXP \<C> \<Longrightarrow> reflexive (\<R>\<^sup>C \<C>)" by (simp add: EXP_def sp_rel_def)
lemma sp_rel_trans: "MONO \<C> \<Longrightarrow> IDEM \<C> \<Longrightarrow> transitive (\<R>\<^sup>C \<C>)" by (smt IDEM_def MONO_def sp_rel_def)

text\<open>\noindent{However, we can obtain finite countermodels for antisymmetry and symmetry given all relevant conditions.
We will revisit this issue later and examine their relation with the topological separation axioms T0 and T1 resp.}\<close>
lemma "iADDI \<C> \<Longrightarrow> EXP \<C> \<Longrightarrow> NOR \<C> \<Longrightarrow> IDEM \<C> \<Longrightarrow> antisymmetric (\<R>\<^sup>C \<C>)" nitpick oops (*counterexample*)
lemma "iADDI \<C> \<Longrightarrow> EXP \<C> \<Longrightarrow> NOR \<C> \<Longrightarrow> IDEM \<C> \<Longrightarrow> symmetric (\<R>\<^sup>C \<C>)" nitpick oops (*counterexample*)

subsection \<open>Alexandrov topology\<close>

text\<open>\noindent{As mentioned previously, Alexandrov closure (and by duality interior) operations correspond to specialization
relations. It is worth mentioning that in Alexandrov topologies every point has a minimal/smallest neighborhood,
namely the set of points related to it by the specialization (aka. accessibility) relation. Alexandrov spaces are
thus also called 'finitely generated'. We examine below  minimal conditions under which these relations obtain.}\<close>

lemma sp_rel_a:   "MONO \<C>  \<Longrightarrow> \<forall>A. (\<C>\<^sub>R (\<R>\<^sup>C \<C>)) A \<^bold>\<preceq> \<C> A" by (smt Cl_rel_def MONO_def sp_rel_def)
lemma sp_rel_b: "iADDI_a \<C> \<Longrightarrow> \<forall>A. (\<C>\<^sub>R (\<R>\<^sup>C \<C>)) A \<^bold>\<succeq> \<C> A"  proof -
  assume iaddia: "iADDI_a \<C>"
  { fix A
    let ?S="\<lambda>B::\<sigma>. \<exists>w::w. A w \<and> B=(\<lambda>u. u=w)"
    have "A \<^bold>\<approx> (\<^bold>\<Or>?S)" using supremum_def by auto
    hence "\<C>(A) \<^bold>\<approx> \<C>(\<^bold>\<Or>?S)" by (smt eq_ext)
    moreover have "\<^bold>\<Or>Ra[\<C>|?S] \<^bold>\<approx> (\<C>\<^sub>R (\<R>\<^sup>C \<C>)) A" by (smt Cl_rel_def Ra_restr_ex sp_rel_def)
    moreover from iaddia have "\<C>(\<^bold>\<Or>?S) \<^bold>\<preceq> \<^bold>\<Or>Ra[\<C>|?S]" unfolding iADDI_a_def by simp
    ultimately have "\<C> A \<^bold>\<preceq> (\<C>\<^sub>R (\<R>\<^sup>C \<C>)) A" by simp
  } thus ?thesis by simp
qed
lemma sp_rel: "iADDI \<C> \<Longrightarrow> \<forall>A. \<C> A \<^bold>\<approx> (\<C>\<^sub>R (\<R>\<^sup>C \<C>)) A" by (metis MONO_iADDIb iADDI_a_def iADDI_b_def iADDI_def sp_rel_a sp_rel_b)
text\<open>\noindent{It is instructive to expand the definitions in the above lemma:}\<close>
lemma "iADDI \<C> \<Longrightarrow>  \<forall>A. \<forall>w. (\<C> A) w \<longleftrightarrow> (\<exists>v. A v \<and> (\<C> (\<lambda>u. u=v)) w)" using Cl_rel_def sp_rel by fastforce

text\<open>\noindent{We now turn to the more traditional characterization of Alexandrov topologies in terms of closure under
infinite joins/meets.}\<close>

text\<open>\noindent{Fixed points of operations satisfying ADDI (MULT) are not in general closed under infinite joins (meets).
For the given conditions countermodels are expected to be infinite. We (sanity) check that nitpick cannot find any.}\<close>
lemma "ADDI(\<phi>) \<Longrightarrow> supremum_closed (fp \<phi>)" (*nitpick*) oops (*cannot find finite countermodels*)
lemma "MULT(\<phi>) \<Longrightarrow> infimum_closed  (fp \<phi>)" (*nitpick*) oops (*cannot find finite countermodels*)

text\<open>\noindent{By contrast, we can show that this obtains if assuming the corresponding infinitary variants (iADDI/iMULT).}\<close>
lemma "iADDI(\<phi>) \<Longrightarrow> supremum_closed (fp \<phi>)" by (metis (full_types) Ra_restr_ex iADDI_def supremum_def)
lemma "iMULT(\<phi>) \<Longrightarrow> infimum_closed  (fp \<phi>)" by (metis (full_types) Ra_restr_all iMULT_def infimum_def)

text\<open>\noindent{As shown above, closure (interior) operations derived from relations readily satisfy iADDI (iMULT),
being thus closed under infinite joins (meets).}\<close>
lemma "supremum_closed (fp (\<C>\<^sub>R R))" by (smt Cl_rel_def supremum_def)
lemma "infimum_closed  (fp (\<I>\<^sub>R R))" by (smt Int_rel_def infimum_def)

subsection \<open>(Anti)symmetry and the separation axioms T0 and T1\<close>
text\<open>\noindent{We can now revisit the relationship between (anti)symmetry and the separation axioms T1 and T0.}\<close>

text\<open>\noindent{T0: any two distinct points in the space can be separated by an open set (i.e. containing one point and not the other).}\<close>
abbreviation "T0_sep \<C> \<equiv> \<forall>w v. w \<noteq> v \<longrightarrow> (\<exists>G. (fp \<C>\<^sup>d)(G) \<and> (G w \<noteq> G v))"
text\<open>\noindent{T1: any two distinct points can be separated by (two not necessarily disjoint) open sets, i.e. all singletons are closed.}\<close>
abbreviation "T1_sep \<C> \<equiv> \<forall>w. (fp \<C>)(\<lambda>u. u = w)"

text\<open>\noindent{We can (sanity) check that T1 entails T0 but not viceversa.}\<close>
lemma "T0_sep \<C> \<Longrightarrow> T1_sep \<C>" nitpick oops (*counterexample*)
lemma "T1_sep \<C> \<Longrightarrow> T0_sep \<C>" by (smt compl_def dual_def dual_symm)

text\<open>\noindent{Under appropriate conditions, T0-separation corresponds to antisymmetry of the specialization relation (here an ordering).}\<close>
lemma "T0_sep \<C> \<longleftrightarrow> antisymmetric (\<R>\<^sup>C \<C>)" nitpick oops (*counterexample*)
lemma T0_antisymm_a: "MONO \<C> \<Longrightarrow> T0_sep \<C> \<longrightarrow> antisymmetric (\<R>\<^sup>C \<C>)" by (smt Cl_rel_def compl_def dual_def sp_rel_a)
lemma T0_antisymm_b: "EXP \<C> \<Longrightarrow> IDEM \<C> \<Longrightarrow> antisymmetric (\<R>\<^sup>C \<C>) \<longrightarrow> T0_sep \<C>" by (metis (full_types) EXP_dual1 IDEM_def IDEM_dual2 IDEMa_def IDEMb_def compl_def dEXP_def dual_def dual_symm sp_rel_def)
lemma T0_antisymm: "MONO \<C> \<Longrightarrow> EXP \<C> \<Longrightarrow> IDEM \<C> \<Longrightarrow> T0_sep \<C> = antisymmetric (\<R>\<^sup>C \<C>)" by (metis T0_antisymm_a T0_antisymm_b)

text\<open>\noindent{Also, under the appropriate conditions, T1-separation corresponds to symmetry of the specialization relation.}\<close>
lemma T1_symm_a: "T1_sep \<C> \<longrightarrow> symmetric (\<R>\<^sup>C \<C>)" using sp_rel_def by auto
lemma T1_symm_b: "MONO \<C> \<Longrightarrow> EXP \<C> \<Longrightarrow> T0_sep \<C> \<Longrightarrow> symmetric (\<R>\<^sup>C \<C>) \<longrightarrow> T1_sep \<C>" by (metis T0_antisymm_a sp_rel_def sp_rel_reflex)
lemma T1_symm: "MONO \<C> \<Longrightarrow> EXP \<C> \<Longrightarrow> T0_sep \<C> \<Longrightarrow> symmetric (\<R>\<^sup>C \<C>) = T1_sep \<C>" by (metis T1_symm_a T1_symm_b)

end


(* Author: Tobias Nipkow *)

theory Abs_Int_den2
imports Abs_Int_den1_ivl
begin

context preord
begin

definition mono where "mono f = (\<forall>x y. x \<sqsubseteq> y \<longrightarrow> f x \<sqsubseteq> f y)"

lemma monoD: "mono f \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y" by(simp add: mono_def)

lemma mono_comp: "mono f \<Longrightarrow> mono g \<Longrightarrow> mono (g o f)"
by(simp add: mono_def)

declare le_trans[trans]

end

subsection "Widening and Narrowing"

text{* Jumping to the trivial post-fixed point @{const Top} in case @{text k}
rounds of iteration did not reach a post-fixed point (as in @{const iter}) is
a trivial widening step. We generalise this idea and complement it with
narrowing, a process to regain precision.

Class @{text WN} makes some assumptions about the widening and narrowing
operators. The assumptions serve two purposes. Together with a further
assumption that certain chains become stationary, they permit to prove
termination of the fixed point iteration, which we do not --- we limit the
number of iterations as before. The second purpose of the narrowing
assumptions is to prove that the narrowing iteration keeps on producing
post-fixed points and that it goes down. However, this requires the function
being iterated to be monotone. Unfortunately, abstract interpretation with
widening is not monotone. Hence the (recursive) abstract interpretation of a
loop body that again contains a loop may result in a non-monotone
function. Therefore our narrowing iteration needs to check at every step
that a post-fixed point is maintained, and we cannot prove that the precision
increases. *}

class WN = SL_top +
fixes widen :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<nabla>" 65)
assumes widen: "y \<sqsubseteq> x \<nabla> y"
fixes narrow :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<triangle>" 65)
assumes narrow1: "y \<sqsubseteq> x \<Longrightarrow> y \<sqsubseteq> x \<triangle> y"
assumes narrow2: "y \<sqsubseteq> x \<Longrightarrow> x \<triangle> y \<sqsubseteq> x"
begin

fun iter_up :: "('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a" where
"iter_up f 0 x = Top" |
"iter_up f (Suc n) x =
  (let fx = f x in if fx \<sqsubseteq> x then x else iter_up f n (x \<nabla> fx))"

lemma iter_up_pfp: "f(iter_up f n x) \<sqsubseteq> iter_up f n x"
apply (induction n arbitrary: x)
 apply (simp)
apply (simp add: Let_def)
done

fun iter_down :: "('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a" where
"iter_down f 0 x = x" |
"iter_down f (Suc n) x =
  (let y = x \<triangle> f x in if f y \<sqsubseteq> y then iter_down f n y else x)"

lemma iter_down_pfp: "f x \<sqsubseteq> x \<Longrightarrow> f(iter_down f n x) \<sqsubseteq> iter_down f n x"
apply (induction n arbitrary: x)
 apply (simp)
apply (simp add: Let_def)
done

definition iter' :: "nat \<Rightarrow> nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" where
"iter' m n f x =
  (let f' = (\<lambda>y. x \<squnion> f y) in iter_down f' n (iter_up f' m x))"

lemma iter'_pfp_above:
shows "f(iter' m n f x0) \<sqsubseteq> iter' m n f x0"
and "x0 \<sqsubseteq> iter' m n f x0"
using iter_up_pfp[of "\<lambda>x. x0 \<squnion> f x"] iter_down_pfp[of "\<lambda>x. x0 \<squnion> f x"]
by(auto simp add: iter'_def Let_def)

text{* This is how narrowing works on monotone functions: you just iterate. *}

abbreviation iter_down_mono :: "('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a" where
"iter_down_mono f n x == ((\<lambda>x. x \<triangle> f x)^^n) x"

text{* Narrowing always yields a post-fixed point: *}

lemma iter_down_mono_pfp: assumes "mono f" and "f x0 \<sqsubseteq> x0"
defines "x n == iter_down_mono f n x0"
shows "f(x n) \<sqsubseteq> x n"
proof (induction n)
  case 0 show ?case by (simp add: x_def assms(2))
next
  case (Suc n)
  have "f (x (Suc n)) = f(x n \<triangle> f(x n))" by(simp add: x_def)
  also have "\<dots> \<sqsubseteq> f(x n)" by(rule monoD[OF `mono f` narrow2[OF Suc]])
  also have "\<dots> \<sqsubseteq> x n \<triangle> f(x n)" by(rule narrow1[OF Suc])
  also have "\<dots> = x(Suc n)" by(simp add: x_def)
  finally show ?case .
qed

text{* Narrowing can only increase precision: *}

lemma iter_down_down: assumes "mono f" and "f x0 \<sqsubseteq> x0"
defines "x n == iter_down_mono f n x0"
shows "x n \<sqsubseteq> x0"
proof (induction n)
  case 0 show ?case by(simp add: x_def)
next
  case (Suc n)
  have "x(Suc n) = x n \<triangle> f(x n)" by(simp add: x_def)
  also have "\<dots> \<sqsubseteq> x n" unfolding x_def
    by(rule narrow2[OF iter_down_mono_pfp[OF assms(1), OF assms(2)]])
  also have "\<dots> \<sqsubseteq> x0" by(rule Suc)
  finally show ?case .
qed

end

instantiation ivl :: WN
begin

definition "widen_ivl ivl1 ivl2 =
  ((*if is_empty ivl1 then ivl2 else if is_empty ivl2 then ivl1 else*)
     case (ivl1,ivl2) of (I l1 h1, I l2 h2) \<Rightarrow>
       I (if le_option False l2 l1 \<and> l2 \<noteq> l1 then None else l2)
         (if le_option True h1 h2 \<and> h1 \<noteq> h2 then None else h2))"

definition "narrow_ivl ivl1 ivl2 =
  ((*if is_empty ivl1 \<or> is_empty ivl2 then empty else*)
     case (ivl1,ivl2) of (I l1 h1, I l2 h2) \<Rightarrow>
       I (if l1 = None then l2 else l1)
         (if h1 = None then h2 else h1))"

instance
proof qed
  (auto simp add: widen_ivl_def narrow_ivl_def le_option_def le_ivl_def empty_def split: ivl.split option.split if_splits)

end

instantiation astate :: (WN) WN
begin

definition "widen_astate F1 F2 =
  FunDom (\<lambda>x. fun F1 x \<nabla> fun F2 x) (inter_list (dom F1) (dom F2))"

definition "narrow_astate F1 F2 =
  FunDom (\<lambda>x. fun F1 x \<triangle> fun F2 x) (inter_list (dom F1) (dom F2))"

instance
proof
  case goal1 thus ?case
    by(simp add: widen_astate_def le_astate_def lookup_def widen)
next
  case goal2 thus ?case
    by(auto simp: narrow_astate_def le_astate_def lookup_def narrow1)
next
  case goal3 thus ?case
    by(auto simp: narrow_astate_def le_astate_def lookup_def narrow2)
qed

end

instantiation up :: (WN) WN
begin

fun widen_up where
"widen_up bot x = x" |
"widen_up x bot = x" |
"widen_up (Up x) (Up y) = Up(x \<nabla> y)"

fun narrow_up where
"narrow_up bot x = bot" |
"narrow_up x bot = bot" |
"narrow_up (Up x) (Up y) = Up(x \<triangle> y)"

instance
proof
  case goal1 show ?case
    by(induct x y rule: widen_up.induct) (simp_all add: widen)
next
  case goal2 thus ?case
    by(induct x y rule: narrow_up.induct) (simp_all add: narrow1)
next
  case goal3 thus ?case
    by(induct x y rule: narrow_up.induct) (simp_all add: narrow2)
qed

end

permanent_interpretation
  Abs_Int1 rep_ivl num_ivl plus_ivl filter_plus_ivl filter_less_ivl "(iter' 3 2)"
defining afilter_ivl' = afilter
and bfilter_ivl' = bfilter
and AI_ivl' = AI
and aval_ivl' = aval'
proof qed (auto simp: iter'_pfp_above)

value "list_up(AI_ivl' test3_ivl Top)"
value "list_up(AI_ivl' test4_ivl Top)"
value "list_up(AI_ivl' test5_ivl Top)"

end


(*  Title:      statecharts/DataSpace/DataSpace.thy

    Author:     Steffen Helke, Software Engineering Group
    Copyright   2010 Technische Universitaet Berlin
*)

section \<open>Partitoned Data Spaces for Statecharts\<close>
theory DataSpace
imports Contrib
begin

subsection \<open>Definitions\<close>

definition
  DataSpace :: "('d set) list
                => bool" where
  "DataSpace L = ((distinct L) \<and>
                  (\<forall> D1\<in>(set L). \<forall> D2\<in>(set L).
                             D1 \<noteq> D2 \<longrightarrow> ((D1 \<inter> D2) = {})) \<and>
                  ((\<Union> (set L)) = UNIV))"

lemma DataSpace_EmptySet:
 "[UNIV] \<in> { L | L. DataSpace L }"
by (unfold DataSpace_def, auto)

definition "dataspace = { L | (L::('d set) list). DataSpace L}"

typedef 'd dataspace = "dataspace :: 'd set list set"
  unfolding dataspace_def
  apply (rule exI)
  apply (rule DataSpace_EmptySet)
  done

definition
 PartNum :: "('d)dataspace => nat" where
 "PartNum = length o Rep_dataspace"

definition
 PartDom :: "['d dataspace, nat] => ('d set)" (infixl "!D!" 101) where
 "PartDom d n = (Rep_dataspace d) ! n"

subsection \<open>Lemmas\<close>

subsubsection \<open>\<open>DataSpace\<close>\<close>

lemma DataSpace_UNIV [simp]:
 "DataSpace [UNIV]"
by (unfold DataSpace_def, auto)

lemma DataSpace_select:
 "DataSpace (Rep_dataspace L)"
apply (cut_tac x=L in  Rep_dataspace)
apply (unfold dataspace_def)
apply auto
done

lemma UNIV_dataspace [simp]:
  "[UNIV] \<in> dataspace"
by (unfold dataspace_def, auto)

lemma Inl_Inr_DataSpace [simp]:
  "DataSpace [Part UNIV Inl, Part UNIV Inr]"
apply (unfold DataSpace_def)
apply auto
apply (rename_tac d)
apply (rule_tac b="(inv Inl) d" in Part_eqI)
apply auto
apply (rule sym)
apply (case_tac d)
apply auto
done

lemma Inl_Inr_dataspace [simp]:
  "[Part UNIV Inl, Part UNIV Inr] \<in> dataspace"
by (unfold dataspace_def, auto)

lemma InlInr_InlInl_Inr_DataSpace [simp]:
  "DataSpace [Part UNIV (Inl o Inr), Part UNIV (Inl o Inl), Part UNIV Inr]"
apply (unfold DataSpace_def)
apply auto
apply (unfold Part_def)
apply auto
apply (rename_tac x)
apply (case_tac x)
apply auto
apply (rename_tac a)
apply (case_tac a)
apply auto
done

lemma InlInr_InlInl_Inr_dataspace [simp]:
  "[Part UNIV (Inl o Inr), Part UNIV (Inl o Inl), Part UNIV Inr] : dataspace"
by (unfold dataspace_def, auto)

subsubsection \<open>\<open>PartNum\<close>\<close>

lemma PartDom_PartNum_distinct:
      "\<lbrakk> i < PartNum d; j < PartNum d;
         i \<noteq> j; p \<in>  (d !D! i) \<rbrakk> \<Longrightarrow>
         p \<notin> (d !D! j)"
apply auto
apply (cut_tac L=d in DataSpace_select)
apply (unfold DataSpace_def)
apply auto
apply (erule_tac x="Rep_dataspace d ! i" in ballE)
apply (erule_tac x="Rep_dataspace d ! j" in ballE)
apply auto
apply (simp add:distinct_conv_nth PartNum_def)
apply (unfold PartDom_def PartNum_def)
apply auto
done

lemma PartDom_PartNum_distinct2:
      "\<lbrakk> i < PartNum d; j < PartNum d;
         i \<noteq> j; p \<in>  (d !D! j) \<rbrakk> \<Longrightarrow>
        p \<notin> (d !D! i)"
apply auto
apply (cut_tac L=d in DataSpace_select)
apply (unfold DataSpace_def)
apply auto
apply (erule_tac x="Rep_dataspace d ! i" in ballE)
apply (erule_tac x="Rep_dataspace d ! j" in ballE)
apply auto
apply (simp add:distinct_conv_nth PartNum_def)
apply (unfold PartDom_def PartNum_def)
apply auto
done

lemma PartNum_length [simp]:
  "(DataSpace L) \<Longrightarrow> (PartNum (Abs_dataspace L) = (length L))"
apply (unfold PartNum_def)
apply auto
apply (subst Abs_dataspace_inverse)
apply (unfold dataspace_def)
apply auto
done

end


(*<*)
\<comment>\<open> ********************************************************************
 * Project         : AGM Theory
 * Version         : 1.0
 *
 * Authors         : Valentin Fouillard, Safouan Taha, Frederic Boulanger
                     and Nicolas Sabouret
 *
 * This file       : AGM contraction
 *
 * Copyright (c) 2021 Université Paris Saclay, France
 *
 * All rights reserved.
 *
 ******************************************************************************\<close>

theory AGM_Contraction

imports AGM_Logic AGM_Remainder

begin
(*>*)

section \<open>Contractions\<close>
text\<open>The first operator of belief change of the AGM framework is contraction. This operator consist to remove
a sentence @{term \<open>\<phi>\<close>} from a belief set @{term \<open>K\<close>} in such a way that @{term \<open>K\<close>} no longer imply @{term \<open>\<phi>\<close>}.

In the following we will first axiomatize such operators at different levels of logics (Tarskian, supraclassical and compact)
and then we will give constructions satisfying these axioms. The following graph summarizes all equivalences we established:

\includegraphics[width=\textwidth]{"graph_locales.pdf"}

We will use the extension feature of locales in Isabelle/HOL to incrementally define the contraction
operator as shown by blue arrows in the previous figure. Then, using the interpretation feature of locales, we will prove the equivalence between
descriptive and constructive approaches at each level depending on the adopted logics (black arrows).
\<close>

subsection\<open>AGM contraction postulates\<close>
text\<open>
The operator of contraction is denoted by the symbol @{text \<open>\<div>\<close>} and respects the six following conditions :
\<^item> @{text \<open>contract_closure\<close>} : a belief set @{term \<open>K\<close>} contracted by @{term \<open>\<phi>\<close>} should be logically closed
\<^item> @{text \<open>contract_inclusion\<close>} : a contracted set @{term \<open>K\<close>} should be a subset of the original one
\<^item> @{text \<open>contract_vacuity\<close>} : if @{term \<open>\<phi>\<close>} is not included in a set @{term \<open>K\<close>} then the contraction of @{term \<open>K\<close>} by @{term \<open>\<phi>\<close>} involves no change at all
\<^item> @{text \<open>contract_success\<close>} : if a set @{term \<open>K\<close>} is contracted by @{term \<open>\<phi>\<close>} then @{term \<open>K\<close>} does not imply @{term \<open>\<phi>\<close>}
\<^item> @{text \<open>contract_recovery\<close>}: all propositions removed in a set @{term \<open>K\<close>} by contraction of @{term \<open>\<phi>\<close>} will be recovered by expansion of @{term \<open>\<phi>\<close>}
\<^item> @{text \<open>contract_extensionality\<close>} : Extensionality guarantees that the logic of contraction is extensional in the sense of allowing logically
quivalent sentences to be freely substituted for each other\<close>
locale AGM_Contraction = Tarskian_logic +
fixes contraction::\<open>'a set \<Rightarrow> 'a \<Rightarrow> 'a set\<close> (infix \<open>\<div>\<close> 55)
assumes contract_closure:        \<open>K = Cn(A) \<Longrightarrow> K \<div> \<phi> = Cn(K \<div> \<phi>)\<close>
    and contract_inclusion:      \<open>K = Cn(A) \<Longrightarrow> K \<div> \<phi> \<subseteq> K\<close>
    and contract_vacuity:        \<open>K = Cn(A) \<Longrightarrow> \<phi> \<notin> K \<Longrightarrow> K \<div> \<phi> = K\<close>
    and contract_success:        \<open>K = Cn(A) \<Longrightarrow> \<phi> \<notin> Cn({}) \<Longrightarrow> \<phi> \<notin> K \<div> \<phi>\<close>
    and contract_recovery:       \<open>K = Cn(A) \<Longrightarrow> K \<subseteq> ((K \<div> \<phi>) \<oplus> \<phi>)\<close>
    and contract_extensionality: \<open>K = Cn(A) \<Longrightarrow> Cn({\<phi>}) = Cn({\<psi>}) \<Longrightarrow> K \<div> \<phi> = K \<div> \<psi>\<close>

text\<open>
A full contraction is defined by two more postulates to rule the conjunction. We base on a supraclassical logic.
\<^item> @{text \<open>contract_conj_overlap\<close>} : An element in both @{text \<open>K \<div> \<phi>\<close>}  and  @{text \<open>K \<div> \<psi>\<close>}  is also an element of  @{text \<open>K \<div> (\<phi> \<and> \<psi>)\<close>}
\<^item> @{text \<open>contract_conj_inclusion\<close>} : If @{term \<open>\<phi>\<close>} not in @{text \<open>K \<div> (\<phi> \<and> \<psi>)\<close>}  then all elements removed by this contraction are also removed from @{text \<open>K \<div> \<phi>\<close>}\<close>
locale AGM_FullContraction = AGM_Contraction + Supraclassical_logic +
  assumes contract_conj_overlap:   \<open>K = Cn(A) \<Longrightarrow> (K \<div> \<phi>) \<inter> (K \<div> \<psi>) \<subseteq> (K \<div> (\<phi> .\<and>. \<psi>))\<close>
      and contract_conj_inclusion: \<open>K = Cn(A) \<Longrightarrow> \<phi> \<notin> (K \<div> (\<phi> .\<and>. \<psi>)) \<Longrightarrow> ((K \<div> (\<phi> .\<and>. \<psi>) \<subseteq> (K \<div> \<phi>)))\<close>

begin
\<comment> \<open>two important lemmas/corollaries that can replace the two assumptions @{text \<open>contract_conj_overlap\<close>} and @{text \<open>contract_conj_inclusion\<close>}\<close>
text\<open>@{text \<open>contract_conj_overlap_variant\<close>} does not need \<open>\<psi>\<close> to occur in the left side! \<close>
corollary contract_conj_overlap_variant:  \<open>K = Cn(A) \<Longrightarrow> (K \<div> \<phi>) \<inter> Cn({\<phi>}) \<subseteq> (K \<div> (\<phi> .\<and>. \<psi>))\<close>
proof -
  assume a:\<open>K = Cn(A)\<close>
  { assume b:\<open>K \<turnstile> \<phi>\<close> and c:\<open>K \<turnstile> \<psi>\<close>
    hence d:\<open>K \<div> (\<phi> .\<and>. \<psi>) = K \<div> (\<phi> .\<and>. ((.\<not> \<phi>) .\<or>. \<psi>))\<close>
      apply(rule_tac contract_extensionality[OF a])
      using conj_overlap[of _ \<phi> \<psi>] by (simp add: Cn_same)
    have e:\<open>K \<inter> Cn {\<phi>} \<subseteq> K \<div> (.\<not> \<phi> .\<or>. \<psi>)\<close>
    proof(safe)
      fix \<chi>
      assume f:\<open>\<chi> \<in> K\<close> and g:\<open>\<chi> \<in> Cn {\<phi>}\<close>
      have \<open>K \<div> (.\<not> \<phi> .\<or>. \<psi>) \<turnstile> (.\<not> \<phi> .\<or>. \<psi>) .\<longrightarrow>. \<chi>\<close>
        by (metis a contract_recovery expansion_def f impI_PL infer_def subset_eq)
      hence \<open>K \<div> (.\<not> \<phi> .\<or>. \<psi>) \<turnstile> .\<not> \<phi> .\<longrightarrow>. \<chi>\<close>
        by (meson disjI1_PL imp_trans inclusion_L infer_def insert_subset validD_L valid_imp_PL)
      with g show \<open>\<chi> \<in> K \<div> (.\<not> \<phi> .\<or>. \<psi>)\<close>
        by (metis a contract_closure disjE_PL ex_mid_PL infer_def validD_L valid_imp_PL)
    qed
    have ?thesis
      unfolding d using e contract_conj_overlap[OF a, of \<phi> \<open>(.\<not> \<phi> .\<or>. \<psi>)\<close>] a contract_inclusion by force
  }
  then show ?thesis
    apply (cases \<open>\<not> K \<turnstile> \<phi> \<or> \<not> K \<turnstile> \<psi>\<close>)
    by (metis IntE a assumption_L conjE1_PL conjE2_PL contract_inclusion contract_vacuity subsetD subsetI) blast
qed

text\<open>@{text \<open>contract_conj_inclusion_variant\<close>}: Everything retained in @{text \<open>K \<div> (\<phi> \<and> \<psi>)\<close>} is retained in @{text \<open>K \<div> \<psi>\<close>}\<close>
corollary contract_conj_inclusion_variant : \<open>K = Cn(A) \<Longrightarrow> (K \<div> (\<phi> .\<and>. \<psi>) \<subseteq> (K \<div> \<phi>)) \<or> (K \<div> (\<phi> .\<and>. \<psi>) \<subseteq> (K \<div> \<psi>))\<close>
proof -
  assume a:\<open>K = Cn(A)\<close>
  { assume d:\<open>\<phi> \<in> (K \<div> (\<phi> .\<and>. \<psi>)) \<and> \<psi> \<in> (K \<div> (\<phi> .\<and>. \<psi>))\<close>
    hence \<open>\<phi> .\<and>. \<psi> \<in> (K \<div> (\<phi> .\<and>. \<psi>))\<close>
      using Supraclassical_logic.conjI_PL Supraclassical_logic_axioms a contract_closure by fastforce
    with d have ?thesis
      by (metis (no_types, lifting) Supraclassical_logic.valid_conj_PL Supraclassical_logic_axioms
                Tarskian_logic.valid_expansion Tarskian_logic_axioms a contract_closure contract_inclusion
                contract_recovery contract_success dual_order.trans expansion_def)
  }
  then show ?thesis
    by (metis a conj_com_Cn contract_conj_inclusion contract_extensionality)
qed

end

subsection \<open>Partial meet contraction definition\<close>

text\<open>A partial meet contraction of @{term \<open>K\<close>} by @{term \<open>\<phi>\<close>} is the intersection of some sets that not imply @{term \<open>\<phi>\<close>}.
We define these sets as the "remainders" @{text \<open>(K .\<bottom>. \<phi>\<close>}.
The function of selection @{term \<open>\<gamma>\<close>} select the best set of the remainders that do not imply @{term \<open>\<phi>\<close>}.
This function respect these postulates :
\<^item> @{text \<open>is_selection\<close>} : if there exist some set that do not imply @{term \<open>\<phi>\<close>} then the function selection @{term \<open>\<gamma>\<close>} is a subset of these sets
\<^item> @{text \<open>tautology_selection\<close>} : if there is no set that do not imply @{term \<open>\<phi>\<close>} then the result of the selection function is @{term \<open>K\<close>}
\<^item> @{text nonempty_selection} : An empty selection function do not exist
\<^item> @{text extensional_selection} : Two proposition with the same closure have the same selection function\<close>
locale PartialMeetContraction = Tarskian_logic +

fixes selection::\<open>'a set \<Rightarrow> 'a  \<Rightarrow> 'a set set\<close> (\<open>\<gamma>\<close>)
assumes is_selection:          \<open>K = Cn(A) \<Longrightarrow> (K .\<bottom>. \<phi>) \<noteq> {} \<Longrightarrow> \<gamma> K \<phi> \<subseteq> (K .\<bottom>. \<phi>)\<close>
assumes tautology_selection:   \<open>K = Cn(A) \<Longrightarrow> (K .\<bottom>. \<phi>) = {} \<Longrightarrow> \<gamma> K \<phi> = {K}\<close>
assumes nonempty_selection:    \<open>K = Cn(A) \<Longrightarrow> \<gamma> K \<phi> \<noteq> {}\<close>
assumes extensional_selection: \<open>K = Cn(A) \<Longrightarrow> Cn({\<phi>}) = Cn({\<psi>}) \<Longrightarrow> \<gamma> K \<phi> = \<gamma> K \<psi>\<close>

\<comment> \<open>extensionality seems very hard to implement for a constructive approach,
one basic implementation will be to ignore @{term \<open>A\<close>} and @{term \<open>\<phi>\<close>}
and only base on @{text \<open>A .\<bottom>. \<phi>\<close>} that
is already proved as extensional (lemma @{text \<open>remainder_extensionality\<close>})\<close>

begin

text \<open>A partial meet is the intersection of set of selected element.\<close>
definition (in Tarskian_logic) meet_contraction::\<open>'a set \<Rightarrow> ('a set \<Rightarrow> 'a  \<Rightarrow> 'a set set) \<Rightarrow> 'a \<Rightarrow> 'a set\<close> (\<open>_ \<div>\<^bsub>_\<^esub> _\<close> [60,50,60]55)
  where mc: \<open>(A \<div>\<^bsub>\<gamma>\<^esub> \<phi>) \<equiv> \<Inter>(\<gamma> A \<phi>)\<close>

text \<open>Following this definition 4 postulates of AGM can be proved on a partial meet contraction:
\<^item> @{text \<open>contract_inclusion\<close>}
\<^item> @{text \<open> contract_vacuity\<close>}
\<^item> @{text \<open> contract_closure\<close>}
\<^item> @{text \<open> contract_extensionality\<close>}\<close>

text \<open>@{text \<open>pmc_inclusion\<close> } :a partial meet contraction is a subset of the contracted set\<close>
lemma pmc_inclusion: \<open>K = Cn(A) \<Longrightarrow> K \<div>\<^bsub>\<gamma>\<^esub> \<phi> \<subseteq> K\<close>
  apply (cases \<open>(K .\<bottom>. \<phi>) = {}\<close>, simp_all add: mc tautology_selection)
  by (meson Inf_less_eq in_mono is_selection nonempty_selection rem_inclusion)

text\<open>@{text \<open>pmc_vacuity\<close>} :  if @{term \<open>\<phi>\<close>} is not included in a set @{term \<open>K\<close>} then the partial meet contraction of @{term \<open>K\<close>} by @{term \<open>\<phi>\<close>} involves not change at all\<close>
lemma pmc_vacuity: \<open>K = Cn(A) \<Longrightarrow> \<not> K \<turnstile> \<phi> \<Longrightarrow> K \<div>\<^bsub>\<gamma>\<^esub> \<phi> = K\<close>
  unfolding mc nonconsequence_remainder
  by (metis Inf_superset_mono Un_absorb1 cInf_singleton insert_not_empty is_selection mc nonconsequence_remainder pmc_inclusion sup_commute)

text\<open>@{text \<open>pmc_closure\<close>} : a partial meet contraction is logically closed\<close>
lemma pmc_closure: \<open>K = Cn(A) \<Longrightarrow> (K \<div>\<^bsub>\<gamma>\<^esub> \<phi>) = Cn(K \<div>\<^bsub>\<gamma>\<^esub> \<phi>)\<close>
proof (rule subset_antisym, simp_all add:inclusion_L mc transitivity_L, goal_cases)
  case 1
  have \<open>\<Inter>(\<gamma> (Cn A) \<phi>) = \<Inter>{Cn(B)|B. B \<in> \<gamma> (Cn A) \<phi>}\<close>
    by auto (metis idempotency_L insert_absorb insert_iff insert_subset is_selection rem_closure tautology_selection)+
  from Cn_Inter[OF this] show ?case by blast
qed

text \<open>@{text \<open>pmc_extensionality\<close>} : Extensionality guarantees that the logic of contraction is extensional in the sense of allowing logically equivalent sentences to be freely substituted for each other\<close>
lemma pmc_extensionality: \<open>K = Cn(A) \<Longrightarrow> Cn({\<phi>}) = Cn({\<psi>}) \<Longrightarrow> K \<div>\<^bsub>\<gamma>\<^esub> \<phi> = K \<div>\<^bsub>\<gamma>\<^esub> \<psi>\<close>
  by (metis extensional_selection mc)

text \<open>@{text \<open>pmc_tautology\<close>} : if @{term \<open>\<phi>\<close>} is a tautology then the partial meet contraction of @{term \<open>K\<close>} by @{term \<open>\<phi>\<close>} is @{term \<open>K\<close>}\<close>
lemma pmc_tautology: \<open>K = Cn(A) \<Longrightarrow> \<tturnstile> \<phi> \<Longrightarrow>  K \<div>\<^bsub>\<gamma>\<^esub> \<phi> = K\<close>
  by (simp add: mc taut2emptyrem tautology_selection)

text\<open>@{text \<open>completion\<close>} is a an operator that can build an equivalent selection from an existing one\<close>
definition (in Tarskian_logic) completion::\<open>('a set \<Rightarrow> 'a  \<Rightarrow> 'a set set) \<Rightarrow> 'a set \<Rightarrow> 'a  \<Rightarrow> 'a set set\<close> (\<open>*\<close>)
  where \<open>* \<gamma> A \<phi> \<equiv> if (A .\<bottom>. \<phi>) = {} then {A} else {B. B \<in> A .\<bottom>. \<phi> \<and> \<Inter> (\<gamma> A \<phi>) \<subseteq> B}\<close>

lemma selection_completion: "K = Cn(A) \<Longrightarrow> \<gamma> K \<phi> \<subseteq> * \<gamma> K \<phi>"
  using completion_def is_selection tautology_selection by fastforce

lemma (in Tarskian_logic) completion_completion: "K = Cn(A) \<Longrightarrow> * (* \<gamma>) K \<phi> = * \<gamma> K \<phi>"
  by (auto simp add:completion_def)

lemma pmc_completion: \<open>K = Cn(A) \<Longrightarrow> K \<div>\<^bsub>*\<gamma>\<^esub> \<phi> = K \<div>\<^bsub>\<gamma>\<^esub> \<phi>\<close>
  apply(auto simp add: mc completion_def tautology_selection)
  by (metis Inter_lower equals0D in_mono is_selection)

end

text\<open>A transitively relational meet contraction is a partial meet contraction using a binary relation between the elements of the selection function\<close>
text\<open>A relation is :
\<^item> transitive (@{text \<open>trans_rel\<close>})
\<^item> non empty (there is always an element  preferred to the others (@{text \<open>nonempty_rel\<close>}))\<close>

text\<open>A selection function @{term \<open>\<gamma>\<^sub>T\<^sub>R\<close>} is transitively relational @{text \<open>rel_sel\<close>} with the following condition :
\<^item> If the the remainders @{text \<open>K .\<bottom>. \<phi>\<close>} is empty then the selection function return @{term \<open>K\<close>}
\<^item> Else the selection function return a non empty transitive relation on the remainders\<close>
locale TransitivelyRelationalMeetContraction =  Tarskian_logic +

fixes relation::\<open>'a set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool\<close> (\<open>_ \<preceq>\<^bsub>_\<^esub> _\<close> [60,50,60]55)
assumes trans_rel: \<open>K = Cn(A) \<Longrightarrow> B \<preceq>\<^bsub>K\<^esub> C \<Longrightarrow> C \<preceq>\<^bsub>K\<^esub> D \<Longrightarrow> B \<preceq>\<^bsub>K\<^esub> D\<close>
assumes nonempty_rel: \<open>K = Cn(A) \<Longrightarrow> (K .\<bottom>. \<phi>) \<noteq> {} \<Longrightarrow> \<exists>B\<in>(K .\<bottom>. \<phi>). (\<forall>C\<in>(K .\<bottom>. \<phi>). C \<preceq>\<^bsub>K\<^esub> B)\<close> \<comment> \<open>pas clair dans la litterrature\<close>

fixes rel_sel::\<open>'a set \<Rightarrow> 'a  \<Rightarrow> 'a set set\<close> (\<open>\<gamma>\<^sub>T\<^sub>R\<close>)
defines rel_sel: \<open>\<gamma>\<^sub>T\<^sub>R K \<phi> \<equiv> if (K .\<bottom>. \<phi>) = {} then {K}
                                              else {B. B\<in>(K .\<bottom>. \<phi>) \<and> (\<forall>C\<in>(K .\<bottom>. \<phi>). C \<preceq>\<^bsub>K\<^esub> B)}\<close>

begin

text\<open>A transitively relational selection function respect the partial meet contraction postulates.\<close>
sublocale PartialMeetContraction where selection = \<gamma>\<^sub>T\<^sub>R
  apply(unfold_locales)
     apply(simp_all add: rel_sel)
   using nonempty_rel apply blast
  using remainder_extensionality by blast

end

text\<open>A full meet contraction is a limiting case of the partial meet contraction where if the remainders are not empty then
the selection function return all the remainders (as defined by @{text \<open>full_sel\<close>}\<close>
locale FullMeetContraction = Tarskian_logic +

fixes full_sel::\<open>'a set \<Rightarrow> 'a  \<Rightarrow> 'a set set\<close> (\<open>\<gamma>\<^sub>F\<^sub>C\<close>)
defines full_sel: \<open>\<gamma>\<^sub>F\<^sub>C K \<phi> \<equiv> if K .\<bottom>. \<phi> = {} then {K} else K .\<bottom>. \<phi>\<close>

begin

text\<open>A full selection and a relation ? is a transitively relational meet contraction postulates.\<close>
sublocale TransitivelyRelationalMeetContraction where relation = \<open>\<lambda> K A B. True\<close> and rel_sel=\<gamma>\<^sub>F\<^sub>C
  by (unfold_locales, auto simp add:full_sel, rule eq_reflection, simp)

end

subsection\<open>Equivalence of partial meet contraction and AGM contraction\<close>

locale PMC_SC = PartialMeetContraction + Supraclassical_logic + Compact_logic

begin

text \<open>In a context of a supraclassical and a compact logic the two remaining postulates of AGM contraction :
\<^item> @{text \<open>contract_recovery\<close>}
\<^item> @{text \<open>contract_success\<close>}
can be proved on a partial meet contraction.\<close>

text\<open>@{text \<open>pmc_recovery\<close>} : all proposition removed by a partial meet contraction of @{term \<open>\<phi>\<close>} will be recovered by the expansion of @{term \<open>\<phi>\<close>}\<close>

\<comment> \<open>recovery requires supraclassicality\<close>
lemma pmc_recovery: \<open>K = Cn(A) \<Longrightarrow> K \<subseteq> ((K \<div>\<^bsub>\<gamma>\<^esub> \<phi>) \<oplus> \<phi>)\<close>
  apply(cases \<open>(K .\<bottom>. \<phi>) = {}\<close>, simp_all (no_asm) add:mc expansion_def)
  using inclusion_L tautology_selection apply fastforce
  proof -
    assume a:\<open>K = Cn(A)\<close> and b:\<open>K .\<bottom>. \<phi> \<noteq> {}\<close>
    { fix \<psi>
      assume d:\<open>K \<turnstile> \<psi>\<close>
      have \<open>\<phi> .\<longrightarrow>. \<psi> \<in> \<Inter>(\<gamma> K \<phi>)\<close>
        using is_selection[OF a b]
        by auto (metis a d infer_def rem_closure remainder_recovery subsetD)
    }
    with a b show \<open>K \<subseteq> Cn (insert \<phi> (\<Inter> (\<gamma> K \<phi>)))\<close>
      by (metis (no_types, lifting) Un_commute assumption_L imp_PL infer_def insert_is_Un subsetI)
  qed

text \<open>@{text \<open>pmc_success\<close>} : a partial meet contraction of @{term \<open>K\<close>} by @{term \<open>\<phi>\<close>} not imply @{term \<open>\<phi>\<close>}\<close>
\<comment> \<open>success requires compacteness\<close>
lemma pmc_success: \<open>K = Cn(A) \<Longrightarrow> \<phi> \<notin> Cn({}) \<Longrightarrow> \<phi> \<notin> K \<div>\<^bsub>\<gamma>\<^esub> \<phi>\<close>
proof
  assume a:\<open>K = Cn(A)\<close> and b:\<open>\<phi> \<notin> Cn({})\<close> and c:\<open>\<phi> \<in> K \<div>\<^bsub>\<gamma>\<^esub> \<phi>\<close>
  from c show False unfolding mc
  proof(cases \<open>K .\<bottom>. \<phi> = {K}\<close>)
    case True
    then show ?thesis
      by (meson assumption_L c nonconsequence_remainder pmc_inclusion[OF a] subsetD)
  next
    case False
    hence \<open>\<forall>B\<in>K .\<bottom>. \<phi>. \<phi> \<notin> B\<close> using assumption_L rem by auto
    moreover have \<open>K .\<bottom>. \<phi> \<noteq> {}\<close> using b emptyrem2taut validD_L by blast
    ultimately show ?thesis
      using b c mc nonempty_selection[OF a] validD_L emptyrem2taut is_selection[OF a]
      by (metis Inter_iff bot.extremum_uniqueI subset_iff)
  qed
qed

text\<open>As a partial meet contraction has been proven to respect all postulates of AGM contraction
the equivalence between the both are straightforward\<close>
sublocale AGM_Contraction where contraction = \<open>\<lambda>A \<phi>. A \<div>\<^bsub>\<gamma>\<^esub> \<phi>\<close>
  using pmc_closure pmc_inclusion pmc_vacuity
        pmc_success pmc_recovery pmc_extensionality
        expansion_def idempotency_L infer_def
  by (unfold_locales) metis+

end

locale AGMC_SC = AGM_Contraction + Supraclassical_logic + Compact_logic

begin

text \<open>obs 2.5 page 514\<close>
definition AGM_selection::\<open>'a set \<Rightarrow> 'a  \<Rightarrow> 'a set set\<close> (\<open>\<gamma>\<^sub>A\<^sub>G\<^sub>M\<close>)
  where AGM_sel: \<open>\<gamma>\<^sub>A\<^sub>G\<^sub>M A \<phi> \<equiv> if A .\<bottom>. \<phi> = {} then {A} else {B. B \<in> A .\<bottom>. \<phi> \<and> A \<div> \<phi> \<subseteq> B}\<close>

text\<open>The selection function @{term \<open>\<gamma>\<^sub>A\<^sub>G\<^sub>M\<close>} respect the partial meet contraction postulates\<close>
sublocale PartialMeetContraction where selection = \<gamma>\<^sub>A\<^sub>G\<^sub>M
proof(unfold_locales, unfold AGM_sel, simp_all, goal_cases)
  case (1 K A \<phi>) \<comment> \<open>@{text \<open>non_emptiness\<close>} of selection requires a compact logic\<close>
  then show ?case  using upper_remainder[of \<open>K \<div> \<phi>\<close> K \<phi>] contract_success[OF 1(1)]
    by (metis contract_closure contract_inclusion infer_def taut2emptyrem valid_def)
next
  case (2 K A \<phi> \<psi>)
  then show ?case
    by (metis (mono_tags, lifting) contract_extensionality Collect_cong remainder_extensionality)
qed

text \<open>@{text \<open>contraction_is_pmc\<close>} : an AGM contraction is equivalent to a partial met contraction using the selection function \<open>\<gamma>\<^sub>A\<^sub>G\<^sub>M\<close>\<close>
lemma contraction_is_pmc: \<open>K = Cn(A) \<Longrightarrow> K \<div> \<phi> = K \<div>\<^bsub>\<gamma>\<^sub>A\<^sub>G\<^sub>M\<^esub> \<phi>\<close> \<comment> \<open>requires a supraclassical logic\<close>
proof
  assume a:\<open>K = Cn(A)\<close>
  show \<open>K \<div> \<phi> \<subseteq> K \<div>\<^bsub>\<gamma>\<^sub>A\<^sub>G\<^sub>M\<^esub> \<phi>\<close>
    using contract_inclusion[OF a] by (auto simp add:mc AGM_sel)
next
  assume a:\<open>K = Cn(A)\<close>
  show \<open>K \<div>\<^bsub>\<gamma>\<^sub>A\<^sub>G\<^sub>M\<^esub> \<phi> \<subseteq> K \<div> \<phi>\<close>
  proof (cases \<open>\<tturnstile> \<phi>\<close>)
    case True
    hence \<open>K .\<bottom>. \<phi> = {}\<close>
      using nonconsequence_remainder taut2emptyrem by auto
    then show ?thesis
      apply(simp_all add:mc AGM_sel)
      by (metis a emptyrem2taut contract_closure contract_recovery valid_expansion)
  next
    case validFalse:False
    then show ?thesis
    proof (cases \<open>K \<turnstile> \<phi>\<close>)
      case True
      hence b:\<open>K .\<bottom>. \<phi> \<noteq> {}\<close>
        using emptyrem2taut validFalse by blast
      have d:\<open>\<psi> \<in> K \<Longrightarrow> \<phi> .\<longrightarrow>. \<psi> \<in> K \<div> \<phi>\<close> for \<psi>
        using Supraclassical_logic.impI_PL Supraclassical_logic_axioms a contract_closure contract_recovery expansion_def by fastforce
      { fix \<psi>
        assume e:\<open>\<psi> \<in> K \<close> and f:\<open>\<psi> \<notin> K \<div> \<phi>\<close>
        have \<open>(\<psi> .\<longrightarrow>. \<phi>) .\<longrightarrow>. \<phi> \<notin> K \<div> \<phi>\<close>
          using imp_recovery2[of \<open>K \<div> \<phi>\<close> \<phi> \<psi>] a contract_closure d e f by auto
        hence g:\<open>\<not> (K \<div> \<phi>) \<union> {\<psi> .\<longrightarrow>. \<phi>} \<turnstile> \<phi>\<close>
          using a contract_closure impI_PL by fastforce
        then obtain B where h:\<open>(K \<div> \<phi>) \<union> {\<psi> .\<longrightarrow>. \<phi>} \<subseteq> B\<close> and i:\<open>B \<in> K .\<bottom>. \<phi>\<close>
          using upper_remainder[of \<open>(K \<div> \<phi>) \<union> {\<psi> .\<longrightarrow>. \<phi>}\<close> K \<phi>] a True contract_inclusion idempotency_L impI2 by auto
        hence j:\<open>\<psi> \<notin> Cn(B)\<close>
          by (metis (no_types, lifting) CollectD mp_PL Un_insert_right a infer_def insert_subset rem rem_closure)
        have \<open>\<psi> \<notin>  K \<div>\<^bsub>\<gamma>\<^sub>A\<^sub>G\<^sub>M\<^esub> \<phi>\<close>
          apply(simp add:mc AGM_sel b, rule_tac x=B in exI)
          by (meson Tarskian_logic.assumption_L Tarskian_logic_axioms h i j le_sup_iff)
      }
      then show ?thesis
        using a pmc_inclusion by fastforce
    next
      case False
      hence \<open>K .\<bottom>. \<phi> = {K}\<close>
        using nonconsequence_remainder taut2emptyrem by auto
      then show ?thesis
        using False a contract_vacuity idempotency_L pmc_vacuity by auto
    qed
  qed
qed

lemma contraction_with_completion: \<open>K = Cn(A) \<Longrightarrow> K \<div> \<phi> = K \<div>\<^bsub>* \<gamma>\<^sub>A\<^sub>G\<^sub>M\<^esub> \<phi>\<close>
  by (simp add: contraction_is_pmc pmc_completion)

end

(* in case of doubt uncomment one of these\<in>
sublocale AGMC_SC \<subseteq> PMC_SC where selection = \<gamma>\<^sub>A\<^sub>G\<^sub>M\<^sub>C
  by (unfold_locales)

sublocale PMC_SC \<subseteq> AGMC_SC where contraction = \<open>\<lambda>A \<phi>. A \<div>\<^bsub>\<gamma>\<^esub> \<phi>\<close>
  by (unfold_locales)
*)

locale TRMC_SC = TransitivelyRelationalMeetContraction + PMC_SC where selection = \<gamma>\<^sub>T\<^sub>R

begin
text \<open>A transitively relational selection function respect conjuctive overlap.\<close>
lemma rel_sel_conj_overlap: \<open>K = Cn(A) \<Longrightarrow> \<gamma>\<^sub>T\<^sub>R K (\<phi> .\<and>. \<psi>) \<subseteq> \<gamma>\<^sub>T\<^sub>R K \<phi> \<union> \<gamma>\<^sub>T\<^sub>R K \<psi>\<close>
proof(intro subsetI)
  fix B
  assume a:\<open>K = Cn(A)\<close> and b:\<open>B \<in> \<gamma>\<^sub>T\<^sub>R K (\<phi> .\<and>. \<psi>)\<close>
  show \<open>B \<in> \<gamma>\<^sub>T\<^sub>R K \<phi> \<union> \<gamma>\<^sub>T\<^sub>R K \<psi>\<close> (is ?A)
  proof(cases \<open>\<tturnstile> \<phi> \<or> \<tturnstile> \<psi> \<or> \<not> K \<turnstile> \<phi> \<or> \<not> K \<turnstile> \<psi>\<close>, elim disjE)
    assume \<open>\<tturnstile> \<phi>\<close>
    hence c:\<open>Cn({\<phi> .\<and>. \<psi>}) = Cn({\<psi>})\<close>
      using conj_equiv valid_Cn_equiv valid_def by blast
    from b show ?A
      by (metis Un_iff a c extensional_selection)
  next
    assume \<open>\<tturnstile> \<psi>\<close>
    hence c:\<open>Cn({\<phi> .\<and>. \<psi>}) = Cn({\<phi>})\<close>
      by (simp add: Cn_conj_bis Cn_same validD_L)
    from b show ?A
      by (metis Un_iff a c extensional_selection)
  next
    assume \<open>\<not> K \<turnstile> \<phi>\<close>
    then show ?A
      by (metis UnI1 a b conjE1_PL is_selection nonconsequence_remainder nonempty_selection tautology_selection subset_singletonD)
  next
    assume \<open>\<not> K \<turnstile> \<psi>\<close>
    then show ?A
      by (metis UnI2 a b conjE2_PL is_selection nonconsequence_remainder nonempty_selection tautology_selection subset_singletonD)
  next
    assume d:\<open>\<not> (\<tturnstile> \<phi> \<or> \<tturnstile> \<psi> \<or> \<not> K \<turnstile> \<phi> \<or> \<not> K \<turnstile> \<psi>)\<close>
    hence h:\<open>K .\<bottom>. \<phi>  \<noteq> {}\<close> and i:\<open>K .\<bottom>. \<psi> \<noteq> {}\<close> and j:\<open>K .\<bottom>. (\<phi> .\<and>. \<psi>) \<noteq> {}\<close> and k:"K \<turnstile> \<phi> .\<and>. \<psi>"
      using d emptyrem2taut valid_conj_PL apply auto
      by (meson Supraclassical_logic.conjI_PL Supraclassical_logic_axioms d)
    show ?A
      using remainder_conj[OF a k] b h i j rel_sel by auto
  qed
qed

text\<open>A transitively relational meet contraction respect conjuctive overlap.\<close>
lemma trmc_conj_overlap: \<open>K = Cn(A) \<Longrightarrow> (K \<div>\<^bsub>\<gamma>\<^sub>T\<^sub>R\<^esub> \<phi>) \<inter> (K \<div>\<^bsub>\<gamma>\<^sub>T\<^sub>R\<^esub> \<psi>) \<subseteq> (K \<div>\<^bsub>\<gamma>\<^sub>T\<^sub>R\<^esub> (\<phi> .\<and>. \<psi>))\<close>
  unfolding mc using rel_sel_conj_overlap by blast

text\<open>A transitively relational selection function respect conjuctive inclusion\<close>
lemma rel_sel_conj_inclusion: \<open>K = Cn(A) \<Longrightarrow> \<gamma>\<^sub>T\<^sub>R K (\<phi> .\<and>. \<psi>) \<inter> (K .\<bottom>. \<phi>) \<noteq> {} \<Longrightarrow> \<gamma>\<^sub>T\<^sub>R K \<phi> \<subseteq> \<gamma>\<^sub>T\<^sub>R K (\<phi> .\<and>. \<psi>)\<close>
proof(intro subsetI)
  fix B
  assume a:\<open>K = Cn(A)\<close> and b:\<open>\<gamma>\<^sub>T\<^sub>R K (\<phi> .\<and>. \<psi>) \<inter> (K .\<bottom>. \<phi>) \<noteq> {}\<close> and c:\<open>B \<in> \<gamma>\<^sub>T\<^sub>R K \<phi>\<close>
  show \<open>B \<in> \<gamma>\<^sub>T\<^sub>R K (\<phi> .\<and>. \<psi>)\<close> (is ?A)
  proof(cases \<open>\<tturnstile> \<phi> \<or> \<tturnstile> \<psi> \<or> \<not> K \<turnstile> \<phi> \<or> \<not> K \<turnstile> \<psi>\<close>, auto)
    assume \<open>\<tturnstile> \<phi>\<close>
    then show ?A
      using b taut2emptyrem by auto
  next
    assume \<open>\<tturnstile> \<psi>\<close>
    hence \<open>Cn({\<phi> .\<and>. \<psi>}) = Cn({\<phi>})\<close>
      by (simp add: Cn_conj_bis Cn_same validD_L)
    then show ?A
      using a c extensional_selection by blast
  next
    assume d:\<open>\<phi> \<notin> Cn K\<close>
    with d show ?A
      by (metis Int_emptyI Tarskian_logic.nonconsequence_remainder Tarskian_logic_axioms a b c idempotency_L
                inf_bot_right is_selection nonempty_selection singletonD subset_singletonD)
  next
    assume d:\<open>\<psi> \<notin> Cn K\<close>
    hence e:\<open>(\<phi> .\<and>. \<psi>) \<notin> Cn K\<close>
      by (meson Supraclassical_logic.conjE2_PL Supraclassical_logic_axioms)
    hence f:\<open>\<gamma>\<^sub>T\<^sub>R K (\<phi> .\<and>. \<psi>) = {K}\<close>
      by (metis Tarskian_logic.nonconsequence_remainder Tarskian_logic_axioms a insert_not_empty is_selection
                nonempty_selection subset_singletonD)
    with b have g:\<open>(K .\<bottom>. \<phi>) = {K}\<close>
      unfolding nonconsequence_remainder[symmetric] using rem by auto
    with d f show ?A
      using a c is_selection by fastforce
  next
    assume d:\<open>\<not> \<tturnstile> \<phi>\<close> and e:\<open>\<not> \<tturnstile> \<psi>\<close> and f:\<open>\<phi> \<in> Cn K\<close> and g:\<open>\<psi> \<in> Cn K\<close>
    hence h:\<open>K .\<bottom>. \<phi>  \<noteq> {}\<close> and i:\<open>K .\<bottom>. \<psi> \<noteq> {}\<close> and j:\<open>K .\<bottom>. (\<phi> .\<and>. \<psi>) \<noteq> {}\<close> and k:"K \<turnstile> \<phi> .\<and>. \<psi>"
      using e d emptyrem2taut valid_conj_PL apply auto
      by (meson Supraclassical_logic.conjI_PL Supraclassical_logic_axioms f g)
    have o:\<open>B \<in> K .\<bottom>. \<phi> \<Longrightarrow> B \<in> K .\<bottom>. (\<phi> .\<and>. \<psi>)\<close> for B
      using a k remainder_conj by auto
    from b obtain B' where l:\<open>B' \<in> K .\<bottom>. (\<phi> .\<and>. \<psi>)\<close> and m:\<open>\<forall>C\<in>K .\<bottom>. (\<phi> .\<and>. \<psi>). C \<preceq>\<^bsub>K\<^esub> B'\<close> and n:\<open>\<phi> \<notin> B'\<close>
      apply (auto simp add:mc rel_sel j)
      using assumption_L rem by force
    have p:\<open>B' \<in> K .\<bottom>. \<phi>\<close>
      apply(simp add: rem)
      by (metis (no_types, lifting) Supraclassical_logic.conjE1_PL Supraclassical_logic_axioms
                Tarskian_logic.rem Tarskian_logic_axioms a l mem_Collect_eq n rem_closure)
    from c show ?A
      apply (simp add:rel_sel o j h)
      using m p trans_rel a by blast
  qed
qed

text\<open>A transitively relational meet contraction respect conjuctive inclusion\<close>
lemma trmc_conj_inclusion: \<open>K = Cn(A) \<Longrightarrow> \<phi> \<notin> (K \<div>\<^bsub>\<gamma>\<^sub>T\<^sub>R\<^esub> (\<phi> .\<and>. \<psi>)) \<Longrightarrow> ((K \<div>\<^bsub>\<gamma>\<^sub>T\<^sub>R\<^esub> (\<phi> .\<and>. \<psi>) \<subseteq> (K \<div>\<^bsub>\<gamma>\<^sub>T\<^sub>R\<^esub> \<phi>)))\<close>
proof -
  assume a:\<open>K = Cn(A)\<close> and b:\<open>\<phi> \<notin> (K \<div>\<^bsub>\<gamma>\<^sub>T\<^sub>R\<^esub> (\<phi> .\<and>. \<psi>))\<close>
  then obtain B where c:\<open>B \<in> \<gamma>\<^sub>T\<^sub>R K (\<phi> .\<and>. \<psi>)\<close> and d:\<open>\<not> B \<turnstile> \<phi>\<close> apply(simp add:mc)
    by (metis b emptyrem2taut is_selection pmc_tautology rem_closure subset_iff validD_L valid_conj_PL)
  hence \<open>B \<in> (K .\<bottom>. \<phi>)\<close>
    using remainder_recovery_bis[OF a _ d, of \<open>\<phi> .\<and>. \<psi>\<close>]
    by (metis (no_types, opaque_lifting) a conj_PL emptyrem2taut insert_not_empty is_selection
                                         nonconsequence_remainder subsetD taut2emptyrem)
  with c have e:\<open>\<gamma>\<^sub>T\<^sub>R K (\<phi> .\<and>. \<psi>) \<inter> (K .\<bottom>. \<phi>) \<noteq> {}\<close> by blast
  then show \<open>((K \<div>\<^bsub>\<gamma>\<^sub>T\<^sub>R\<^esub> (\<phi> .\<and>. \<psi>) \<subseteq> (K \<div>\<^bsub>\<gamma>\<^sub>T\<^sub>R\<^esub> \<phi>)))\<close>
    unfolding mc using rel_sel_conj_inclusion[OF a e] by blast
qed

text\<open>As a transitively relational meet contraction has been proven to respect all postulates of AGM full contraction
the equivalence between the both are straightforward\<close>
sublocale AGM_FullContraction where contraction = \<open>\<lambda>A \<phi>. A  \<div>\<^bsub>\<gamma>\<^sub>T\<^sub>R\<^esub> \<phi>\<close>
  using trmc_conj_inclusion trmc_conj_overlap
  by (unfold_locales, simp_all)

end

locale AGMFC_SC = AGM_FullContraction + AGMC_SC

begin

text\<open>An AGM relation is defined as ?\<close>
definition AGM_relation::\<open>'a set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool\<close>
  where AGM_rel: \<open>AGM_relation C K B  \<equiv> (C = K \<and> B = K) \<or> (  (\<exists>\<phi>. K \<turnstile> \<phi> \<and> C \<in> K .\<bottom>. \<phi>)
                                                            \<and> (\<exists>\<phi>. K \<turnstile> \<phi> \<and> B \<in> K .\<bottom>. \<phi> \<and>  K \<div> \<phi> \<subseteq> B)
                                                            \<and> (\<forall>\<phi>. (K \<turnstile> \<phi> \<and> C \<in> K .\<bottom>. \<phi> \<and> B \<in> K .\<bottom>. \<phi> \<and> K \<div> \<phi> \<subseteq> C) \<longrightarrow> K \<div> \<phi> \<subseteq> B))\<close>
text\<open>An AGM relational selection is defined as a function that return @{term \<open>K\<close>} if the remainders of @{text \<open>K .\<bottom>. \<phi>\<close>} is empty and
the best element of the remainders according to an AGM relation\<close>
definition AGM_relational_selection::\<open>'a set \<Rightarrow> 'a  \<Rightarrow> 'a set set\<close> (\<open>\<gamma>\<^sub>A\<^sub>G\<^sub>M\<^sub>T\<^sub>R\<close>)
  where AGM_rel_sel: \<open>\<gamma>\<^sub>A\<^sub>G\<^sub>M\<^sub>T\<^sub>R  K \<phi> \<equiv> if (K .\<bottom>. \<phi>) = {}
                                   then {K}
                                   else {B. B\<in>(K .\<bottom>. \<phi>) \<and> (\<forall>C\<in>(K .\<bottom>. \<phi>). AGM_relation C K B)}\<close>

lemma AGM_rel_sel_completion: \<open>K = Cn(A) \<Longrightarrow> \<gamma>\<^sub>A\<^sub>G\<^sub>M\<^sub>T\<^sub>R K \<phi> = * \<gamma>\<^sub>A\<^sub>G\<^sub>M K \<phi>\<close>
  apply (unfold AGM_rel_sel, simp add:completion_def split: if_splits)
proof(auto simp add:AGM_sel)
  fix S B C
  assume a:\<open>S \<in> Cn(A) .\<bottom>. \<phi>\<close> and b:\<open>B \<in> Cn(A) .\<bottom>. \<phi>\<close> and c:\<open>\<Inter> {B \<in> Cn(A) .\<bottom>. \<phi>. Cn(A) \<div> \<phi> \<subseteq> B} \<subseteq> B\<close>
     and d:\<open>C \<in> Cn(A) .\<bottom>. \<phi>\<close>
  hence e:\<open>\<phi> \<notin>  Cn(A) \<div> \<phi>\<close>
    using Tarskian_logic.taut2emptyrem Tarskian_logic_axioms contract_success by fastforce
  show \<open>AGM_relation C (Cn(A)) B\<close>
  proof(cases \<open>\<phi> \<in> Cn(A)\<close>)
    case True
    { fix \<psi>
      assume \<open>Cn A \<div> \<psi> \<subseteq> C\<close>
      hence \<open>Cn A \<div> (\<phi> .\<and>. \<psi>) \<subseteq> Cn A \<div> \<phi>\<close>
        using contract_conj_inclusion_variant[of \<open>Cn(A)\<close> A \<phi> \<psi>]
        by (metis (mono_tags, lifting) assumption_L contract_conj_inclusion d mem_Collect_eq rem subset_iff)
    } note f = this
    { fix \<psi> \<phi>'
      assume g:\<open>\<psi> \<in> Cn A \<div> \<phi>'\<close> and h:\<open>B \<in> Cn A .\<bottom>. \<phi>'\<close> and j:\<open>Cn A \<div> \<phi>' \<subseteq> C\<close> and i:\<open>\<psi> \<notin> B\<close>
      hence \<open>\<phi>' .\<or>. \<psi> \<in> Cn A \<div> \<phi>'\<close>
        using Supraclassical_logic.disjI2_PL Supraclassical_logic_axioms contract_closure by fastforce
      hence k:\<open>\<phi>' .\<or>. \<psi> \<in> Cn A \<div> \<phi>\<close>
        using contract_conj_overlap_variant[of \<open>Cn(A)\<close> A \<phi>' \<phi>] f[OF j]
        by (metis IntI Supraclassical_logic.disjI1_PL Supraclassical_logic_axioms conj_com_Cn
                  contract_extensionality inclusion_L singletonI subsetD)
      hence l:\<open>Cn A \<div> \<phi> \<subseteq> B\<close> using c by auto
      from k l have m:\<open>\<phi>' .\<or>. \<psi> \<in> B\<close> and n:\<open>B =Cn(B)\<close>
        using b rem_closure by blast+
      have \<open>B \<union> {\<psi>} \<turnstile> \<phi>'\<close> using g h i
        by (simp add:rem) (metis contract_inclusion insertI1 insert_subsetI psubsetI subsetD subset_insertI)
      with n m have  \<open>B \<turnstile> \<phi>'\<close>
        by (metis Cn_equiv assumption_L disjE_PL disj_com equiv_PL imp_PL)
      with h have False
        using assumption_L rem by auto
    } note g = this
    with True show ?thesis
      apply(unfold AGM_rel, rule_tac disjI2)
      using d b c by (auto simp add:AGM_rel idempotency_L del:subsetI) blast+
  next
    case False
    then show ?thesis
      by (metis AGM_rel b d idempotency_L infer_def nonconsequence_remainder singletonD)
    qed
next
  fix S B \<psi>
  assume a:\<open>S \<in> Cn(A) .\<bottom>. \<phi>\<close> and b:\<open>B \<in> Cn(A) .\<bottom>. \<phi>\<close> and c:\<open>\<forall>C\<in>Cn A .\<bottom>. \<phi>. AGM_relation C (Cn A) B\<close>
     and d:\<open>\<forall>C'. C' \<in> Cn A .\<bottom>. \<phi> \<and> Cn A \<div> \<phi> \<subseteq> C' \<longrightarrow> \<psi> \<in> C'\<close>
  then show \<open>\<psi> \<in> B\<close>
    unfolding AGM_rel
    by (metis (no_types, lifting) AGM_sel empty_Collect_eq insert_Diff insert_not_empty
              nonconsequence_remainder nonempty_selection singletonD)
qed

text\<open>A transitively relational selection and an AGM relation is a transitively relational meet contraction\<close>
sublocale TransitivelyRelationalMeetContraction where relation = AGM_relation and rel_sel = \<open>\<gamma>\<^sub>A\<^sub>G\<^sub>M\<^sub>T\<^sub>R\<close>
proof(unfold_locales, simp_all (no_asm) only:atomize_eq, goal_cases)
  case a:(1 K A C B' B) \<comment> \<open>Very difficult proof requires litterature and high automation of isabelle!\<close>
  from a(2,3) show ?case
    unfolding AGM_rel apply(elim disjE conjE, simp_all)
  proof(intro disjI2 allI impI, elim exE conjE, goal_cases)
    case (1 \<psi> _ _ \<phi>)
    have b:\<open>B \<in> K .\<bottom>. (\<phi> .\<and>. \<psi>)\<close> and c:\<open>B' \<in> K .\<bottom>. (\<phi> .\<and>. \<psi>)\<close> and d:\<open>C \<in> K .\<bottom>. (\<phi> .\<and>. \<psi>)\<close>
      using remainder_conj[OF a(1)] 1 conjI_PL by auto
    hence e:\<open>K \<div> (\<phi> .\<and>. \<psi>) \<subseteq> B\<close>
      using contract_conj_inclusion_variant[OF a(1), of \<phi>  \<psi>]
      by (meson "1"(1) "1"(12) "1"(16) "1"(2) "1"(3) "1"(8) Supraclassical_logic.conj_PL
                Supraclassical_logic_axioms dual_order.trans)
    { fix \<chi>
      assume f:\<open>\<chi> \<in> K \<div> \<psi>\<close>
      have \<open>\<psi> .\<or>. \<chi> \<in> (K \<div> \<psi>) \<inter> Cn {\<psi>}\<close>
        by (metis Int_iff Supraclassical_logic.disjI1_PL Supraclassical_logic.disjI2_PL Supraclassical_logic_axioms
                  f a(1) contract_closure in_mono inclusion_L singletonI)
      hence g:\<open>\<psi> .\<or>. \<chi> \<in> B\<close>
        using contract_conj_overlap_variant[OF a(1), of \<psi>]
        by (metis AGM_Contraction.contract_extensionality AGM_Contraction_axioms a(1) conj_com_Cn e in_mono)
      have \<open>\<psi> .\<longrightarrow>. \<chi> \<in> B\<close>
        by (metis a(1) "1"(10) "1"(15) "1"(16) assumption_L f in_mono infer_def rem_closure rem_inclusion remainder_recovery)
      with g have \<open>\<chi> \<in> B\<close>
        by (metis 1(15) a(1) disjE_PL infer_def order_refl rem_closure validD_L valid_Cn_imp)
    }
    then show ?case by blast
  qed
next
  case (2 K A \<phi>)
  hence \<open>* \<gamma>\<^sub>A\<^sub>G\<^sub>M  K \<phi> \<noteq> {}\<close>
    using nonempty_selection[OF 2(1), of \<phi>] selection_completion[OF 2(1), of \<phi>] by blast
  then show ?case
    using AGM_rel_sel_completion[OF 2(1), of \<phi>] AGM_rel_sel 2(1,2) by force
next
  case (3 K \<phi>)
  then show ?case using AGM_rel_sel_completion AGM_rel_sel by simp
qed

\<comment> \<open>ça marche tout seul! ==> Je ne vois pas où sont utilisés ces lemmas\<close>
lemmas fullcontraction_is_pmc = contraction_is_pmc
lemmas fullcontraction_is_trmc = contraction_with_completion

end

locale FMC_SC = FullMeetContraction + TRMC_SC

begin

lemma full_meet_weak1: \<open>K = Cn(A) \<Longrightarrow> K \<turnstile> \<phi> \<Longrightarrow> (K \<div>\<^bsub>\<gamma>\<^sub>F\<^sub>C\<^esub> \<phi>) = K \<inter> Cn({.\<not> \<phi>})\<close>
proof(intro subset_antisym Int_greatest)
  assume a:\<open>K = Cn(A)\<close> and b:\<open>K \<turnstile> \<phi>\<close>
  then show \<open> (K \<div>\<^bsub>\<gamma>\<^sub>F\<^sub>C\<^esub> \<phi>) \<subseteq> K\<close>
    by (simp add: Inf_less_eq full_sel mc rem_inclusion)
next
  assume a:\<open>K = Cn(A)\<close> and b:\<open>K \<turnstile> \<phi>\<close>
  show \<open>(K \<div>\<^bsub>\<gamma>\<^sub>F\<^sub>C\<^esub> \<phi>) \<subseteq> Cn({.\<not> \<phi>})\<close>
  proof
    fix \<psi>
    assume c:\<open>\<psi> \<in> (K \<div>\<^bsub>\<gamma>\<^sub>F\<^sub>C\<^esub> \<phi>)\<close>
    { assume \<open>\<not> {.\<not> \<phi>} \<turnstile> \<psi>\<close>
      hence \<open>\<not> {.\<not> \<psi>} \<turnstile> \<phi>\<close>
        by (metis Un_insert_right insert_is_Un not_PL notnot_PL)
      hence \<open>\<not> {\<phi> .\<or>. .\<not> \<psi>} \<turnstile> \<phi>\<close>
        by (metis assumption_L disjI2_PL singleton_iff transitivity2_L)
      then obtain B where d:\<open>{\<phi> .\<or>. .\<not> \<psi>} \<subseteq> B\<close> and e:\<open>B \<in> K .\<bottom>. \<phi>\<close>
        by (metis a b disjI1_PL empty_subsetI idempotency_L infer_def insert_subset upper_remainder)
      hence f:\<open>\<not> \<psi> \<in> B\<close>
        by (metis (no_types, lifting) CollectD assumption_L insert_subset disj_notE_PL rem)
      hence \<open>\<not> \<psi> \<in> (K \<div>\<^bsub>\<gamma>\<^sub>F\<^sub>C\<^esub> \<phi>)\<close>
        using e mc full_sel by auto
    }
    then show \<open>\<psi> \<in> Cn({.\<not> \<phi>})\<close>
      using c infer_def by blast
  qed
next
  assume a:\<open>K = Cn(A)\<close> and b:\<open>K \<turnstile> \<phi>\<close>
  show \<open>K \<inter> Cn({.\<not> \<phi>}) \<subseteq> (K \<div>\<^bsub>\<gamma>\<^sub>F\<^sub>C\<^esub> \<phi>)\<close>
  proof(safe)
    fix \<psi>
    assume c:\<open>\<psi> \<in> K\<close> and d: \<open>\<psi> \<in> Cn {.\<not> \<phi>}\<close>
    have e:\<open>B \<turnstile> .\<not> \<phi> .\<longrightarrow>. \<psi>\<close> for B
      by (simp add: d validD_L valid_imp_PL)
    { fix B
      assume f:\<open>B \<in> K .\<bottom>. \<phi>\<close>
      hence \<open>B \<turnstile> \<phi> .\<longrightarrow>. \<psi>\<close>
        using a assumption_L c remainder_recovery by auto
      then have f:\<open>B \<turnstile> \<psi>\<close> using d e
        using disjE_PL ex_mid_PL by blast
    }
    then show \<open>\<psi> \<in> (K \<div>\<^bsub>\<gamma>\<^sub>F\<^sub>C\<^esub> \<phi>)\<close>
      apply(simp_all add:mc c full_sel)
      using a rem_closure by blast
  qed
qed

lemma full_meet_weak2:\<open>K = Cn(A) \<Longrightarrow> K \<turnstile> \<phi> \<Longrightarrow> Cn((K \<div>\<^bsub>\<gamma>\<^sub>F\<^sub>C\<^esub> \<phi>) \<union> {.\<not> \<phi>}) = Cn({.\<not> \<phi>})\<close>
  unfolding full_meet_weak1
  by (metis Cn_union idempotency_L inf.cobounded2 sup.absorb_iff2 sup_commute)

end

end


(*  File:       Drop_Module.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Karsten Diekhoff, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Jonas Kraemer, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Drop Module\<close>

theory Drop_Module
  imports "Component_Types/Electoral_Module"
begin

text \<open>
  This is a family of electoral modules. For a natural number n and a
  lexicon (linear order) r of all alternatives, the according drop module
  rejects the lexicographically first n alternatives (from A) and
  defers the rest.
  It is primarily used as counterpart to the pass module in a
  parallel composition, in order to segment the alternatives into
  two groups.
\<close>

subsection \<open>Definition\<close>

fun drop_module :: "nat \<Rightarrow> 'a Preference_Relation \<Rightarrow> 'a Electoral_Module" where
  "drop_module n r A p =
    ({},
    {a \<in> A. card(above (limit A r) a) \<le> n},
    {a \<in> A. card(above (limit A r) a) > n})"

subsection \<open>Soundness\<close>

theorem drop_mod_sound[simp]: "electoral_module (drop_module n r)"
proof (intro electoral_modI)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  let ?mod = "drop_module n r"
  have
    "(\<forall> a \<in> A. a \<in> {x \<in> A. card(above (limit A r) x) \<le> n} \<or>
        a \<in> {x \<in> A. card(above (limit A r) x) > n})"
    by auto
  hence
    "{a \<in> A. card(above (limit A r) a) \<le> n} \<union>
        {a \<in> A. card(above (limit A r) a) > n} = A"
    by blast
  hence 0: "set_equals_partition A (drop_module n r A p)"
    by simp
  have
    "(\<forall> a \<in> A. \<not>(a \<in> {x \<in> A. card(above (limit A r) x) \<le> n} \<and>
        a \<in> {x \<in> A. card(above (limit A r) x) > n}))"
    by auto
  hence
    "{a \<in> A. card(above (limit A r) a) \<le> n} \<inter>
        {a \<in> A. card(above (limit A r) a) > n} = {}"
    by blast
  hence 1: "disjoint3 (?mod A p)"
    by simp
  from 0 1 show "well_formed A (?mod A p)"
    by simp
qed

subsection \<open>Non-Electing\<close>

text \<open>
  The drop module is non-electing.
\<close>

theorem drop_mod_non_electing[simp]:
  assumes "linear_order r"
  shows "non_electing (drop_module n r)"
  unfolding non_electing_def
  using assms
  by simp

subsection \<open>Properties\<close>

text \<open>
  The drop module is strictly defer-monotone.
\<close>

theorem drop_mod_def_lift_inv[simp]:
  assumes "linear_order r"
  shows "defer_lift_invariance (drop_module n r)"
  unfolding defer_lift_invariance_def
  using assms
  by simp

end