theory Philosophers imports Main begin

text \<open>Exercise 1 The Strict Positive Paradox\<close>

lemma strict_positive_paradox: "A \<longrightarrow> B \<longrightarrow> B"
proof (rule impI)
  show "B \<longrightarrow> B"
  proof (rule impI)
    assume "B"
    thus "B" .
  qed
qed

text \<open>Exercise 2\<close>

lemma prefixing: "(A \<longrightarrow> B) \<longrightarrow> (C \<longrightarrow> A) \<longrightarrow> (C \<longrightarrow> B)"
proof (rule impI)
  assume "A \<longrightarrow> B"
  show "(C \<longrightarrow> A) \<longrightarrow> (C \<longrightarrow> B)"
  proof (rule impI)
    assume "C \<longrightarrow> A"
    show "C \<longrightarrow> B"
    proof (rule impI)
      assume "C"
      with \<open>C \<longrightarrow> A\<close> have "A" by (rule mp)
      thus "B" using \<open>A \<longrightarrow> B\<close> by (rule rev_mp)
    qed
  qed
qed

lemma suffixing: "(A \<longrightarrow> B) \<longrightarrow> (B \<longrightarrow> C) \<longrightarrow> (A \<longrightarrow> C)"
proof (rule impI)
  assume "A \<longrightarrow> B"
  show "(B \<longrightarrow> C) \<longrightarrow> (A \<longrightarrow> C)"
  proof (rule impI)
    assume "B \<longrightarrow> C"
    show "A \<longrightarrow> C"
    proof (rule impI)
      assume "A"
      with \<open>A \<longrightarrow> B\<close> have "B" by (rule mp)
      thus "C" using \<open>B \<longrightarrow> C\<close> by (rule rev_mp)
    qed
  qed
qed

text \<open>Exercise 3\<close>

lemma "(A \<longleftrightarrow> B) \<longleftrightarrow> (B \<longleftrightarrow> A)"
proof (rule iffI)
  assume "A \<longleftrightarrow> B"
  show "B \<longleftrightarrow> A"
  proof (rule iffI)
    assume "B"
    with \<open>A \<longleftrightarrow> B\<close> show "A" by (rule iffD2)
  next
    assume "A"
    with \<open>A \<longleftrightarrow> B\<close> show "B" by (rule iffD1)
  qed
next
  assume "B \<longleftrightarrow> A"
  show "A \<longleftrightarrow> B"
  proof (rule iffI)
    assume "A"
    with \<open>B \<longleftrightarrow> A\<close> show "B" by (rule iffD2)
  next
    assume "B"
    with \<open>B \<longleftrightarrow> A\<close> show "A" by (rule iffD1)
  qed
qed

text \<open>Exercise 4 Strengthening the Antecedent\<close>

lemma strengthening_the_antecendent: "(A \<longrightarrow> C) \<longrightarrow>(A \<and> B \<longrightarrow> C)"
proof (rule impI)
  assume "A \<longrightarrow> C"
  show "A \<and> B \<longrightarrow> C"
  proof (rule impI)
    assume "A \<and> B"
    hence "A" by (rule conjE)
    with \<open>A \<longrightarrow> C\<close> show "C" by (rule mp)
  qed
qed

text \<open>Exercise 5\<close>

lemma "(A \<longrightarrow> B) \<longrightarrow> (A \<longrightarrow> C) \<longrightarrow> (A \<longrightarrow> B \<and> C)"
proof (rule impI)
  assume "A \<longrightarrow> B"
  show "(A \<longrightarrow> C) \<longrightarrow> (A \<longrightarrow> B \<and> C)"
  proof
    assume "A \<longrightarrow> C"
    show "A \<longrightarrow> B \<and> C"
    proof (rule impI)
      assume "A"
      then have "C" using \<open>A \<longrightarrow> C\<close> by (rule rev_mp)
      from \<open>A \<longrightarrow> B\<close> \<open>A\<close> have "B" by (rule mp)
      thus "B \<and> C" using \<open>C\<close> by (rule conjI)
    qed
  qed
qed

text \<open>Exercise 6\<close>

lemma "(A \<longrightarrow> B) \<longrightarrow> (A \<longrightarrow> B \<or> C)"
proof
  assume "A \<longrightarrow> B"
  show "A \<longrightarrow> B \<or> C"
  proof
    assume "A"
    with \<open>A \<longrightarrow> B\<close> have "B" by (rule mp)
    thus "B \<or> C" by (rule disjI1)
  qed
qed

text \<open>Exercise 7\<close>

lemma "(A \<longrightarrow> C) \<and> (B \<longrightarrow> C) \<longrightarrow> (A \<or> B \<longrightarrow> C)"
proof
  assume antecedence: "(A \<longrightarrow> C) \<and> (B \<longrightarrow> C)"
  show "A \<or> B \<longrightarrow> C"
  proof
    assume "A \<or> B"
    show "C"
    proof (rule disjE)
      show "A \<or> B" using \<open>A \<or> B\<close> .
    next
      assume "A"
      from antecedence have "A \<longrightarrow> C" by (rule conjE)
      thus "C" using \<open>A\<close> by (rule mp)
    next
      assume "B"
      from antecedence have "B \<longrightarrow> C" by (rule conjE)
      with \<open>B\<close> show "C" by (rule rev_mp)
    qed
  qed
qed

text \<open>Exercise 8 The Associativity of Disjunction\<close>

lemma "A \<or> B \<or> C \<longleftrightarrow> (A \<or> B) \<or> C"
proof
  assume "A \<or> B \<or> C"
  show "(A \<or> B) \<or> C"
  proof (rule disjE)
    show "A \<or> B \<or> C" using \<open>A \<or> B \<or> C\<close> .
  next
    assume "A"
    hence "A \<or> B" by (rule disjI1)
    thus "(A \<or> B) \<or> C" ..
  next
    assume "B \<or> C"
    thus "(A \<or> B) \<or> C"
    proof (rule disjE)
      assume "B"
      hence "A \<or> B"  by (rule disjI2)
      thus "(A \<or> B) \<or> C" ..
    next
      assume "C"
      thus "(A \<or> B) \<or> C" ..
    qed
  qed
next
  assume "(A \<or> B) \<or> C"
  thus "A \<or> B \<or> C"
  proof
    assume "A \<or> B"
    thus "A \<or> B \<or> C"
    proof
      assume "A"
      thus "A \<or> B \<or> C" ..
    next
      assume "B"
      hence "B \<or> C" ..
      thus "A \<or> B \<or> C" ..
    qed
  next
    assume "C"
    hence "B \<or> C" ..
    thus "A \<or> B \<or> C" ..
  qed
qed

text \<open>Exercise 9\<close>

lemma "A \<or> B \<and> C \<longrightarrow> (A \<or> B) \<and> (A \<or> C)"
proof
  assume "A \<or> B \<and> C"
  thus "(A \<or> B) \<and> (A \<or> C)"
  proof
    assume "A"
    hence "A \<or> B" by (rule disjI1)
    from \<open>A\<close> have "A \<or> C" ..
    with \<open>A \<or> B\<close> show "(A \<or> B) \<and> (A \<or> C)" by (rule conjI)
  next
    assume "B \<and> C"
    hence "B" by (rule conjE)
    hence "A \<or> B" ..
    have "C" using \<open>B \<and> C\<close> ..
    hence "A \<or> C" ..
    with \<open>A \<or> B\<close> show "(A \<or> B) \<and> (A \<or> C)" ..
  qed
qed

text \<open>Exercise 10 Explosion\<close>

lemma explosion: "A \<and> \<not> A \<longrightarrow> B"
proof
  assume "A \<and> \<not> A"
  hence "A" by (rule conjE)
  have "\<not> A" using \<open>A \<and> \<not> A\<close> ..
  thus "B" using \<open>A\<close> by (rule notE)
qed

text \<open>Exercise 11\<close>

lemma "A \<or> B \<longrightarrow> \<not> A \<longrightarrow> B"
proof
  assume "A \<or> B"
  thus "\<not> A \<longrightarrow> B"
  proof
    assume "A"
    show "\<not> A \<longrightarrow> B"
    proof
      assume "\<not> A"
      thus "B" using \<open>A\<close> ..
    qed
  next
    assume "B"
    show "\<not> A \<longrightarrow> B"
    proof
      show "B" using \<open>B\<close> .
    qed
  qed
qed

text \<open>Exercise 12\<close>

lemma "A \<longrightarrow> \<not> \<not> A"
proof
  assume "A"
  show "\<not> \<not> A"
  proof (rule notI)
    assume "\<not> A"
    thus "False" using \<open>A\<close> by (rule notE)
  qed
qed

text \<open>Exercise 13\<close>

lemma "\<not> \<not> (A \<or> \<not> A)"
proof (rule notI)
  assume "\<not> (A \<or> \<not> A)"
  moreover have "A \<or> \<not> A"
  proof (rule disjI2)
    show "\<not> A "
    proof (rule notI)
      assume "A"
      hence "A \<or> \<not> A" by (rule disjI1)
      with \<open>\<not> (A \<or> \<not> A)\<close> show "False" by (rule notE)
    qed
  qed
  ultimately show "False" ..
qed

text \<open>Exercise 14 The Law of Excluded Middle\<close>

lemma excluded_middle: "A \<or> \<not> A"
proof (rule ccontr)
  assume "\<not> (A \<or> \<not> A)"
  moreover have "A \<or> \<not> A"
  proof (rule disjI2)
    show "\<not> A "
    proof (rule notI)
      assume "A"
      hence "A \<or> \<not> A" by (rule disjI1)
      with \<open>\<not> (A \<or> \<not> A)\<close> show "False" by (rule notE)
    qed
  qed
  ultimately show "False" ..
qed

text \<open>Exercise 15 Conditional Excluded Middle\<close>

lemma "(A \<longrightarrow> B) \<or> (A \<longrightarrow> \<not> B)"
proof cases
  assume "B"
  have "A \<longrightarrow> B"
  proof
    show "B" using \<open>B\<close> .
  qed
  thus "(A \<longrightarrow> B) \<or> (A \<longrightarrow> \<not> B)" ..
next
  assume "\<not> B"
  have "A \<longrightarrow> \<not> B"
  proof
    show "\<not> B" using \<open>\<not> B\<close> .
  qed
  thus "(A \<longrightarrow> B) \<or> (A \<longrightarrow> \<not> B)" ..
qed

text \<open>Exercise 16\<close>

lemma "(A \<longrightarrow> B) \<or> (B \<longrightarrow> A)"
proof cases
  assume "A \<longrightarrow> B"
  then show "(A \<longrightarrow> B) \<or> (B \<longrightarrow> A)" ..
next
  assume "\<not> (A \<longrightarrow> B)"
  have "A"
  proof (rule ccontr)
    assume "\<not> A"
    have "A \<longrightarrow> B"
    proof
      assume "A"
      show "B"
      proof (rule ccontr)
        from \<open>\<not> A\<close> \<open>A\<close> show "False" ..
      qed
    qed
    with \<open>\<not> (A \<longrightarrow> B)\<close> show "False" ..
  qed
  have "B \<longrightarrow> A"
  proof
    show "A" using \<open>A\<close> .
  qed
  thus "(A \<longrightarrow> B) \<or> (B \<longrightarrow> A)" ..
qed

text \<open>Exercise 17\<close>

lemma "(A \<or> B) \<and> (A \<or> C) \<longrightarrow> A \<or> B \<and> C"
proof
  assume "(A \<or> B) \<and> (A \<or> C)"
  show "A \<or> B \<and> C"
  proof cases
    assume "A"
    thus "A \<or> B \<and> C" ..
  next
    assume "\<not> A"
    have "B \<and> C"
    proof
      show "B"
      proof (rule ccontr)
        assume "\<not> B"
        have "\<not> (A \<or> B)"
        proof
          assume "A \<or> B"
          thus "False"
          proof
            assume "A"
            with \<open>\<not> A\<close> show "False" ..
          next
            assume "B"
            with \<open>\<not> B\<close> show "False" ..
          qed
        qed
        have "A \<or> B" using \<open>(A \<or> B) \<and> (A \<or> C)\<close> ..
        with \<open>\<not> (A \<or> B)\<close> show "False" ..
      qed
    next
      show "C"
      proof (rule ccontr)
        assume "\<not> C"
        have "\<not> (A \<or> C)"
        proof
          assume "A \<or> C"
          thus "False"
          proof
            assume "A"
            with \<open>\<not> A\<close> show "False" ..
          next
            assume "C"
            with \<open>\<not> C\<close> show "False" ..
          qed
        qed
        have "A \<or> C" using \<open>(A \<or> B) \<and> (A \<or> C)\<close> ..
        with \<open>\<not> (A \<or> C)\<close> show "False" ..
      qed
    qed
    thus "A \<or> B \<and> C" ..
  qed
qed

text \<open>Exercise 18 The Equivalence Thesis\<close>

lemma "(A \<longrightarrow> B) \<longleftrightarrow> (\<not> A \<or> B)"
proof
  assume "A \<longrightarrow> B"
  show "\<not> A \<or> B"
  proof cases
    assume "B"
    thus "\<not> A \<or> B" ..
  next
    assume "\<not> B"
    have "\<not> A"
    proof
      assume "A"
      with \<open>A \<longrightarrow> B\<close> have "B" by (rule mp)
      with \<open>\<not> B\<close> show "False" ..
    qed
    thus "\<not> A \<or> B" ..
  qed
next
  assume "\<not> A \<or> B"
  show "A \<longrightarrow> B"
  proof cases
    assume "B"
    show "A \<longrightarrow> B"
    proof
      show "B" using \<open>B\<close> .
    qed
  next
    assume "\<not> B"
    have "\<not> A"
    proof
      assume "A"
      have "\<not> (\<not> A \<or> B)"
      proof
        assume "\<not> A \<or> B"
        thus "False"
        proof
          assume "\<not> A"
          thus "False" using \<open>A\<close> ..
        next
          assume "B"
          with \<open>\<not> B\<close> show "False" ..
        qed
      qed
      thus "False" using \<open>\<not> A \<or> B\<close> ..
    qed
    show "A \<longrightarrow> B"
    proof
      assume "A"
      show "B"
      proof (rule ccontr)
        assume "\<not> B"
        have "\<not> (\<not> A \<or> B)"
        proof
          assume "\<not> A \<or> B"
          thus "False"
          proof
            assume "\<not> A"
            thus "False" using \<open>A\<close> ..
          next
            assume "B"
            with \<open>\<not> B\<close> show "False" ..
          qed
        qed
        thus "False" using \<open>\<not> A \<or> B\<close> ..
      qed
    qed
  qed
qed

lemma "(A \<longrightarrow> B) \<longleftrightarrow> \<not> (A \<and> \<not> B)"
proof
  assume "A \<longrightarrow> B"
  show "\<not> (A \<and> \<not> B)"
  proof
    assume "A \<and> \<not> B"
    hence "A" ..
    have "\<not> B" using \<open>A \<and> \<not> B\<close> ..
    have "\<not> (A \<longrightarrow> B)"
    proof
      assume "A \<longrightarrow> B"
      hence "B" using \<open>A\<close> ..
      with \<open>\<not> B\<close> show "False" ..
    qed
    thus "False" using \<open>A \<longrightarrow> B\<close> ..
  qed
next
  assume "\<not> (A \<and> \<not> B)"
  show "A \<longrightarrow> B"
  proof
    assume "A"
    show "B"
    proof (rule ccontr)
      assume "\<not> B"
      with \<open>A\<close> have "A \<and> \<not> B" ..
      with \<open>\<not> (A \<and> \<not> B)\<close> show "False" ..
    qed
  qed
qed

text \<open>Exercise 19 The Air Raid\<close>

lemma
  assumes 1: "A \<or> \<not> A"
  assumes 2: "A \<longrightarrow> B \<longrightarrow> A"
  assumes 3: "(B \<longrightarrow> A) \<longrightarrow> D"
  assumes 4: "\<not> A \<longrightarrow> C \<longrightarrow> \<not> A"
  assumes 5: "(C \<longrightarrow> \<not> A) \<longrightarrow> D"
  shows "D"
proof (rule disjE)
  from 1 show "A \<or> \<not> A" .
next
  assume "A"
  with 2 have "B \<longrightarrow> A" ..
  with 3 show "D" ..
next
  assume "\<not> A"
  with 4 have "C \<longrightarrow> \<not> A" ..
  with 5 show "D" ..
qed

text \<open>Exercise 20\<close>

lemma "(\<forall> x. F x) \<longrightarrow> F a \<and> F b"
proof
  assume "\<forall> x. F x"
  hence "F b" by (rule allE)
  have "F a" using \<open>\<forall> x. F x\<close> ..
  thus "F a \<and> F b" using \<open>F b\<close> ..
qed

text \<open>Exercise 21 The Riddle of Dracula\<close>

lemma "(\<forall> x. R x d) \<longrightarrow> (\<forall> z. R d z \<longrightarrow> z = m) \<longrightarrow> d = m"
proof
  assume "\<forall> x. R x d"
  hence "R d d" by (rule allE)
  show "(\<forall> z. R d z \<longrightarrow> z = m) \<longrightarrow> d = m"
  proof
    assume "\<forall> z. R d z \<longrightarrow> z = m"
    hence "R d d \<longrightarrow> d = m" ..
    thus "d = m" using \<open>R d d\<close> by (rule mp)
  qed
qed

text \<open>Exercise 22\<close>

lemma "(\<forall> x. F x \<and> G x) \<longrightarrow> (\<forall> x. F x)"
proof
  assume "\<forall> x. F x \<and> G x"
  show "\<forall> x. F x"
  proof (rule allI)
    fix x
    have "F x \<and> G x" using \<open>\<forall> x. F x \<and> G x\<close> by (rule allE)
    thus "F x" ..
  qed
qed

text \<open>Exercise 23\<close>

lemma "(\<forall> x. F x) \<longrightarrow> (\<forall> x. G x \<longrightarrow> F x)"
proof
  assume "\<forall> x. F x"
  show "\<forall> x. G x \<longrightarrow> F x"
  proof (rule allI)
    fix x
    show "G x \<longrightarrow> F x"
    proof
      from \<open>\<forall> x. F x\<close> have "F x" by (rule allE)
      thus "F x" .
    qed
  qed
qed

text \<open>Exercise 24 The Converse Drinkers Principle\<close>

lemma "\<exists>x. (\<exists>y. F y) \<longrightarrow> F x"
proof cases
  assume "\<exists>y. F y"
  thus "\<exists>x. (\<exists>y. F y) \<longrightarrow> F x"
  proof (rule exE)
    fix y
    assume "F y"
    hence "(\<exists>y. F y) \<longrightarrow> F y" by (rule impI)
    thus "\<exists>x. (\<exists>y. F y) \<longrightarrow> F x" by (rule exI)
  qed
next
  fix y
  assume "\<nexists>y. F y"
  have "(\<exists>y. F y) \<longrightarrow> F y"
  proof
    assume "\<exists>y. F y"
    show "F y"
    proof (rule ccontr)
      from \<open>\<nexists>y. F y\<close> \<open>\<exists>y. F y\<close> show "False" ..
    qed
  qed
  thus "\<exists>x. (\<exists>y. F y) \<longrightarrow> F x" by (rule exI)
qed

text \<open>Exercise 25\<close>

lemma not_all_imp_some_not: "\<not> (\<forall>x. F x) \<longrightarrow> (\<exists>x. \<not> F x)"
proof
  assume "\<not> (\<forall>x. F x)"
  show "\<exists>x. \<not> F x"
  proof (rule ccontr)
    assume "\<nexists>x. \<not> F x"
    have "\<forall>x. F x"
    proof (rule allI)
      fix x
      show "F x"
      proof (rule ccontr)
        assume "\<not> F x"
        hence "\<exists>x. \<not> F x" by (rule exI)
        with \<open>\<nexists>x. \<not> F x\<close> show "False" by (rule notE)
      qed
    qed
    with \<open>\<not> (\<forall>x. F x)\<close> show "False" ..
  qed
qed

text \<open>Exercise 26\<close>

lemma "(\<forall>x. F x) \<longrightarrow> (\<exists>x. F x)"
proof
  fix x
  assume "\<forall>x. F x"
  hence "F x" by (rule allE)
  thus "\<exists>x. F x" by (rule exI)
qed

text \<open>Exercise 27\<close>

lemma "(\<exists>x. F x) \<longrightarrow> (\<exists>x. F x \<or> G x)"
proof
  assume "\<exists>x. F x"
  then obtain x where "F x" by (rule exE)
  hence "F x \<or> G x" ..
  thus "\<exists>x. F x \<or> G x" by (rule exI)
qed

text \<open>Exercise 28 The Drinker Principle\<close>

lemma "\<exists>x. F x \<longrightarrow> (\<forall>x. F x)"
proof cases
  fix x
  assume "\<forall>x. F x"
  hence "F x \<longrightarrow> (\<forall>x. F x)" by (rule impI)
  thus "\<exists>x. F x \<longrightarrow> (\<forall>x. F x)" by (rule exI)
next
  assume "\<not> (\<forall>x. F x)"
  with not_all_imp_some_not have "\<exists>x. \<not> F x" ..
  then obtain x where "\<not> F x" by (rule exE)
  have "F x \<longrightarrow> (\<forall>x. F x)"
  proof
    assume "F x"
    show "\<forall>x. F x"
    proof (rule ccontr)
      from \<open>\<not> F x\<close> \<open>F x\<close> show "False" ..
    qed
  qed
  thus "\<exists>x. F x \<longrightarrow> (\<forall>x. F x)" by (rule exI)
qed

text \<open>Exercise 29\<close>

lemma "F a \<longrightarrow> a = a"
proof
  show "a = a" by (rule refl)
qed

text \<open>Exercise 30\<close>

lemma "\<forall>x. \<exists>y. x = y"
proof (rule allI)
  fix x
  have "x = x" by (rule refl)
  thus "\<exists>y. x = y" by (rule exI)
qed

text \<open>Exercise 31\<close>

lemma "a = b \<longrightarrow> b = a"
proof
  assume "a = b"
  have "((=) b) b" ..
  with \<open>a = b\<close> show "((=) b) a" by (rule ssubst)
qed

text \<open>Exercise 32\<close>

lemma "a = b \<longrightarrow> b = c \<longrightarrow> a = c"
proof
  assume "a = b"
  show "b = c \<longrightarrow> a = c"
  proof
    assume "b = c"
    thus "a = c" using \<open>a = b\<close> by (rule subst)
  qed
qed

text \<open>Exercise 33 The Indiscernibility of Identity\<close>

lemma "x = y \<longrightarrow> (F x \<longleftrightarrow> F y)"
proof
  assume "x = y"
  show "F x \<longleftrightarrow> F y"
  proof
    assume "F x"
    with \<open>x = y\<close> show "F y" by (rule subst)
  next
    assume "F y"
    with \<open>x = y\<close> show "F x" by (rule ssubst)
  qed
qed

text \<open>Exercise 34\<close>

lemma "(\<forall>x. F x \<longleftrightarrow> x = a) \<longrightarrow> (THE x. F x) = a"
proof
  assume "\<forall>x. F x \<longleftrightarrow> x = a"
  then have "F a \<longleftrightarrow> a = a" ..
  moreover have "a = a" ..
  ultimately have "F a" by (rule iffD2)
  show "(THE x. F x) = a"
  proof (rule the_equality)
    show "F a" using \<open>F a\<close> .
  next
    fix x
    assume "F x"
    from \<open>\<forall>x. F x \<longleftrightarrow> x = a\<close> have "F x \<longleftrightarrow> x = a" ..
    thus "x = a" using \<open>F x\<close> ..
  qed
qed

end


(* Author: Alexander Maletzky *)

section \<open>Elimination Property\<close>

theory Elimination_Property
  imports Lex_Order_PP Polynomials.MPoly_PM Groebner_Bases.Syzygy
begin

text \<open>We prove the so-called \<^emph>\<open>elimination property\<close> of Gr\"obner bases: Roughly, if \<open>G\<close> is a
  Gr\"obner basis, then under certain restrictions \<open>G \<inter> P[X]\<close> is a Gr\"obner basis, too. This does
  not only hold for intersections with sets of the form \<open>P[X]\<close>, but also for the component-analog of
  \<open>P[X]\<close> (called \<open>PolysC\<close> below).\<close>

subsection \<open>Eliminating Components\<close>

context gd_term
begin

definition PolysC :: "'k \<Rightarrow> ('t \<Rightarrow>\<^sub>0 'b::zero) set"
  where "PolysC k = {p. component_of_term ` keys p \<subseteq> {..<k}}"

context
  assumes pot: is_pot_ord
begin

lemma PolysC_I_pot_ord:
  assumes "component_of_term (lt p) < k"
  shows "p \<in> PolysC k"
proof -
  {
    fix u
    assume "u \<in> keys p"
    hence "u \<preceq>\<^sub>t lt p" by (rule lt_max_keys)
    with pot have "component_of_term u \<le> component_of_term (lt p)" by (rule is_pot_ordD2)
    also have "\<dots> < k" by fact
    finally have "component_of_term u < k" .
  }
  thus ?thesis by (auto simp: PolysC_def)
qed

lemma ex_pmdl_Int_PolysC_adds_lt:
  assumes "dickson_grading d" and "G \<subseteq> dgrad_p_set d m" and "is_Groebner_basis G"
    and "f \<in> pmdl (pmdl G \<inter> PolysC k)" and "f \<noteq> 0"
  shows "\<exists>g\<in>G \<inter> PolysC k. g \<noteq> 0 \<and> lt g adds\<^sub>t lt f"
proof -
  have "pmdl (pmdl G \<inter> PolysC k) \<subseteq> pmdl G" by (rule pmdl.span_subset_spanI) simp
  with assms(4) have "f \<in> pmdl G" ..
  with assms(3, 5) obtain g where "g \<in> G" and "g \<noteq> 0"
    and adds: "lt g adds\<^sub>t lt f" unfolding GB_alt_3_dgrad_p_set[OF assms(1, 2)] by blast
  show ?thesis
  proof (intro bexI conjI)
    from adds have "lt g \<preceq>\<^sub>t lt f" by (rule ord_adds_term)
    with pot have "component_of_term (lt g) \<le> component_of_term (lt f)" by (rule is_pot_ordD2)
    also from assms(4, 5) have "\<dots> < k"
    proof (induct f rule: pmdl_induct)
      case module_0
      thus ?case by simp
    next
      case (module_plus a p c t)
      from module_plus.hyps(3) have "p \<in> PolysC k" ..
      let ?q = "a + monom_mult c t p"
      from module_plus.prems have "lt ?q \<in> keys ?q" by (rule lt_in_keys)
      also have "\<dots> \<subseteq> keys a \<union> keys (monom_mult c t p)" by (rule Poly_Mapping.keys_add)
      finally show ?case
      proof
        assume *: "lt ?q \<in> keys a"
        hence "a \<noteq> 0" by auto
        from * have "lt ?q \<preceq>\<^sub>t lt a" by (rule lt_max_keys)
        with pot have "component_of_term (lt ?q) \<le> component_of_term (lt a)" by (rule is_pot_ordD2)
        also from \<open>a \<noteq> 0\<close> have "\<dots> < k" by (rule module_plus.hyps)
        finally show ?thesis .
      next
        assume "lt ?q \<in> keys (monom_mult c t p)"
        also have "\<dots> \<subseteq> (\<oplus>) t ` keys p" by (rule keys_monom_mult_subset)
        finally have "component_of_term (lt ?q) \<in> component_of_term ` (\<oplus>) t ` keys p" by (rule imageI)
        also have "\<dots> = component_of_term ` keys p" by (simp add: image_image term_simps)
        also from \<open>p \<in> PolysC k\<close> have "\<dots> \<subseteq> {..<k}" by (simp add: PolysC_def)
        finally show ?thesis by simp
      qed
    qed
    finally have "g \<in> PolysC k" by (rule PolysC_I_pot_ord)
    with \<open>g \<in> G\<close> show "g \<in> G \<inter> PolysC k" ..
  qed fact+
qed

lemma pmdl_Int_PolysC_dgrad_p_set:
  assumes "dickson_grading d" and "G \<subseteq> dgrad_p_set d m" and "is_Groebner_basis G"
  shows "pmdl (G \<inter> PolysC k) = pmdl (pmdl G \<inter> PolysC k)"
  using assms(1)
proof (rule pmdl_eqI_adds_lt_dgrad_p_set')
  have "G \<inter> PolysC k \<subseteq> G" by simp
  also have "\<dots> \<subseteq> dgrad_p_set d m" by fact
  finally show "G \<inter> PolysC k \<subseteq> dgrad_p_set d m" .
next
  show "pmdl (G \<inter> PolysC k) \<subseteq> pmdl (pmdl G \<inter> PolysC k)" by (auto intro!: pmdl.span_base pmdl.span_mono)
next
  fix f
  assume "f \<in> pmdl (pmdl G \<inter> PolysC k)" and "f \<noteq> 0"
  with assms show "\<exists>g\<in>G \<inter> PolysC k. g \<noteq> 0 \<and> lt g adds\<^sub>t lt f" by (rule ex_pmdl_Int_PolysC_adds_lt)
qed

lemma Int_PolysC_isGB_dgrad_p_set:
  assumes "dickson_grading d" and "G \<subseteq> dgrad_p_set d m" and "is_Groebner_basis G"
  shows "is_Groebner_basis (G \<inter> PolysC k)"
  using assms(1)
proof (rule isGB_I_adds_lt)
  have "G \<inter> PolysC k \<subseteq> G" by simp
  also have "\<dots> \<subseteq> dgrad_p_set d m" by fact
  finally show "G \<inter> PolysC k \<subseteq> dgrad_p_set d m" .
next
  fix f::"'t \<Rightarrow>\<^sub>0 'b"
  assume "f \<noteq> 0"
  assume "f \<in> pmdl (G \<inter> PolysC k)"
  also have "\<dots> \<subseteq> pmdl (pmdl G \<inter> PolysC k)" by (auto intro!: pmdl.span_base pmdl.span_mono)
  finally have "f \<in> pmdl (pmdl G \<inter> PolysC k)" .
  with assms show "\<exists>g\<in>G \<inter> PolysC k. g \<noteq> 0 \<and> lt g adds\<^sub>t lt f" using \<open>f \<noteq> 0\<close>
    by (rule ex_pmdl_Int_PolysC_adds_lt)
qed

lemmas pmdl_Int_PolysC_finite =
  pmdl_Int_PolysC_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl]
lemmas Int_PolysC_isGB_finite =
  Int_PolysC_isGB_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl]

end

end (* gd_term *)

subsection \<open>TOP Orders\<close>

context ordered_term
begin

definition is_top_ord :: bool
  where "is_top_ord \<longleftrightarrow> (\<forall>u v. pp_of_term u \<prec> pp_of_term v \<longrightarrow> u \<prec>\<^sub>t v)"

lemma is_top_ordI: "(\<And>u v. pp_of_term u \<prec> pp_of_term v \<Longrightarrow> u \<prec>\<^sub>t v) \<Longrightarrow> is_top_ord"
  by (simp add: is_top_ord_def)

lemma is_top_ordD: "is_top_ord \<Longrightarrow> pp_of_term u \<prec> pp_of_term v \<Longrightarrow> u \<prec>\<^sub>t v"
  by (simp add: is_top_ord_def)

lemma is_top_ordD2:
  assumes "is_top_ord" and "u \<preceq>\<^sub>t v"
  shows "pp_of_term u \<preceq> pp_of_term v"
proof (rule ccontr)
  assume "\<not> pp_of_term u \<preceq> pp_of_term v"
  hence "pp_of_term v \<prec> pp_of_term u" by simp
  with assms(1) have "v \<prec>\<^sub>t u" by (rule is_top_ordD)
  with assms(2) show False by simp
qed

lemma is_top_ord:
  assumes "is_top_ord"
  shows "u \<preceq>\<^sub>t v \<longleftrightarrow> (pp_of_term u \<prec> pp_of_term v \<or>
                    (pp_of_term u = pp_of_term v \<and> component_of_term u \<le> component_of_term v))"
      (is "?l \<longleftrightarrow> ?r")
proof
  assume ?l
  with assms have "pp_of_term u \<preceq> pp_of_term v" by (rule is_top_ordD2)
  hence "pp_of_term u \<prec> pp_of_term v \<or> pp_of_term u = pp_of_term v" by auto
  thus ?r
  proof
    assume "pp_of_term u \<prec> pp_of_term v"
    thus ?r ..
  next
    assume 1: "pp_of_term u = pp_of_term v"
    moreover have "component_of_term u \<le> component_of_term v"
    proof (rule ccontr)
      assume "\<not> component_of_term u \<le> component_of_term v"
      hence 2: "component_of_term v \<le> component_of_term u"
        and 3: "component_of_term u \<noteq> component_of_term v" by simp_all
      from 1 have "pp_of_term v \<preceq> pp_of_term u" by simp
      hence "v \<preceq>\<^sub>t u" using 2 by (rule ord_termI)
      with \<open>?l\<close> have "u = v" by simp
      with 3 show False by simp
    qed
    ultimately show ?r by simp
  qed
next
  assume ?r
  thus ?l
  proof
    assume "pp_of_term u \<prec> pp_of_term v"
    with assms have "u \<prec>\<^sub>t v" by (rule is_top_ordD)
    thus ?l by simp
  next
    assume "pp_of_term u = pp_of_term v \<and> component_of_term u \<le> component_of_term v"
    hence "pp_of_term u \<preceq> pp_of_term v" and "component_of_term u \<le> component_of_term v" by simp_all
    thus ?l by (rule ord_termI)
  qed
qed

end (* ordered_term *)

subsection \<open>Elimination Orders\<close>

definition is_elim_ord :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow> ('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow> bool) \<Rightarrow> 'x set \<Rightarrow> bool"
  where "is_elim_ord ord X \<longleftrightarrow> (\<forall>s t. s \<in> .[X] \<longrightarrow> ord t s \<longrightarrow> t \<in> .[X])"

lemma is_elim_ordI: "(\<And>s t. s \<in> .[X] \<Longrightarrow> ord t s \<Longrightarrow> t \<in> .[X]) \<Longrightarrow> is_elim_ord ord X"
  by (simp add: is_elim_ord_def)

lemma is_elim_ordD: "is_elim_ord ord X \<Longrightarrow> s \<in> .[X] \<Longrightarrow> ord t s \<Longrightarrow> t \<in> .[X]"
  by (simp add: is_elim_ord_def)

lemma is_elim_ord_UNIV: "is_elim_ord ord UNIV"
  by (simp add: is_elim_ord_def PPs_def)

lemma lex_is_elim_ord: "is_elim_ord (lex_pm::('x::linorder \<Rightarrow>\<^sub>0 nat) \<Rightarrow> _) {x..}"
proof (intro is_elim_ordI PPsI subsetI)
  fix s t :: "'x \<Rightarrow>\<^sub>0 nat" and y
  assume "lex_pm t s" and "y \<in> keys t"
  then obtain z where "z \<in> keys s" and "z \<le> y" by (rule lex_pm_keys_leE)
  moreover assume "s \<in> .[{x..}]"
  ultimately show "y \<in> {x..}" by (auto dest!: PPsD)
qed

lemma lex_is_elim_ord': "is_elim_ord (lex_pm::('x::linorder \<Rightarrow>\<^sub>0 nat) \<Rightarrow> _) {x<..}"
proof (intro is_elim_ordI PPsI subsetI)
  fix s t :: "'x \<Rightarrow>\<^sub>0 nat" and y
  assume "lex_pm t s" and "y \<in> keys t"
  then obtain z where "z \<in> keys s" and "z \<le> y" by (rule lex_pm_keys_leE)
  moreover assume "s \<in> .[{x<..}]"
  ultimately show "y \<in> {x<..}" by (auto dest!: PPsD)
qed

subsection \<open>Eliminating Indeterminates\<close>

locale pm_term =
  ordered_term pair_of_term term_of_pair ord ord_strict ord_term ord_term_strict
  for pair_of_term::"'t \<Rightarrow> (('x::{countable,linorder} \<Rightarrow>\<^sub>0 nat) \<times> 'k::{the_min,wellorder})"
  and term_of_pair::"(('x \<Rightarrow>\<^sub>0 nat) \<times> 'k) \<Rightarrow> 't"
  and ord :: "('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow> ('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow> bool" (infixl "\<preceq>" 50)
  and ord_strict (infixl "\<prec>" 50)
  and ord_term::"'t \<Rightarrow> 't \<Rightarrow> bool" (infixl "\<preceq>\<^sub>t" 50)
  and ord_term_strict::"'t \<Rightarrow> 't \<Rightarrow> bool" (infixl "\<prec>\<^sub>t" 50)
begin

sublocale gd_term ..

definition PolysV :: "'x set \<Rightarrow> ('t \<Rightarrow>\<^sub>0 'b::zero) set"
  where "PolysV X = {p. pp_of_term ` keys p \<subseteq> .[X]}"

lemma dgrad_p_set_varnum_PolysV: "dgrad_p_set (varnum X) 0 = PolysV X"
  by (simp add: dgrad_p_set_def dgrad_set_varnum PolysV_def)

context
  fixes Y :: "'x set"
  assumes top: is_top_ord
  assumes elim: "is_elim_ord (\<preceq>) Y"
  assumes fin: "finite Y"
begin

lemma PolysV_I_top_ord:
  assumes "lp p \<in> .[Y]"
  shows "p \<in> PolysV Y"
proof -
  {
    fix u
    assume "u \<in> keys p"
    hence "u \<preceq>\<^sub>t lt p" by (rule lt_max_keys)
    note elim assms
    moreover from top \<open>u \<preceq>\<^sub>t lt p\<close> have "pp_of_term u \<preceq> lp p" by (rule is_top_ordD2)
    ultimately have "pp_of_term u \<in> .[Y]" by (rule is_elim_ordD)
  }
  thus ?thesis by (auto simp: PolysV_def)
qed

lemma ex_pmdl_Int_PolysV_adds_lt:
  assumes "dickson_grading d" and "G \<subseteq> dgrad_p_set d m" and "is_Groebner_basis G"
    and "f \<in> PolysV Y" and "f \<in> pmdl (pmdl G \<inter> PolysV Y)" and "f \<noteq> 0"
  shows "\<exists>g\<in>G \<inter> PolysV Y. g \<noteq> 0 \<and> lt g adds\<^sub>t lt f"
proof -
  have "pmdl (pmdl G \<inter> PolysV Y) \<subseteq> pmdl G" by (rule pmdl.span_subset_spanI) simp
  with assms(5) have "f \<in> pmdl G" ..
  with assms(3, 6) obtain g where "g \<in> G" and "g \<noteq> 0"
    and adds: "lt g adds\<^sub>t lt f" unfolding GB_alt_3_dgrad_p_set[OF assms(1, 2)] by blast
  show ?thesis
  proof (intro bexI conjI)
    from adds have "lt g \<preceq>\<^sub>t lt f" by (rule ord_adds_term)
    note elim
    moreover from assms(4, 6) have "lp f \<in> .[Y]" by (auto simp: PolysV_def dest: lt_in_keys)
    moreover from top \<open>lt g \<preceq>\<^sub>t lt f\<close> have "lp g \<preceq> lp f" by (rule is_top_ordD2)
    ultimately have "lp g \<in> .[Y]" by (rule is_elim_ordD)
    hence "g \<in> PolysV Y" by (rule PolysV_I_top_ord)
    with \<open>g \<in> G\<close> show "g \<in> G \<inter> PolysV Y" ..
  qed fact+
qed

lemma pmdl_Int_PolysV_dgrad_p_set:
  assumes "dickson_grading d" and "G \<subseteq> dgrad_p_set d m" and "is_Groebner_basis G"
  shows "pmdl (G \<inter> PolysV Y) = pmdl (pmdl G \<inter> PolysV Y)"
  using dickson_grading_varnum[OF fin]
proof (rule pmdl_eqI_adds_lt_dgrad_p_set)
  show "G \<inter> PolysV Y \<subseteq> dgrad_p_set (varnum Y) 0"
    and "pmdl G \<inter> PolysV Y \<subseteq> dgrad_p_set (varnum Y) 0" by (simp_all add: dgrad_p_set_varnum_PolysV)
next
  show "pmdl (G \<inter> PolysV Y) \<subseteq> pmdl (pmdl G \<inter> PolysV Y)" by (auto intro!: pmdl.span_base pmdl.span_mono)
next
  fix f :: "'t \<Rightarrow>\<^sub>0 'a"
  assume "f \<in> dgrad_p_set (varnum Y) 0"
  hence "f \<in> PolysV Y" by (simp only: dgrad_p_set_varnum_PolysV)
  assume "f \<in> pmdl (pmdl G \<inter> PolysV Y)" and "f \<noteq> 0"
  with assms \<open>f \<in> PolysV Y\<close> show "\<exists>g\<in>G \<inter> PolysV Y. g \<noteq> 0 \<and> lt g adds\<^sub>t lt f"
    by (rule ex_pmdl_Int_PolysV_adds_lt)
qed

lemma Int_PolysV_isGB_dgrad_p_set:
  assumes "dickson_grading d" and "G \<subseteq> dgrad_p_set d m" and "is_Groebner_basis G"
  shows "is_Groebner_basis (G \<inter> PolysV Y)"
  using dickson_grading_varnum[OF fin]
proof (rule isGB_I_adds_lt)
  show "G \<inter> PolysV Y \<subseteq> dgrad_p_set (varnum Y) 0" by (simp add: dgrad_p_set_varnum_PolysV)
next
  fix f::"'t \<Rightarrow>\<^sub>0 'a"
  assume "f \<noteq> 0"
  assume "f \<in> dgrad_p_set (varnum Y) 0"
  hence "f \<in> PolysV Y" by (simp only: dgrad_p_set_varnum_PolysV)
  assume "f \<in> pmdl (G \<inter> PolysV Y)"
  also have "\<dots> \<subseteq> pmdl (pmdl G \<inter> PolysV Y)" by (auto intro!: pmdl.span_base pmdl.span_mono)
  finally have "f \<in> pmdl (pmdl G \<inter> PolysV Y)" .
  with assms \<open>f \<in> PolysV Y\<close> show "\<exists>g\<in>G \<inter> PolysV Y. g \<noteq> 0 \<and> lt g adds\<^sub>t lt f" using \<open>f \<noteq> 0\<close>
    by (rule ex_pmdl_Int_PolysV_adds_lt)
qed

lemmas pmdl_Int_PolysV_PolysV =
  pmdl_Int_PolysV_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum_PolysV]
lemmas Int_PolysV_isGB_PolysV =
  Int_PolysV_isGB_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum_PolysV]

lemmas pmdl_Int_PolysV_finite =
  pmdl_Int_PolysV_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl]
lemmas Int_PolysV_isGB_finite =
  Int_PolysV_isGB_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl]

end

end (* pm_term *)

subsection \<open>Translating Results into @{locale pm_powerprod}\<close>

context pm_powerprod
begin

sublocale punit: pm_term to_pair_unit fst "(\<preceq>)" "(\<prec>)" "(\<preceq>)" "(\<prec>)" ..

lemma PolysV_eq_Polys [simp]: "punit.PolysV X = P[X]"
  by (simp add: punit.PolysV_def Polys_def)

lemma punit_is_top_ord: "punit.is_top_ord"
  by (simp add: punit.is_top_ord_def)

lemmas ideal_Int_Polys_Polys =
  punit.pmdl_Int_PolysV_PolysV[OF punit_is_top_ord, simplified]
lemmas Int_Polys_isGB_Polys =
  punit.Int_PolysV_isGB_PolysV[OF punit_is_top_ord, simplified]
lemmas ideal_Int_Polys_finite =
  punit.pmdl_Int_PolysV_finite[OF punit_is_top_ord, simplified]
lemmas Int_Polys_isGB_finite =
  punit.Int_PolysV_isGB_finite[OF punit_is_top_ord, simplified]

end (* pm_powerprod *)

end (* theory *)


(* The value setup for friend confidentiality *)
theory Friend_Value_Setup
imports Friend_Intro
begin

text \<open>The confidential information is the friendship status between two arbitrary but fixed users:\<close>

consts UID1 :: userID
consts UID2 :: userID

axiomatization where
UID1_UID2_UIDs: "{UID1,UID2} \<inter> UIDs = {}"
and
UID1_UID2: "UID1 \<noteq> UID2"

subsection \<open>Preliminaries\<close>

(* The notion of two userID lists being equal save for at most one occurrence of uid: *)
fun eqButUIDl :: "userID \<Rightarrow> userID list \<Rightarrow> userID list \<Rightarrow> bool" where
"eqButUIDl uid uidl uidl1 = (remove1 uid uidl = remove1 uid uidl1)"

lemma eqButUIDl_eq[simp,intro!]: "eqButUIDl uid uidl uidl"
by auto

lemma eqButUIDl_sym:
assumes "eqButUIDl uid uidl uidl1"
shows "eqButUIDl uid uidl1 uidl"
using assms by auto

lemma eqButUIDl_trans:
assumes "eqButUIDl uid uidl uidl1" and "eqButUIDl uid uidl1 uidl2"
shows "eqButUIDl uid uidl uidl2"
using assms by auto

lemma eqButUIDl_remove1_cong:
assumes "eqButUIDl uid uidl uidl1"
shows "eqButUIDl uid (remove1 uid' uidl) (remove1 uid' uidl1)"
proof -
  have "remove1 uid (remove1 uid' uidl) = remove1 uid' (remove1 uid uidl)" by (simp add: remove1_commute)
  also have "\<dots> = remove1 uid' (remove1 uid uidl1)" using assms by simp
  also have "\<dots> = remove1 uid (remove1 uid' uidl1)" by (simp add: remove1_commute)
  finally show ?thesis by simp
qed

lemma eqButUIDl_snoc_cong:
assumes "eqButUIDl uid uidl uidl1"
and "uid' \<in>\<in> uidl \<longleftrightarrow> uid' \<in>\<in> uidl1"
shows "eqButUIDl uid (uidl ## uid') (uidl1 ## uid')"
using assms by (auto simp add: remove1_append remove1_idem)

(* The notion of two functions each taking a userID and returning a list of user IDs
  being equal everywhere but on UID1 and UID2, where their return results are allowed
  to be eqButUIDl : *)
definition eqButUIDf where
"eqButUIDf frds frds1 \<equiv>
  eqButUIDl UID2 (frds UID1) (frds1 UID1)
\<and> eqButUIDl UID1 (frds UID2) (frds1 UID2)
\<and> (\<forall>uid. uid \<noteq> UID1 \<and> uid \<noteq> UID2 \<longrightarrow> frds uid = frds1 uid)"

lemmas eqButUIDf_intro = eqButUIDf_def[THEN meta_eq_to_obj_eq, THEN iffD2]

lemma eqButUIDf_eeq[simp,intro!]: "eqButUIDf frds frds"
unfolding eqButUIDf_def by auto

lemma eqButUIDf_sym:
assumes "eqButUIDf frds frds1" shows "eqButUIDf frds1 frds"
using assms eqButUIDl_sym unfolding eqButUIDf_def
by presburger

lemma eqButUIDf_trans:
assumes "eqButUIDf frds frds1" and "eqButUIDf frds1 frds2"
shows "eqButUIDf frds frds2"
using assms eqButUIDl_trans unfolding eqButUIDf_def by (auto split: if_splits)

lemma eqButUIDf_cong:
assumes "eqButUIDf frds frds1"
and "uid = UID1 \<Longrightarrow> eqButUIDl UID2 uu uu1"
and "uid = UID2 \<Longrightarrow> eqButUIDl UID1 uu uu1"
and "uid \<noteq> UID1 \<Longrightarrow> uid \<noteq> UID2 \<Longrightarrow> uu = uu1"
shows "eqButUIDf (frds (uid := uu)) (frds1(uid := uu1))"
using assms unfolding eqButUIDf_def by (auto split: if_splits)

lemma eqButUIDf_eqButUIDl:
assumes "eqButUIDf frds frds1"
shows "eqButUIDl UID2 (frds UID1) (frds1 UID1)"
  and "eqButUIDl UID1 (frds UID2) (frds1 UID2)"
using assms unfolding eqButUIDf_def by (auto split: if_splits)

lemma eqButUIDf_not_UID:
"\<lbrakk>eqButUIDf frds frds1; uid \<noteq> UID1; uid \<noteq> UID2\<rbrakk> \<Longrightarrow> frds uid = frds1 uid"
unfolding eqButUIDf_def by (auto split: if_splits)

lemma eqButUIDf_not_UID':
assumes eq1: "eqButUIDf frds frds1"
and uid: "(uid,uid') \<notin> {(UID1,UID2), (UID2,UID1)}"
shows "uid \<in>\<in> frds uid' \<longleftrightarrow> uid \<in>\<in> frds1 uid'"
proof -
  from uid have "(uid' = UID1 \<and> uid \<noteq> UID2)
               \<or> (uid' = UID2 \<and> uid \<noteq> UID1)
               \<or> (uid' \<notin> {UID1,UID2})" (is "?u1 \<or> ?u2 \<or> ?n12")
    by auto
  then show ?thesis proof (elim disjE)
    assume "?u1"
    moreover then have "uid \<in>\<in> remove1 UID2 (frds uid') \<longleftrightarrow> uid \<in>\<in> remove1 UID2 (frds1 uid')"
      using eq1 unfolding eqButUIDf_def by auto
    ultimately show ?thesis by auto
  next
    assume "?u2"
    moreover then have "uid \<in>\<in> remove1 UID1 (frds uid') \<longleftrightarrow> uid \<in>\<in> remove1 UID1 (frds1 uid')"
      using eq1 unfolding eqButUIDf_def by auto
    ultimately show ?thesis by auto
  next
    assume "?n12"
    then show ?thesis using eq1 unfolding eqButUIDf_def by auto
  qed
qed

(* The notion of two functions each taking two userID arguments being
  equal everywhere but on the values (UID1,UID2) and (UID2,UID1): *)
definition eqButUID12 where
"eqButUID12 freq freq1 \<equiv>
 \<forall> uid uid'. if (uid,uid') \<in> {(UID1,UID2), (UID2,UID1)} then True else freq uid uid' = freq1 uid uid'"

lemmas eqButUID12_intro = eqButUID12_def[THEN meta_eq_to_obj_eq, THEN iffD2]

lemma eqButUID12_eeq[simp,intro!]: "eqButUID12 freq freq"
unfolding eqButUID12_def by auto

lemma eqButUID12_sym:
assumes "eqButUID12 freq freq1" shows "eqButUID12 freq1 freq"
using assms unfolding eqButUID12_def
by presburger

lemma eqButUID12_trans:
assumes "eqButUID12 freq freq1" and "eqButUID12 freq1 freq2"
shows "eqButUID12 freq freq2"
using assms unfolding eqButUID12_def by (auto split: if_splits)

lemma eqButUID12_cong:
assumes "eqButUID12 freq freq1"
(*and "uid = UID1 \<Longrightarrow> eqButUID2 uu uu1"*)
and "\<not> (uid,uid') \<in> {(UID1,UID2), (UID2,UID1)} \<Longrightarrow> uu = uu1"
shows "eqButUID12 (fun_upd2 freq uid uid' uu) (fun_upd2 freq1 uid uid' uu1)"
using assms unfolding eqButUID12_def fun_upd2_def by (auto split: if_splits)

lemma eqButUID12_not_UID:
"\<lbrakk>eqButUID12 freq freq1; \<not> (uid,uid') \<in> {(UID1,UID2), (UID2,UID1)}\<rbrakk> \<Longrightarrow> freq uid uid' = freq1 uid uid'"
unfolding eqButUID12_def by (auto split: if_splits)

(* The notion of two states being equal everywhere but on the friendship requests or status of users UID1 and UID2: *)
definition eqButUID :: "state \<Rightarrow> state \<Rightarrow> bool" where
"eqButUID s s1 \<equiv>
 admin s = admin s1 \<and>

 pendingUReqs s = pendingUReqs s1 \<and> userReq s = userReq s1 \<and>
 userIDs s = userIDs s1 \<and> user s = user s1 \<and> pass s = pass s1 \<and>

 eqButUIDf (pendingFReqs s) (pendingFReqs s1) \<and>
 eqButUID12 (friendReq s) (friendReq s1) \<and>
 eqButUIDf (friendIDs s) (friendIDs s1) \<and>

 postIDs s = postIDs s1 \<and> admin s = admin s1 \<and>
 post s = post s1 \<and>
 owner s = owner s1 \<and>
 vis s = vis s1"

lemmas eqButUID_intro = eqButUID_def[THEN meta_eq_to_obj_eq, THEN iffD2]

lemma eqButUID_refl[simp,intro!]: "eqButUID s s"
unfolding eqButUID_def by auto

lemma eqButUID_sym[sym]:
assumes "eqButUID s s1" shows "eqButUID s1 s"
using assms eqButUIDf_sym eqButUID12_sym unfolding eqButUID_def by auto

lemma eqButUID_trans[trans]:
assumes "eqButUID s s1" and "eqButUID s1 s2" shows "eqButUID s s2"
using assms eqButUIDf_trans eqButUID12_trans unfolding eqButUID_def by metis

(* Implications from eqButUID, including w.r.t. auxiliary operations: *)
lemma eqButUID_stateSelectors:
"eqButUID s s1 \<Longrightarrow>
 admin s = admin s1 \<and>

 pendingUReqs s = pendingUReqs s1 \<and> userReq s = userReq s1 \<and>
 userIDs s = userIDs s1 \<and> user s = user s1 \<and> pass s = pass s1 \<and>

 eqButUIDf (pendingFReqs s) (pendingFReqs s1) \<and>
 eqButUID12 (friendReq s) (friendReq s1) \<and>
 eqButUIDf (friendIDs s) (friendIDs s1) \<and>

 postIDs s = postIDs s1 \<and> admin s = admin s1 \<and>
 post s = post s1 \<and>
 owner s = owner s1 \<and>
 vis s = vis s1 \<and>

 IDsOK s = IDsOK s1"
unfolding eqButUID_def IDsOK_def[abs_def] by auto

lemma eqButUID_eqButUID2:
"eqButUID s s1 \<Longrightarrow> eqButUIDl UID2 (friendIDs s UID1) (friendIDs s1 UID1)"
unfolding eqButUID_def using eqButUIDf_eqButUIDl
by (smt eqButUIDf_eqButUIDl eqButUIDl.simps)

lemma eqButUID_not_UID:
"eqButUID s s1 \<Longrightarrow> uid \<noteq> UID \<Longrightarrow> post s uid = post s1 uid"
unfolding eqButUID_def by auto

lemma eqButUID_cong[simp, intro]:
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>admin := uu1\<rparr>) (s1 \<lparr>admin := uu2\<rparr>)"

"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>pendingUReqs := uu1\<rparr>) (s1 \<lparr>pendingUReqs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>userReq := uu1\<rparr>) (s1 \<lparr>userReq := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>userIDs := uu1\<rparr>) (s1 \<lparr>userIDs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>user := uu1\<rparr>) (s1 \<lparr>user := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>pass := uu1\<rparr>) (s1 \<lparr>pass := uu2\<rparr>)"

"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>postIDs := uu1\<rparr>) (s1 \<lparr>postIDs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>owner := uu1\<rparr>) (s1 \<lparr>owner := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>post := uu1\<rparr>) (s1 \<lparr>post := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>vis := uu1\<rparr>) (s1 \<lparr>vis := uu2\<rparr>)"

"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> eqButUIDf uu1 uu2 \<Longrightarrow> eqButUID (s \<lparr>pendingFReqs := uu1\<rparr>) (s1 \<lparr>pendingFReqs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> eqButUID12 uu1 uu2 \<Longrightarrow> eqButUID (s \<lparr>friendReq := uu1\<rparr>) (s1 \<lparr>friendReq := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> eqButUIDf uu1 uu2 \<Longrightarrow> eqButUID (s \<lparr>friendIDs := uu1\<rparr>) (s1 \<lparr>friendIDs := uu2\<rparr>)"

unfolding eqButUID_def by auto

subsection\<open>Value Setup\<close>

datatype "value" =
  FrVal bool \<comment> \<open>updated friendship status between \<open>UID1\<close> and \<open>UID2\<close>\<close>
| OVal bool \<comment> \<open>updated dynamic declassification trigger condition\<close>

text \<open>The dynamic declassification trigger condition holds, i.e.~the access window to the
confidential information is open, as long as the two users have not been created yet (so there
cannot be friendship between them) or one of them is friends with an observer.\<close>

definition openByA :: "state \<Rightarrow> bool" \<comment> \<open>Openness by absence\<close>
where "openByA s \<equiv> \<not> UID1 \<in>\<in> userIDs s \<or> \<not> UID2 \<in>\<in> userIDs s"

definition openByF :: "state \<Rightarrow> bool" \<comment> \<open>Openness by friendship\<close>
where "openByF s \<equiv> \<exists>uid \<in> UIDs. uid \<in>\<in> friendIDs s UID1 \<or> uid \<in>\<in> friendIDs s UID2"

definition "open" :: "state \<Rightarrow> bool"
where "open s \<equiv> openByA s \<or> openByF s"

lemmas open_defs = open_def openByA_def openByF_def

definition "friends12" :: "state \<Rightarrow> bool"
where "friends12 s \<equiv> UID1 \<in>\<in> friendIDs s UID2 \<and> UID2 \<in>\<in> friendIDs s UID1"

fun \<phi> :: "(state,act,out) trans \<Rightarrow> bool" where
"\<phi> (Trans s (Cact (cFriend uid p uid')) ou s') =
  ((uid,uid') \<in> {(UID1,UID2), (UID2,UID1)} \<and> ou = outOK \<or>
   open s \<noteq> open s')"
|
"\<phi> (Trans s (Dact (dFriend uid p uid')) ou s') =
  ((uid,uid') \<in> {(UID1,UID2), (UID2,UID1)} \<and> ou = outOK \<or>
   open s \<noteq> open s')"
|
"\<phi> (Trans s (Cact (cUser uid p uid' p')) ou s') =
  (open s \<noteq> open s')"
|
"\<phi> _ = False"

fun f :: "(state,act,out) trans \<Rightarrow> value" where
"f (Trans s (Cact (cFriend uid p uid')) ou s') =
  (if (uid,uid') \<in> {(UID1,UID2), (UID2,UID1)} then FrVal True
                                              else OVal True)"
|
"f (Trans s (Dact (dFriend uid p uid')) ou s') =
  (if (uid,uid') \<in> {(UID1,UID2), (UID2,UID1)} then FrVal False
                                              else OVal False)"
|
"f (Trans s (Cact (cUser uid p uid' p')) ou s') = OVal False"
|
"f _ = undefined"

lemma \<phi>E:
assumes \<phi>: "\<phi> (Trans s a ou s')" (is "\<phi> ?trn")
and step: "step s a = (ou, s')"
and rs: "reach s"
obtains (Friend) uid p uid' where "a = Cact (cFriend uid p uid')" "ou = outOK" "f ?trn = FrVal True"
                                  "uid = UID1 \<and> uid' = UID2 \<or> uid = UID2 \<and> uid' = UID1"
                                  "IDsOK s [UID1, UID2] []"
                                  "\<not>friends12 s" "friends12 s'"
      | (Unfriend) uid p uid' where "a = Dact (dFriend uid p uid')" "ou = outOK" "f ?trn = FrVal False"
                                    "uid = UID1 \<and> uid' = UID2 \<or> uid = UID2 \<and> uid' = UID1"
                                    "IDsOK s [UID1, UID2] []"
                                    "friends12 s" "\<not>friends12 s'"
      | (OpenF) uid p uid' where "a = Cact (cFriend uid p uid')"
                                 "(uid \<in> UIDs \<and> uid' \<in> {UID1,UID2}) \<or> (uid' \<in> UIDs \<and> uid \<in> {UID1,UID2})"
                                 "ou = outOK" "f ?trn = OVal True" "\<not>openByF s" "openByF s'"
                                 "\<not>openByA s" "\<not>openByA s'"
      | (CloseF) uid p uid' where "a = Dact (dFriend uid p uid')"
                                  "(uid \<in> UIDs \<and> uid' \<in> {UID1,UID2}) \<or> (uid' \<in> UIDs \<and> uid \<in> {UID1,UID2})"
                                  "ou = outOK" "f ?trn = OVal False" "openByF s" "\<not>openByF s'"
                                  "\<not>openByA s" "\<not>openByA s'"
      | (CloseA) uid p uid' p' where "a = Cact (cUser uid p uid' p')"
                                     "uid' \<in> {UID1,UID2}" "openByA s" "\<not>openByA s'"
                                     "\<not>openByF s" "\<not>openByF s'"
                                     "ou = outOK" "f ?trn = OVal False"
using \<phi> proof (elim \<phi>.elims disjE conjE)
  fix s1 uid p uid' ou1 s1'
  assume "(uid,uid') \<in> {(UID1,UID2), (UID2,UID1)}" and ou: "ou1 = outOK"
     and "?trn = Trans s1 (Cact (cFriend uid p uid')) ou1 s1'"
  then have trn: "a = Cact (cFriend uid p uid')" "s = s1" "s' = s1'" "ou = ou1"
        and uids: "uid = UID1 \<and> uid' = UID2 \<or> uid = UID2 \<and> uid' = UID1" using UID1_UID2 by auto
  then show thesis using ou uids trn step UID1_UID2_UIDs UID1_UID2 reach_distinct_friends_reqs[OF rs]
    by (intro Friend[of uid p uid']) (auto simp add: c_defs friends12_def)
next
  fix s1 uid p uid' ou1 s1'
  assume op: "open s1 \<noteq> open s1'"
     and "?trn = Trans s1 (Cact (cFriend uid p uid')) ou1 s1'"
  then have trn: "a = Cact (cFriend uid p uid')" "s = s1" "s' = s1'" "ou = ou1" by auto
  then have uids: "uid \<in> UIDs \<and> uid' \<in> {UID1, UID2} \<or> uid \<in> {UID1, UID2} \<and> uid' \<in> UIDs" "ou = outOK"
                  "\<not>openByF s1" "openByF s1'" "\<not>openByA s1" "\<not>openByA s1'"
    using op step by (auto simp add: c_defs open_def openByA_def openByF_def)
  then show thesis using op trn step UID1_UID2_UIDs UID1_UID2 by (intro OpenF) auto
next
  fix s1 uid p uid' ou1 s1'
  assume "(uid,uid') \<in> {(UID1,UID2), (UID2,UID1)}" and ou: "ou1 = outOK"
     and "?trn = Trans s1 (Dact (dFriend uid p uid')) ou1 s1'"
  then have trn: "a = Dact (dFriend uid p uid')" "s = s1" "s' = s1'" "ou = ou1"
        and uids: "uid = UID1 \<and> uid' = UID2 \<or> uid = UID2 \<and> uid' = UID1" using UID1_UID2 by auto
  then show thesis using step ou reach_friendIDs_symmetric[OF rs]
    by (intro Unfriend) (auto simp: d_defs friends12_def)
next
  fix s1 uid p uid' ou1 s1'
  assume op: "open s1 \<noteq> open s1'"
     and "?trn = Trans s1 (Dact (dFriend uid p uid')) ou1 s1'"
  then have trn: "a = Dact (dFriend uid p uid')" "s = s1" "s' = s1'" "ou = ou1" by auto
  then have uids: "uid \<in> UIDs \<and> uid' \<in> {UID1, UID2} \<or> uid \<in> {UID1, UID2} \<and> uid' \<in> UIDs" "ou = outOK"
                  "openByF s1" "\<not>openByF s1'" "\<not>openByA s1" "\<not>openByA s1'"
    using op step by (auto simp add: d_defs open_def openByA_def openByF_def)
  then show thesis using op trn step UID1_UID2_UIDs UID1_UID2 by (auto intro: CloseF)
next
  fix s1 uid p uid' p' ou1 s1'
  assume op: "open s1 \<noteq> open s1'"
     and "?trn = Trans s1 (Cact (cUser uid p uid' p')) ou1 s1'"
  then have trn: "a = Cact (cUser uid p uid' p')" "s = s1" "s' = s1'" "ou = ou1" by auto
  then have uids: "uid' = UID2 \<or> uid' = UID1" "ou = outOK"
                  "\<not>openByF s1" "\<not>openByF s1'" "openByA s1" "\<not>openByA s1'"
    using op step by (auto simp add: c_defs open_def openByF_def openByA_def)
  then show thesis using trn step UID1_UID2_UIDs UID1_UID2 by (intro CloseA) auto
qed

lemma step_open_\<phi>:
assumes "step s a = (ou, s')"
and "open s \<noteq> open s'"
shows "\<phi> (Trans s a ou s')"
using assms proof (cases a)
  case (Sact sa) then show ?thesis using assms UID1_UID2 by (cases sa) (auto simp: s_defs open_defs) next
  case (Cact ca) then show ?thesis using assms by (cases ca) (auto simp: c_defs open_defs) next
  case (Dact da) then show ?thesis using assms by (cases da) (auto simp: d_defs open_defs) next
  case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: u_defs open_defs)
qed auto

lemma step_friends12_\<phi>:
assumes "step s a = (ou, s')"
and "friends12 s \<noteq> friends12 s'"
shows "\<phi> (Trans s a ou s')"
using assms proof (cases a)
  case (Sact sa) then show ?thesis using assms by (cases sa) (auto simp: s_defs friends12_def) next
  case (Cact ca) then show ?thesis using assms by (cases ca) (auto simp: c_defs friends12_def) next
  case (Dact da) then show ?thesis using assms by (cases da) (auto simp: d_defs friends12_def) next
  case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: u_defs friends12_def)
qed auto

lemma eqButUID_friends12_set_friendIDs_eq:
assumes ss1: "eqButUID s s1"
and f12: "friends12 s = friends12 s1"
and rs: "reach s" and rs1: "reach s1"
shows "set (friendIDs s uid) = set (friendIDs s1 uid)"
proof -
  have dfIDs: "distinct (friendIDs s uid)" "distinct (friendIDs s1 uid)"
    using reach_distinct_friends_reqs[OF rs] reach_distinct_friends_reqs[OF rs1] by auto
  from f12 have uid12: "UID1 \<in>\<in> friendIDs s UID2 \<longleftrightarrow> UID1 \<in>\<in> friendIDs s1 UID2"
                       "UID2 \<in>\<in> friendIDs s UID1 \<longleftrightarrow> UID2 \<in>\<in> friendIDs s1 UID1"
    using reach_friendIDs_symmetric[OF rs] reach_friendIDs_symmetric[OF rs1]
    unfolding friends12_def by auto
  from ss1 have fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" unfolding eqButUID_def by simp
  show "set (friendIDs s uid) = set (friendIDs s1 uid)"
  proof (intro equalityI subsetI)
    fix uid'
    assume "uid' \<in>\<in> friendIDs s uid"
    then show "uid' \<in>\<in> friendIDs s1 uid"
      using fIDs dfIDs uid12 eqButUIDf_not_UID' unfolding eqButUIDf_def
      by (metis (no_types, lifting) insert_iff prod.inject singletonD)
  next
    fix uid'
    assume "uid' \<in>\<in> friendIDs s1 uid"
    then show "uid' \<in>\<in> friendIDs s uid"
      using fIDs dfIDs uid12 eqButUIDf_not_UID' unfolding eqButUIDf_def
      by (metis (no_types, lifting) insert_iff prod.inject singletonD)
  qed
qed

lemma distinct_remove1_idem: "distinct xs \<Longrightarrow> remove1 y (remove1 y xs) = remove1 y xs"
by (induction xs) (auto simp add: remove1_idem)

lemma Cact_cFriend_step_eqButUID:
assumes step: "step s (Cact (cFriend uid p uid')) = (ou,s')"
and s: "reach s"
and uids: "(uid = UID1 \<and> uid' = UID2) \<or> (uid = UID2 \<and> uid' = UID1)" (is "?u12 \<or> ?u21")
shows "eqButUID s s'"
using assms proof (cases)
  assume ou: "ou = outOK"
  then have "uid' \<in>\<in> pendingFReqs s uid" using step by (auto simp add: c_defs)
  then have fIDs: "uid' \<notin> set (friendIDs s uid)" "uid \<notin> set (friendIDs s uid')"
        and fRs: "distinct (pendingFReqs s uid)" "distinct (pendingFReqs s uid')"
    using reach_distinct_friends_reqs[OF s] by auto
  have "eqButUIDf (friendIDs s) (friendIDs (createFriend s uid p uid'))"
    using fIDs uids UID1_UID2 unfolding eqButUIDf_def
    by (cases "?u12") (auto simp add: c_defs remove1_idem remove1_append)
  moreover have "eqButUIDf (pendingFReqs s) (pendingFReqs (createFriend s uid p uid'))"
    using fRs uids UID1_UID2 unfolding eqButUIDf_def
    by (cases "?u12") (auto simp add: c_defs distinct_remove1_idem)
  moreover have "eqButUID12 (friendReq s) (friendReq (createFriend s uid p uid'))"
    using uids unfolding eqButUID12_def
    by (auto simp add: c_defs fun_upd2_eq_but_a_b)
  ultimately show "eqButUID s s'" using step ou unfolding eqButUID_def by (auto simp add: c_defs)
qed (auto)

lemma Cact_cFriendReq_step_eqButUID:
assumes step: "step s (Cact (cFriendReq uid p uid' req)) = (ou,s')"
and uids: "(uid = UID1 \<and> uid' = UID2) \<or> (uid = UID2 \<and> uid' = UID1)" (is "?u12 \<or> ?u21")
shows "eqButUID s s'"
using assms proof (cases)
  assume ou: "ou = outOK"
  then have "uid \<notin> set (pendingFReqs s uid')" "uid \<notin> set (friendIDs s uid')"
    using step by (auto simp add: c_defs)
  then have "eqButUIDf (pendingFReqs s) (pendingFReqs (createFriendReq s uid p uid' req))"
    using uids UID1_UID2 unfolding eqButUIDf_def
    by (cases "?u12") (auto simp add: c_defs remove1_idem remove1_append)
  moreover have "eqButUID12 (friendReq s) (friendReq (createFriendReq s uid p uid' req))"
    using uids unfolding eqButUID12_def
    by (auto simp add: c_defs fun_upd2_eq_but_a_b)
  ultimately show "eqButUID s s'" using step ou unfolding eqButUID_def by (auto simp add: c_defs)
qed (auto)

lemma Dact_dFriend_step_eqButUID:
assumes step: "step s (Dact (dFriend uid p uid')) = (ou,s')"
and s: "reach s"
and uids: "(uid = UID1 \<and> uid' = UID2) \<or> (uid = UID2 \<and> uid' = UID1)" (is "?u12 \<or> ?u21")
shows "eqButUID s s'"
using assms proof (cases)
  assume ou: "ou = outOK"
  then have "uid' \<in>\<in> friendIDs s uid" using step by (auto simp add: d_defs)
  then have fRs: "distinct (friendIDs s uid)" "distinct (friendIDs s uid')"
    using reach_distinct_friends_reqs[OF s] by auto
  have "eqButUIDf (friendIDs s) (friendIDs (deleteFriend s uid p uid'))"
    using fRs uids UID1_UID2 unfolding eqButUIDf_def
    by (cases "?u12") (auto simp add: d_defs remove1_idem distinct_remove1_removeAll)
  then show "eqButUID s s'" using step ou unfolding eqButUID_def by (auto simp add: d_defs)
qed (auto)

(* Key lemma: *)
lemma eqButUID_step:
assumes ss1: "eqButUID s s1"
and step: "step s a = (ou,s')"
and step1: "step s1 a = (ou1,s1')"
and rs: "reach s"
and rs1: "reach s1"
shows "eqButUID s' s1'"
proof -
  note simps = eqButUID_def s_defs c_defs u_defs r_defs l_defs
  from assms show ?thesis proof (cases a)
    case (Sact sa) with assms show ?thesis by (cases sa) (auto simp add: simps)
  next
    case (Cact ca) note a = this
      with assms show ?thesis proof (cases ca)
        case (cFriendReq uid p uid' req) note ca = this
          then show ?thesis
          proof (cases "(uid = UID1 \<and> uid' = UID2) \<or> (uid = UID2 \<and> uid' = UID1)")
            case True
              then have "eqButUID s s'" and "eqButUID s1 s1'"
                using step step1 unfolding a ca
                by (auto intro: Cact_cFriendReq_step_eqButUID)
              with ss1 show "eqButUID s' s1'" by (auto intro: eqButUID_sym eqButUID_trans)
          next
            case False
              have fRs: "eqButUIDf (pendingFReqs s) (pendingFReqs s1)"
               and fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" using ss1 by (auto simp: simps)
              then have uid_uid': "uid \<in>\<in> pendingFReqs s uid' \<longleftrightarrow> uid \<in>\<in> pendingFReqs s1 uid'"
                                  "uid \<in>\<in> friendIDs s uid' \<longleftrightarrow> uid \<in>\<in> friendIDs s1 uid'"
                using False by (auto intro!: eqButUIDf_not_UID')
              have "eqButUIDf ((pendingFReqs s)(uid' := pendingFReqs s uid' ## uid))
                              ((pendingFReqs s1)(uid' := pendingFReqs s1 uid' ## uid))"
                using fRs False
                by (intro eqButUIDf_cong) (auto simp add: remove1_append remove1_idem eqButUIDf_def)
              moreover have "eqButUID12 (fun_upd2 (friendReq s) uid uid' req)
                                        (fun_upd2 (friendReq s1) uid uid' req)"
                using ss1 by (intro eqButUID12_cong) (auto simp: simps)
              moreover have "e_createFriendReq s uid p uid' req
                         \<longleftrightarrow> e_createFriendReq s1 uid p uid' req"
                using uid_uid' ss1 by (auto simp: simps)
              ultimately show ?thesis using assms unfolding a ca by (auto simp: simps)
          qed
      next
        case (cFriend uid p uid') note ca = this
          then show ?thesis
          proof (cases "(uid = UID1 \<and> uid' = UID2) \<or> (uid = UID2 \<and> uid' = UID1)")
            case True
              then have "eqButUID s s'" and "eqButUID s1 s1'"
                using step step1 rs rs1 unfolding a ca
                by (auto intro!: Cact_cFriend_step_eqButUID)+
              with ss1 show "eqButUID s' s1'" by (auto intro: eqButUID_sym eqButUID_trans)
          next
            case False
              have fRs: "eqButUIDf (pendingFReqs s) (pendingFReqs s1)"
                    (is "eqButUIDf (?pfr s) (?pfr s1)")
               and fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" using ss1 by (auto simp: simps)
              then have uid_uid': "uid \<in>\<in> pendingFReqs s uid' \<longleftrightarrow> uid \<in>\<in> pendingFReqs s1 uid'"
                                  "uid' \<in>\<in> pendingFReqs s uid \<longleftrightarrow> uid' \<in>\<in> pendingFReqs s1 uid"
                                  "uid \<in>\<in> friendIDs s uid' \<longleftrightarrow> uid \<in>\<in> friendIDs s1 uid'"
                                  "uid' \<in>\<in> friendIDs s uid \<longleftrightarrow> uid' \<in>\<in> friendIDs s1 uid"
                using False by (auto intro!: eqButUIDf_not_UID')
              have "eqButUIDl UID1 (remove1 uid' (?pfr s UID2)) (remove1 uid' (?pfr s1 UID2))"
               and "eqButUIDl UID2 (remove1 uid' (?pfr s UID1)) (remove1 uid' (?pfr s1 UID1))"
               and "eqButUIDl UID1 (remove1 uid (?pfr s UID2)) (remove1 uid (?pfr s1 UID2))"
               and "eqButUIDl UID2 (remove1 uid (?pfr s UID1)) (remove1 uid (?pfr s1 UID1))"
               using fRs unfolding eqButUIDf_def
               by (auto intro!: eqButUIDl_remove1_cong simp del: eqButUIDl.simps)
              then have 1: "eqButUIDf ((?pfr s)(uid := remove1 uid' (?pfr s uid),
                                                uid' := remove1 uid (?pfr s uid')))
                                     ((?pfr s1)(uid := remove1 uid' (?pfr s1 uid),
                                                uid' := remove1 uid (?pfr s1 uid')))"
                using fRs False
                by (intro eqButUIDf_cong) (auto simp add: eqButUIDf_def)
              have "uid = UID1 \<Longrightarrow> eqButUIDl UID2 (friendIDs s UID1 ## uid') (friendIDs s1 UID1 ## uid')"
               and "uid = UID2 \<Longrightarrow> eqButUIDl UID1 (friendIDs s UID2 ## uid') (friendIDs s1 UID2 ## uid')"
               and "uid' = UID1 \<Longrightarrow> eqButUIDl UID2 (friendIDs s UID1 ## uid) (friendIDs s1 UID1 ## uid)"
               and "uid' = UID2 \<Longrightarrow> eqButUIDl UID1 (friendIDs s UID2 ## uid) (friendIDs s1 UID2 ## uid)"
                using fIDs uid_uid' by - (intro eqButUIDl_snoc_cong; simp add: eqButUIDf_def)+
              then have 2: "eqButUIDf ((friendIDs s)(uid := friendIDs s uid ## uid',
                                                      uid' := friendIDs s uid' ## uid))
                                       ((friendIDs s1)(uid := friendIDs s1 uid ## uid',
                                                       uid' := friendIDs s1 uid' ## uid))"
                using fIDs by (intro eqButUIDf_cong) (auto simp add: eqButUIDf_def)
              have 3: "eqButUID12 (fun_upd2 (fun_upd2 (friendReq s) uid' uid emptyReq)
                                                                    uid uid' emptyReq)
                                  (fun_upd2 (fun_upd2 (friendReq s1) uid' uid emptyReq)
                                                                     uid uid' emptyReq)"
                using ss1 by (intro eqButUID12_cong) (auto simp: simps)
              have "e_createFriend s uid p uid'
                \<longleftrightarrow> e_createFriend s1 uid p uid'"
                using uid_uid' ss1 by (auto simp: simps)
              with 1 2 3 show ?thesis using assms unfolding a ca by (auto simp: simps)
          qed
      qed (auto simp: simps)
  next
    case (Uact ua) with assms show ?thesis by (cases ua) (auto simp add: simps)
  next
    case (Ract ra) with assms show ?thesis by (cases ra) (auto simp add: simps)
  next
    case (Lact la) with assms show ?thesis by (cases la) (auto simp add: simps)
  next
    case (Dact da) note a = this
      with assms show ?thesis proof (cases da)
        case (dFriend uid p uid') note ca = this
          then show ?thesis
          proof (cases "(uid = UID1 \<and> uid' = UID2) \<or> (uid = UID2 \<and> uid' = UID1)")
            case True
              then have "eqButUID s s'" and "eqButUID s1 s1'"
                using step step1 rs rs1 unfolding a ca
                by (auto intro!: Dact_dFriend_step_eqButUID)+
              with ss1 show "eqButUID s' s1'" by (auto intro: eqButUID_sym eqButUID_trans)
          next
            case False
              have fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" using ss1 by (auto simp: simps)
              then have uid_uid': "uid \<in>\<in> friendIDs s uid' \<longleftrightarrow> uid \<in>\<in> friendIDs s1 uid'"
                                  "uid' \<in>\<in> friendIDs s uid \<longleftrightarrow> uid' \<in>\<in> friendIDs s1 uid"
                using False by (auto intro!: eqButUIDf_not_UID')
              have dfIDs: "distinct (friendIDs s uid)" "distinct (friendIDs s uid')"
                          "distinct (friendIDs s1 uid)" "distinct (friendIDs s1 uid')"
                using reach_distinct_friends_reqs[OF rs] reach_distinct_friends_reqs[OF rs1] by auto
              have "uid = UID1 \<Longrightarrow> eqButUIDl UID2 (remove1 uid' (friendIDs s UID1)) (remove1 uid' (friendIDs s1 UID1))"
               and "uid = UID2 \<Longrightarrow> eqButUIDl UID1 (remove1 uid' (friendIDs s UID2)) (remove1 uid' (friendIDs s1 UID2))"
               and "uid' = UID1 \<Longrightarrow> eqButUIDl UID2 (remove1 uid (friendIDs s UID1)) (remove1 uid (friendIDs s1 UID1))"
               and "uid' = UID2 \<Longrightarrow> eqButUIDl UID1 (remove1 uid (friendIDs s UID2)) (remove1 uid (friendIDs s1 UID2))"
                using fIDs uid_uid' by - (intro eqButUIDl_remove1_cong; simp add: eqButUIDf_def)+
              then have 1: "eqButUIDf ((friendIDs s)(uid := remove1 uid' (friendIDs s uid),
                                                      uid' := remove1 uid (friendIDs s uid')))
                                       ((friendIDs s1)(uid := remove1 uid' (friendIDs s1 uid),
                                                       uid' := remove1 uid (friendIDs s1 uid')))"
                using fIDs by (intro eqButUIDf_cong) (auto simp add: eqButUIDf_def)
              have "e_deleteFriend s uid p uid'
                \<longleftrightarrow> e_deleteFriend s1 uid p uid'"
                using uid_uid' ss1 by (auto simp: simps d_defs)
              with 1 show ?thesis using assms dfIDs unfolding a ca
                by (auto simp: simps d_defs distinct_remove1_removeAll)
          qed
      qed
  qed
qed

lemma eqButUID_openByA_eq:
assumes "eqButUID s s1"
shows "openByA s = openByA s1"
using assms unfolding openByA_def eqButUID_def by auto

lemma eqButUID_openByF_eq:
assumes ss1: "eqButUID s s1"
shows "openByF s = openByF s1"
proof -
  from ss1 have fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" unfolding eqButUID_def by auto
  have "\<forall>uid \<in> UIDs. uid \<in>\<in> friendIDs s UID1 \<longleftrightarrow> uid \<in>\<in> friendIDs s1 UID1"
    using UID1_UID2_UIDs UID1_UID2 by (intro ballI eqButUIDf_not_UID'[OF fIDs]; auto)
  moreover have "\<forall>uid \<in> UIDs. uid \<in>\<in> friendIDs s UID2 \<longleftrightarrow> uid \<in>\<in> friendIDs s1 UID2"
    using UID1_UID2_UIDs UID1_UID2 by (intro ballI eqButUIDf_not_UID'[OF fIDs]; auto)
  ultimately show "openByF s = openByF s1" unfolding openByF_def by auto
qed

lemma eqButUID_open_eq: "eqButUID s s1 \<Longrightarrow> open s = open s1"
using eqButUID_openByA_eq eqButUID_openByF_eq unfolding open_def by blast

lemma eqButUID_step_friendIDs_eq:
assumes ss1: "eqButUID s s1"
and rs: "reach s" and rs1: "reach s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
and a: "a \<noteq> Cact (cFriend UID1 (pass s UID1) UID2) \<and> a \<noteq> Cact (cFriend UID2 (pass s UID2) UID1) \<and>
        a \<noteq> Dact (dFriend UID1 (pass s UID1) UID2) \<and> a \<noteq> Dact (dFriend UID2 (pass s UID2) UID1)"
and "friendIDs s = friendIDs s1"
shows "friendIDs s' = friendIDs s1'"
using assms proof (cases a)
  case (Sact sa) then show ?thesis using assms by (cases sa) (auto simp: s_defs) next
  case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: u_defs) next
  case (Dact da) then show ?thesis using assms proof (cases da)
    case (dFriend uid p uid')
      with Dact assms show ?thesis
        by (cases "(uid,uid') \<in> {(UID1,UID2), (UID2,UID1)}")
           (auto simp: d_defs eqButUID_def eqButUIDf_not_UID')
    qed
next
  case (Cact ca) then show ?thesis using assms proof (cases ca)
    case (cFriend uid p uid')
      with Cact assms show ?thesis
        by (cases "(uid,uid') \<in> {(UID1,UID2), (UID2,UID1)}")
           (auto simp: c_defs eqButUID_def eqButUIDf_not_UID')
    qed (auto simp: c_defs)
qed auto

lemma eqButUID_step_\<phi>_imp:
assumes ss1: "eqButUID s s1"
and rs: "reach s" and rs1: "reach s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
and a: "a \<noteq> Cact (cFriend UID1 (pass s UID1) UID2) \<and> a \<noteq> Cact (cFriend UID2 (pass s UID2) UID1) \<and>
        a \<noteq> Dact (dFriend UID1 (pass s UID1) UID2) \<and> a \<noteq> Dact (dFriend UID2 (pass s UID2) UID1)"
and \<phi>: "\<phi> (Trans s a ou s')"
shows "\<phi> (Trans s1 a ou1 s1')"
proof -
  have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
  then have "open s = open s1" and "open s' = open s1'"
        and "openByA s = openByA s1" and "openByA s' = openByA s1'"
        and "openByF s = openByF s1" and "openByF s' = openByF s1'"
    using ss1 by (auto simp: eqButUID_open_eq eqButUID_openByA_eq eqButUID_openByF_eq)
  with \<phi> a step step1 show "\<phi> (Trans s1 a ou1 s1')" using UID1_UID2_UIDs
    by (elim \<phi>.elims) (auto simp: c_defs d_defs)
qed

(* Key lemma: *)
lemma eqButUID_step_\<phi>:
assumes ss1: "eqButUID s s1"
and rs: "reach s" and rs1: "reach s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
and a: "a \<noteq> Cact (cFriend UID1 (pass s UID1) UID2) \<and> a \<noteq> Cact (cFriend UID2 (pass s UID2) UID1) \<and>
        a \<noteq> Dact (dFriend UID1 (pass s UID1) UID2) \<and> a \<noteq> Dact (dFriend UID2 (pass s UID2) UID1)"
shows "\<phi> (Trans s a ou s') = \<phi> (Trans s1 a ou1 s1')"
proof
  assume "\<phi> (Trans s a ou s')"
  with assms show "\<phi> (Trans s1 a ou1 s1')" by (rule eqButUID_step_\<phi>_imp)
next
  assume "\<phi> (Trans s1 a ou1 s1')"
  moreover have "eqButUID s1 s" using ss1 by (rule eqButUID_sym)
  moreover have "a \<noteq> Cact (cFriend UID1 (pass s1 UID1) UID2) \<and>
                 a \<noteq> Cact (cFriend UID2 (pass s1 UID2) UID1) \<and>
                 a \<noteq> Dact (dFriend UID1 (pass s1 UID1) UID2) \<and>
                 a \<noteq> Dact (dFriend UID2 (pass s1 UID2) UID1)"
    using a ss1 unfolding eqButUID_def by auto
  ultimately show "\<phi> (Trans s a ou s')" using rs rs1 step step1
    by (intro eqButUID_step_\<phi>_imp[of s1 s])
qed

lemma createFriend_sym: "createFriend s uid p uid' = createFriend s uid' p' uid"
unfolding c_defs by (cases "uid = uid'") (auto simp: fun_upd2_comm fun_upd_twist)

lemma deleteFriend_sym: "deleteFriend s uid p uid' = deleteFriend s uid' p' uid"
unfolding d_defs by (cases "uid = uid'") (auto simp: fun_upd_twist)

lemma createFriendReq_createFriend_absorb:
assumes "e_createFriendReq s uid' p uid req"
shows "createFriend (createFriendReq s uid' p1 uid req) uid p2 uid' = createFriend s uid p3 uid'"
using assms unfolding c_defs by (auto simp: remove1_idem remove1_append fun_upd2_absorb)

lemma eqButUID_deleteFriend12_friendIDs_eq:
assumes ss1: "eqButUID s s1"
and rs: "reach s" and rs1: "reach s1"
shows "friendIDs (deleteFriend s UID1 p UID2) = friendIDs (deleteFriend s1 UID1 p' UID2)"
proof -
  have "distinct (friendIDs s UID1)" "distinct (friendIDs s UID2)"
       "distinct (friendIDs s1 UID1)" "distinct (friendIDs s1 UID2)"
    using rs rs1 by (auto intro: reach_distinct_friends_reqs)
  then show ?thesis
    using ss1 unfolding eqButUID_def eqButUIDf_def unfolding d_defs
    by (auto simp: distinct_remove1_removeAll)
qed

lemma eqButUID_createFriend12_friendIDs_eq:
assumes ss1: "eqButUID s s1"
and rs: "reach s" and rs1: "reach s1"
and f12: "\<not>friends12 s" "\<not>friends12 s1"
shows "friendIDs (createFriend s UID1 p UID2) = friendIDs (createFriend s1 UID1 p' UID2)"
proof -
  have f12': "UID1 \<notin> set (friendIDs s UID2)" "UID2 \<notin> set (friendIDs s UID1)"
             "UID1 \<notin> set (friendIDs s1 UID2)" "UID2 \<notin> set (friendIDs s1 UID1)"
    using f12 rs rs1 reach_friendIDs_symmetric unfolding friends12_def by auto
  have "friendIDs s = friendIDs s1"
  proof (intro ext)
    fix uid
    show "friendIDs s uid = friendIDs s1 uid"
      using ss1 f12' unfolding eqButUID_def eqButUIDf_def
      by (cases "uid = UID1 \<or> uid = UID2") (auto simp: remove1_idem)
  qed
  then show ?thesis by (auto simp: c_defs)
qed

end


theory Ell1
imports Main Tools Setsum_Infinite Real_Vector_Spaces Complete_Lattices "~~/src/HOL/Probability/Binary_Product_Measure"
begin

subsection {* ell1 (absolutely convergent real series) *}
typedef 'a ell1 = "{\<mu>::'a\<Rightarrow>real. SetSums (\<lambda>x. abs(\<mu> x)) UNIV}"
  apply (rule exI[of _ "\<lambda>x. 0"], auto) unfolding SetSums_def
  using setsum_0 by auto

instantiation ell1 :: (type) zero begin
definition zero_ell1 :: "'a ell1" where "zero_ell1 = Abs_ell1 (\<lambda>x. 0)";
instance ..
end

instantiation ell1 :: (type) comm_monoid_add begin
definition "\<mu> + \<nu> = Abs_ell1 (\<lambda>x. Rep_ell1 \<mu> x + Rep_ell1 \<nu> x)"
instance apply intro_classes sorry
end

instantiation ell1 :: (type) real_vector begin
definition "\<mu> - \<nu> = Abs_ell1 (\<lambda>x. Rep_ell1 \<mu> x - Rep_ell1 \<nu> x)"
definition "-(\<nu>::'a ell1) = 0-\<nu>"
definition "scaleR r (\<mu>::'a ell1) = Abs_ell1 (\<lambda>x. r * Rep_ell1 \<mu> x)"
instance apply intro_classes sorry
end

instantiation ell1 :: (type) real_normed_vector begin
definition "norm_ell1 (s::'a ell1) = SetSum (\<lambda>x. abs(Rep_ell1 s x)) UNIV"
definition "dist_ell1 (s::'a ell1) t = norm (s-t)"
definition "open_ell1 (S::'a ell1 set) = (\<forall>x\<in>S. \<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S)"
definition "sgn_ell1 (s::'a ell1) = s /\<^sub>R norm s"
instance apply intro_classes sorry
end

instantiation ell1 :: (type) order begin
definition "s \<le> (t::'a ell1) = (\<forall>x. Rep_ell1 s x \<le> Rep_ell1 t x)"
definition "s < (t::'a ell1) = (s \<le> t \<and> s \<noteq> t)"
instance apply intro_classes sorry
end

instantiation ell1 :: (type) ordered_real_vector begin
instance apply intro_classes sorry
end

definition "weight_ell1 \<mu> = SetSum (\<lambda>x. Rep_ell1 \<mu> x) UNIV"

definition point_ell1 :: "'a \<Rightarrow> 'a ell1" where "point_ell1 a = Abs_ell1 (\<lambda>x. if x=a then 1 else 0)";

consts compose_ell1 :: "('a \<Rightarrow> 'b ell1) \<Rightarrow> 'a ell1 \<Rightarrow> 'b ell1";
definition apply_to_ell1 :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a ell1 \<Rightarrow> 'b ell1" where
  "apply_to_ell1 f = compose_ell1 (\<lambda>x. point_ell1 (f x))"
definition "support_ell1 \<mu> = {x. Rep_ell1 \<mu> x \<noteq> 0}"

lemma apply_to_ell1_twice [simp]: "apply_to_ell1 f (apply_to_ell1 g \<mu>) = apply_to_ell1 (\<lambda>x. f (g x)) \<mu>"
  sorry

lemma apply_to_ell1_id [simp]: "apply_to_ell1 (\<lambda>x. x) \<mu> = \<mu>"
  sorry

lemma support_compose_ell1 [simp]: "support_ell1 (compose_ell1 f g) = (\<Union>x\<in>support_ell1 g. support_ell1 (f x))"
  sorry

lemma support_apply_to_ell1 [simp]: "support_ell1 (apply_to_ell1 f \<mu>) = f ` support_ell1 \<mu>"
  sorry

lemma support_point_ell1 [simp]: "support_ell1 (point_ell1 x) = {x}"
  sorry

definition "product_ell1 \<mu> \<nu> = Abs_ell1 (\<lambda>(x,y). Rep_ell1 \<mu> x * Rep_ell1 \<nu> y)"
lemma fst_product_ell1 [simp]: "apply_to_ell1 fst (product_ell1 \<mu> \<nu>) = weight_ell1 \<nu> *\<^sub>R \<mu>"
  sorry
lemma snd_product_ell1 [simp]: "apply_to_ell1 snd (product_ell1 \<mu> \<nu>) = weight_ell1 \<mu> *\<^sub>R \<nu>"
  sorry
lemma support_product_ell1 [simp]: "support_ell1 (product_ell1 \<mu> \<nu>) = support_ell1 \<mu> \<times> support_ell1 \<nu>"
  sorry
lemma product_ell1_sym: "apply_to_ell1 (\<lambda>(x,y). (y,x)) (product_ell1 \<mu> \<nu>) = product_ell1 \<nu> \<mu>"
  sorry

lemma apply_to_point_ell1 [simp]: "apply_to_ell1 f (point_ell1 x) = point_ell1 (f x)"
  sorry
lemma point_ell1_inj: "point_ell1 x = point_ell1 y \<Longrightarrow> x = y"
  sorry

subsection {* Distributions (with weight <= 1) *}

typedef 'a distr = "{M::'a measure. emeasure M (space M) \<le> 1 \<and> space M = UNIV \<and> sets M = UNIV}"
  by (rule exI[of _ "sigma UNIV UNIV"], auto simp: emeasure_sigma)
definition "distr_pre d == emeasure (Rep_distr d)"
definition "distr_pr d == measure (Rep_distr d)"
abbreviation "distr_pr1 d x == distr_pr d {x}"

definition support_distr :: "'a distr \<Rightarrow> 'a set" where
  "support_distr \<mu> = {x. distr_pr1 \<mu> x > 0}"

instantiation distr :: (type) zero begin
definition zero_distr :: "'a distr" where "zero_distr = Abs_distr (sigma UNIV UNIV)";
instance ..
end

instantiation distr :: (type) scaleR begin
definition "scaleR_distr r \<mu> = Abs_distr (measure_of
  (space (Rep_distr \<mu>)) (sets (Rep_distr \<mu>)) (\<lambda>E. ereal r * emeasure (Rep_distr \<mu>) E))"
instance ..
end

lemma scaleR_one_distr [simp]: "1 *\<^sub>R (\<mu>::'a distr) = \<mu>"
  unfolding scaleR_distr_def one_ereal_def[symmetric]
  by (auto simp: measure_of_of_measure Rep_distr_inverse)

abbreviation "weight_distr \<mu> == distr_pr \<mu> UNIV"

lemma Rep_Abs_distr_measure_of: "X UNIV \<le> 1 \<Longrightarrow> Rep_distr (Abs_distr (measure_of UNIV UNIV X)) = measure_of UNIV UNIV X"
  apply (subst Abs_distr_inverse) by (auto simp: emeasure_measure_of_conv)

definition "mk_distr (f::_\<Rightarrow>real) == Abs_distr (measure_of UNIV UNIV f)"
definition "mk_distre (f::_\<Rightarrow>ereal) == Abs_distr (measure_of UNIV UNIV f)"
print_theorems
lemma mk_distre_pr:
  assumes "f UNIV \<le> 1"
  assumes "\<And>x. f x \<ge> 0"
  assumes "f {} = 0"
  assumes "\<And>A. disjoint_family A \<Longrightarrow> (\<Sum>i. f (A i)) = f (\<Union>i. A i)"
  shows "distr_pre (mk_distre f) = f"
proof -
  have sigma_UNIV: "sigma_sets UNIV UNIV = UNIV"
    by (metis UNIV_eq_I iso_tuple_UNIV_I sigma_sets.Basic)
  have "measure_space UNIV (sigma_sets UNIV UNIV) f"
    unfolding measure_space_def apply auto
    apply (metis Pow_UNIV sigma_algebra_sigma_sets top_greatest)
    unfolding positive_def using assms close auto
    unfolding sigma_UNIV countably_additive_def
    using assms by auto
  thus ?thesis
    unfolding mk_distre_def distr_pre_def
    apply (subst Abs_distr_inverse)
    by (auto simp: emeasure_measure_of_conv assms)
qed

lemma mk_distr_pr:
  assumes "f UNIV \<le> 1"
  assumes "\<And>x. f x \<ge> 0"
  assumes "f {} = 0"
  assumes "\<And>A. disjoint_family A \<Longrightarrow> (\<Sum>i. f (A i)) = f (\<Union>i. A i)"
  shows "distr_pr (mk_distr f) = f"
sorry

definition point_distr :: "'a \<Rightarrow> 'a distr" where
  "point_distr a = mk_distr (\<lambda>E. if a\<in>E then 1 else 0)";
lemma point_distr_pr: "distr_pr (point_distr a) E = (if a\<in>E then 1 else 0)"
  unfolding point_distr_def apply (subst mk_distr_pr, auto)
  sorry
lemma weight_point_distr [simp]: "weight_distr (point_distr x) = 1"
  unfolding point_distr_pr by simp

definition compose_distr :: "('a \<Rightarrow> 'b distr) \<Rightarrow> 'a distr \<Rightarrow> 'b distr" where
  "compose_distr f \<mu> == mk_distre (\<lambda>E. (\<integral>\<^sup>+ a. distr_pre (f a) E \<partial>Rep_distr \<mu>))"
definition apply_to_distr :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a distr \<Rightarrow> 'b distr" where
  "apply_to_distr f \<mu> = Abs_distr (distr (Rep_distr \<mu>) (sigma UNIV UNIV) f)"

lemma apply_to_distr_twice [simp]: "apply_to_distr f (apply_to_distr g \<mu>) = apply_to_distr (\<lambda>x. f (g x)) \<mu>"
proof -
  let ?\<mu> = "Rep_distr \<mu>"
  have valid: "emeasure (distr (Rep_distr \<mu>) (sigma UNIV UNIV) g) UNIV \<le> 1" sorry
  show ?thesis
    unfolding apply_to_distr_def
    apply (subst Abs_distr_inverse, auto simp: valid)
    apply (subst distr_distr)
    unfolding measurable_def o_def
    by (auto intro: Rep_distr)
qed

lemma apply_to_distr_id [simp]: "apply_to_distr (\<lambda>x. x) \<mu> = \<mu>"
proof -
  let ?\<mu> = "Rep_distr \<mu>"
  have "?\<mu> = distr ?\<mu> ?\<mu> (\<lambda>x .x)" using distr_id by auto
  moreover have "... = distr ?\<mu> (sigma UNIV UNIV) (\<lambda>x. x)"
    by (rule distr_cong, auto)
  finally have eq:"... = ?\<mu>" by simp
  show ?thesis
    unfolding apply_to_distr_def unfolding eq
    by (rule Rep_distr_inverse)
qed

lemma support_compose_distr [simp]: "support_distr (compose_distr f g) = (\<Union>x\<in>support_distr g. support_distr (f x))"
  sorry

lemma support_apply_to_distr [simp]: "support_distr (apply_to_distr f \<mu>) = f ` support_distr \<mu>"
  sorry

lemma support_point_distr [simp]: "support_distr (point_distr x) = {x}"
  sorry

definition "product_distr \<mu> \<nu> = Abs_distr (Rep_distr \<mu>  \<Otimes>\<^sub>M  Rep_distr \<nu>)"

lemma [simp]: "sigma_finite_measure (Rep_distr \<mu>)"
  unfolding sigma_finite_measure_def apply (rule exI[of _ "{UNIV}"])
  apply auto using Rep_distr
  by (metis (full_types, lifting) ereal_infty_less_eq(1) ereal_times(1) mem_Collect_eq)

lemma fst_product_distr [simp]: "apply_to_distr fst (product_distr \<mu> \<nu>) = weight_distr \<nu> *\<^sub>R \<mu>"
  sorry
lemma snd_product_distr [simp]: "apply_to_distr snd (product_distr \<mu> \<nu>) = weight_distr \<mu> *\<^sub>R \<nu>"
  sorry
lemma support_product_distr [simp]: "support_distr (product_distr \<mu> \<nu>) = support_distr \<mu> \<times> support_distr \<nu>"
  sorry
lemma product_distr_sym: "apply_to_distr (\<lambda>(x,y). (y,x)) (product_distr \<mu> \<nu>) = product_distr \<nu> \<mu>"
proof -
  have \<mu>1: "emeasure (Rep_distr \<mu>) UNIV \<le> 1" and \<nu>1: "emeasure (Rep_distr \<nu>) UNIV \<le> 1" using Rep_distr by auto
  have 11: "1::ereal == 1 * 1" by auto
  have mult_mono: "\<And>a b c d. a\<le>c \<Longrightarrow> b\<le>d \<Longrightarrow> b\<ge>0 \<Longrightarrow> c\<ge>0 \<Longrightarrow> (a::ereal) * b \<le> c * d"
    by (metis ereal_mult_left_mono mult.commute order_trans)
  have leq1: "emeasure (Rep_distr \<mu>) UNIV * emeasure (Rep_distr \<nu>) UNIV \<le> 1"
    apply (subst 11) apply (rule mult_mono) using Rep_distr by auto
  have leq1': "emeasure (Rep_distr \<mu> \<Otimes>\<^sub>M Rep_distr \<nu>) UNIV \<le> 1"
    apply (subst UNIV_Times_UNIV[symmetric])
    unfolding space_pair_measure apply simp
    apply (subst UNIV_Times_UNIV[symmetric])
    by (subst sigma_finite_measure.emeasure_pair_measure_Times, auto simp: leq1)
  show ?thesis
    unfolding apply_to_distr_def product_distr_def
    apply (subst Abs_distr_inverse)
    apply (auto simp: leq1' space_pair_measure sets_pair_measure)
    find_theorems "sigma_sets UNIV" sorry

by
UNIV_Times_UNIV
  let ?\<mu> = "Rep_distr \<mu>" let ?\<nu> = "Rep_distr \<nu>"
apply  distr_pair_swap
  sorry

lemma apply_to_point_distr [simp]: "apply_to_distr f (point_distr x) = point_distr (f x)"
  sorry
lemma point_distr_inj: "point_distr x = point_distr y \<Longrightarrow> x = y"
  sorry

definition uniform :: "'a set \<Rightarrow> 'a distr" where
  "uniform S = Abs_distr (\<lambda>x. if x \<in> S then 1/(card S) else 0)"

lemma markov_chain:
  assumes "apply_to_distr snd \<mu>1 = apply_to_distr fst \<mu>2"
  obtains \<mu> where "apply_to_distr (\<lambda>(x::'a,y::'b,z::'c). (x,y)) \<mu> = \<mu>1"
              and "apply_to_distr (\<lambda>(x,y,z). (y,z)) \<mu> = \<mu>2"
proof
  def \<mu> == "undefined::('a*'b*'c) distr"
  show "apply_to_distr (\<lambda>(x,y,z). (x,y)) \<mu> = \<mu>1" sorry
  show "apply_to_distr (\<lambda>(x,y,z). (y,z)) \<mu> = \<mu>2" sorry
qed

lemma compose_point_distr_r [simp]: "compose_distr f (point_distr x) = f x"
  sorry
lemma compose_point_distr_l [simp]: "compose_distr (\<lambda>x. point_distr (f x)) \<mu> = apply_to_distr f \<mu>"
  unfolding apply_to_distr_def ..

lemma compose_distr_trans: "compose_distr (\<lambda>x. compose_distr g (f x)) \<mu> = compose_distr g (compose_distr f \<mu>)"
  sorry

subsection {* Combining ell1 and distr *}

definition "distr_to_ell1 \<mu> = Abs_ell1 (Rep_distr \<mu>)"
definition "ell1_to_distr \<mu> = Abs_distr (Rep_ell1 \<mu>)"

lemma distr_to_ell1_apply_comm [simp]: "distr_to_ell1 (apply_to_distr f \<mu>) = apply_to_ell1 f (distr_to_ell1 \<mu>)"
  sorry
lemma support_distr_to_ell1 [simp]: "support_ell1 (distr_to_ell1 \<mu>) = support_distr \<mu>"
  sorry

end