theory lezpAdd

imports Main
        "../nats"
(* NB: just testing. Realised Isabelle imports the first theory module with a matching name,
      regardless of the theory name. However, to be checked: happened at exploration and the
      theory being imported was merely "../Naturals" :w *)

begin

(*hipster lezp add*)
lemma lemma_a [thy_expl]: "add x2 Z = x2"
by (hipster_induct_schemes nats.lezp.simps nats.add.simps)

lemma lemma_aa [thy_expl]: "add (add x2 y2) z2 = add x2 (add y2 z2)"
by (hipster_induct_schemes nats.lezp.simps nats.add.simps)

lemma lemma_ab [thy_expl]: "add x2 (S y2) = S (add x2 y2)"
by (hipster_induct_schemes nats.lezp.simps nats.add.simps)

lemma lemma_ac [thy_expl]: "add x2 (add y2 x2) = add y2 (add x2 x2)"
by (hipster_induct_schemes nats.lezp.simps nats.add.simps)

lemma lemma_ad [thy_expl]: "add x2 (add y2 y2) = add y2 (add y2 x2)"
by (hipster_induct_schemes nats.lezp.simps nats.add.simps)

lemma lemma_ae [thy_expl]: "add x2 (S y2) = S (add y2 x2)"
by (hipster_induct_schemes nats.lezp.simps nats.add.simps)

lemma lemma_af [thy_expl]: "add (S x2) y2 = S (add y2 x2)"
by (hipster_induct_schemes nats.lezp.simps nats.add.simps)

lemma lemma_ag [thy_expl]: "lezp (add x2 x2) = lezp x2"
by (hipster_induct_schemes nats.lezp.simps nats.add.simps)

lemma lemma_ah [thy_expl]: "add (add x2 y2) (add x2 z2) = add (add x2 z2) (add x2 y2)"
by (hipster_induct_schemes nats.lezp.simps nats.add.simps)

lemma lemma_ai [thy_expl]: "add (add x2 y2) (add z2 x2) = add (add z2 x2) (add x2 y2)"
by (hipster_induct_schemes nats.lezp.simps nats.add.simps)

lemma lemma_aj [thy_expl]: "add (add x3 y3) (add z3 y3) = add (add z3 x3) (add y3 y3)"
by (hipster_induct_schemes nats.lezp.simps nats.add.simps)

lemma lemma_ak [thy_expl]: "add (add x3 y3) (S z3) = add (add z3 x3) (S y3)"
by (hipster_induct_schemes nats.lezp.simps nats.add.simps)

lemma lemma_al [thy_expl]: "add (add x3 x3) (add y3 z3) = add (add x3 y3) (add x3 z3)"
by (hipster_induct_schemes nats.lezp.simps nats.add.simps)

lemma lemma_am [thy_expl]: "add (S x2) (add y2 z2) = add (add y2 x2) (S z2)"
by (hipster_induct_schemes nats.lezp.simps nats.add.simps)

lemma lemma_an [thy_expl]: "add (S x2) (add y2 z2) = add (add y2 z2) (S x2)"
by (hipster_induct_schemes nats.lezp.simps nats.add.simps)

lemma lemma_ao [thy_expl]: "add (S x2) (S y2) = add (S y2) (S x2)"
by (hipster_induct_schemes nats.lezp.simps nats.add.simps)

lemma lemma_ap [thy_expl]: "lezp y3 \<Longrightarrow> add x3 y3 = x3"
by (hipster_induct_schemes nats.lezp.simps nats.add.simps)

lemma lemma_aq [thy_expl]: "add x2 y2 = add y2 x2"
by (hipster_induct_schemes nats.lezp.simps nats.add.simps)

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsection \<open>Composition\<close>
theory TSFunctions_Composition
  imports TSFunctions_Base
begin

unbundle no_comp_syntax
unbundle no_restrict_syntax

lemma Dep_Function_comp_set_right_unique_on:
  assumes f_type: "f : (x : B) \<rightarrow>s (C x)"
  and g_type: "g : A \<rightarrow>s B"
  shows "set_right_unique_on A (f \<circ> g)"
proof -
  have "set_right_unique_on (rng g\<restriction>\<^bsub>A\<^esub> \<inter> dom f) f"
  proof -
    from f_type have "set_right_unique_on (type_pred B) f"
      by (auto dest: Dep_Function_set_right_unique_on)
    then have "set_right_unique_on (mem_of (rng g\<restriction>\<^bsub>A\<^esub> \<inter> dom f)) f"
      using antimonoD[OF antimono_set_right_unique_on_pred]
      by (rule le_boolD'')
      (insert g_type, auto intro!: le_predI elim!: mem_set_restrict_leftE)
    then show ?thesis by simp
  qed
  then show ?thesis using assms by (auto intro!: set_right_unique_on_compI
    dest: Dep_Function_set_right_unique_on)
qed

lemma Dep_Function_comp_eval_eq [simp]:
  assumes f_type: "f : (x : B) \<rightarrow>s (C x)"
  and g_type: "g : A \<rightarrow>s B"
  and x_type: "x : A"
  shows "(f \<circ> g)`x = f`(g`x)"
proof (rule eval_eqI)
  show "x : A" by (fact x_type)
  from assms show "\<langle>x, f`(g`x)\<rangle> \<in> f \<circ> g" by auto
qed (insert Dep_Function_comp_set_right_unique_on[OF f_type g_type], auto)

lemma set_comp_type_Dep_Function [type]:
  "(\<circ>) : ((x : B) \<rightarrow>s C x) \<Rightarrow> (g : A \<rightarrow>s B) \<Rightarrow> (x : A) \<rightarrow>s C (g`x)"
proof (intro Dep_fun_typeI Dep_FunctionI)
  fix f g assume "f : (x : B) \<rightarrow>s C x" "g : A \<rightarrow>s B"
  then show "set_right_unique_on A (f \<circ> g)"
    by (rule Dep_Function_comp_set_right_unique_on)
qed auto

lemma comp_type_CDep_Function [type]:
  "(\<circ>) : ((x : B) \<rightarrow>s C x) \<Rightarrow> (g : A \<rightarrow>cs B) \<Rightarrow> (x : A) \<rightarrow>cs C (g`x)"
proof (intro Dep_fun_typeI CDep_FunctionI Dep_Bin_RelI)
  fix f g p assume f_g_types: "f : (x : B) \<rightarrow>s C x" "g : A \<rightarrow>cs B" and "p \<in> f \<circ> g"
  then obtain x y z where "\<langle>x, y\<rangle> \<in> g" "\<langle>y, z\<rangle> \<in> f" "p = \<langle>x, z\<rangle>" by auto
  moreover with f_g_types have "x : A" "y : B" "g`x = y" by auto
  moreover with \<open>\<langle>y, z\<rangle> \<in> f\<close> f_g_types have "z : C y" by auto
  ultimately show "p : \<Sum>x : A. (C (g`x))" by simp
qed auto

lemma Function_lambda_comp_lambda_eq [simp]:
  assumes "f : Element A \<Rightarrow> Element B"
  shows "(\<lambda>y \<in> B. g y) \<circ> (\<lambda>x \<in> A. f x) = \<lambda>x \<in> A. g (f x)"
  using assms by (intro eqI) auto

end


(* Author: Mathias Fleury
   Minor additions by Peter Lammich
*)
theory Bits_Natural
  imports "HOL-Word.Word" Word_Lib.Aligned
begin

(* TODO: Move *)
lemma bin_trunc_xor':
  "bintrunc n x XOR bintrunc n y = bintrunc n (x XOR y)"
  by (auto simp add: bin_eq_iff bin_nth_ops nth_bintr)

lemma uint_xor: "uint (x XOR y) = uint x XOR uint y"
  by (transfer, simp add: bin_trunc_xor')

instantiation nat :: bit_comprehension
begin

definition test_bit_nat :: \<open>nat \<Rightarrow> nat \<Rightarrow> bool\<close> where
  "test_bit i j = test_bit (int i) j"

definition lsb_nat :: \<open>nat \<Rightarrow> bool\<close> where
  "lsb i = (int i :: int) !! 0"

definition set_bit_nat :: "nat \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> nat" where
  "set_bit i n b = nat (bin_sc n b (int i))"

definition set_bits_nat :: "(nat \<Rightarrow> bool) \<Rightarrow> nat" where
  "set_bits f =
  (if \<exists>n. \<forall>n'\<ge>n. \<not> f n' then
     let n = LEAST n. \<forall>n'\<ge>n. \<not> f n'
     in nat (bl_to_bin (rev (map f [0..<n])))
   else if \<exists>n. \<forall>n'\<ge>n. f n' then
     let n = LEAST n. \<forall>n'\<ge>n. f n'
     in nat (sbintrunc n (bl_to_bin (True # rev (map f [0..<n]))))
   else 0 :: nat)"

definition shiftl_nat where
  "shiftl x n = nat ((int x) * 2 ^ n)"

definition shiftr_nat where
  "shiftr x n = nat (int x div 2 ^ n)"

definition bitNOT_nat :: "nat \<Rightarrow> nat" where
  "bitNOT i = nat (bitNOT (int i))"

definition bitAND_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "bitAND i j = nat (bitAND (int i) (int j))"

definition bitOR_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "bitOR i j = nat (bitOR (int i) (int j))"

definition bitXOR_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "bitXOR i j = nat (bitXOR (int i) (int j))"

definition msb_nat :: "nat \<Rightarrow> bool" where
  "msb i = msb (int i)"

instance ..

end

lemma nat_shiftr[simp]:
  "m >> 0 = m"
  \<open>((0::nat) >> m) = 0\<close>
  \<open>(m >> Suc n) = (m div 2 >> n)\<close> for m :: nat
  by (auto simp: shiftr_nat_def zdiv_int zdiv_zmult2_eq[symmetric])

lemma nat_shifl_div: \<open>m >> n = m div (2^n)\<close> for m :: nat
  by (induction n arbitrary: m) (auto simp: div_mult2_eq)

lemma nat_shiftl[simp]:
  "m << 0 = m"
  \<open>((0::nat) << m) = 0\<close>
  \<open>(m << Suc n) = ((m * 2) << n)\<close> for m :: nat
  by (auto simp: shiftl_nat_def zdiv_int zdiv_zmult2_eq[symmetric])

lemma nat_shiftr_div2: \<open>m >> 1 = m div 2\<close> for m :: nat
  by auto

lemma nat_shiftr_div: \<open>m << n = m * (2^n)\<close> for m :: nat
  by (induction n arbitrary: m) (auto simp: div_mult2_eq)

definition shiftl1 :: \<open>nat \<Rightarrow> nat\<close> where
  \<open>shiftl1 n = n << 1\<close>

definition shiftr1 :: \<open>nat \<Rightarrow> nat\<close> where
  \<open>shiftr1 n = n >> 1\<close>

instantiation natural :: bit_comprehension
begin

context includes natural.lifting begin

lift_definition test_bit_natural :: \<open>natural \<Rightarrow> nat \<Rightarrow> bool\<close> is test_bit .

lift_definition lsb_natural :: \<open>natural \<Rightarrow> bool\<close> is lsb .

lift_definition set_bit_natural :: "natural \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> natural" is
  set_bit .

lift_definition set_bits_natural :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> natural\<close>
  is \<open>set_bits :: (nat \<Rightarrow> bool) \<Rightarrow> nat\<close> .

lift_definition shiftl_natural :: \<open>natural \<Rightarrow> nat \<Rightarrow> natural\<close>
  is \<open>shiftl :: nat \<Rightarrow> nat \<Rightarrow> nat\<close> .

lift_definition shiftr_natural :: \<open>natural \<Rightarrow> nat \<Rightarrow> natural\<close>
  is \<open>shiftr :: nat \<Rightarrow> nat \<Rightarrow> nat\<close> .

lift_definition bitNOT_natural :: \<open>natural \<Rightarrow> natural\<close>
  is \<open>bitNOT :: nat \<Rightarrow> nat\<close> .

lift_definition bitAND_natural :: \<open>natural \<Rightarrow> natural \<Rightarrow> natural\<close>
  is \<open>bitAND :: nat \<Rightarrow> nat \<Rightarrow> nat\<close> .

lift_definition bitOR_natural :: \<open>natural \<Rightarrow> natural \<Rightarrow> natural\<close>
  is \<open>bitOR :: nat \<Rightarrow> nat \<Rightarrow> nat\<close> .

lift_definition bitXOR_natural :: \<open>natural \<Rightarrow> natural \<Rightarrow> natural\<close>
  is \<open>bitXOR :: nat \<Rightarrow> nat \<Rightarrow> nat\<close> .

lift_definition msb_natural :: \<open>natural \<Rightarrow> bool\<close>
  is \<open>msb :: nat \<Rightarrow> bool\<close> .

end

instance ..
end

lemma bitXOR_1_if_mod_2: \<open>bitXOR L 1 = (if L mod 2 = 0 then L + 1 else L - 1)\<close> for L :: nat
  apply transfer
  apply (subst int_int_eq[symmetric])
  apply (rule bin_rl_eqI)
   apply (auto simp: bitXOR_nat_def)
  unfolding bin_rest_def bin_last_def bitXOR_nat_def
       apply presburger+
  done

lemma bitAND_1_mod_2: \<open>bitAND L 1 = L mod 2\<close> for L :: nat
  apply transfer
  apply (subst int_int_eq[symmetric])
  apply (subst bitAND_nat_def)
  by (auto simp: zmod_int bin_rest_def bin_last_def bitval_bin_last[symmetric])

lemma nat_set_bit_0: \<open>set_bit x 0 b = nat ((bin_rest (int x)) BIT b)\<close> for x :: nat
  by (auto simp: set_bit_nat_def)

lemma nat_test_bit0_iff: \<open>n !! 0 \<longleftrightarrow> n mod 2 = 1\<close> for n :: nat
proof -
  have 2: \<open>2 = int 2\<close>
    by auto
  have [simp]: \<open>int n mod 2 = 1 \<longleftrightarrow> n mod 2 = Suc 0\<close>
    unfolding 2 zmod_int[symmetric]
    by auto

  show ?thesis
    unfolding test_bit_nat_def
    by (auto simp: bin_last_def zmod_int)
qed
lemma test_bit_2: \<open>m > 0 \<Longrightarrow> (2*n) !! m \<longleftrightarrow> n !! (m - 1)\<close> for n :: nat
  by (cases m)
    (auto simp: test_bit_nat_def bin_rest_def)

lemma test_bit_Suc_2: \<open>m > 0 \<Longrightarrow> Suc (2 * n) !! m \<longleftrightarrow> (2 * n) !! m\<close> for n :: nat
  by (cases m)
    (auto simp: test_bit_nat_def bin_rest_def)

lemma bin_rest_prev_eq:
  assumes [simp]: \<open>m > 0\<close>
  shows  \<open>nat ((bin_rest (int w))) !! (m - Suc (0::nat)) = w !! m\<close>
proof -
  define m' where \<open>m' = w div 2\<close>
  have w: \<open>w = 2 * m' \<or> w = Suc (2 * m')\<close>
    unfolding m'_def
    by auto
  moreover have \<open>bin_nth (int m') (m - Suc 0) = m' !! (m - Suc 0)\<close>
    unfolding test_bit_nat_def test_bit_int_def ..
  ultimately show ?thesis
    by (auto simp: bin_rest_def test_bit_2 test_bit_Suc_2)
qed

lemma bin_sc_ge0: \<open>w >= 0 ==> (0::int) \<le> bin_sc n b w\<close>
  by (induction n arbitrary: w) auto

lemma bin_to_bl_eq_nat:
  \<open>bin_to_bl (size a) (int a) = bin_to_bl (size b) (int b) ==> a=b\<close>
  by (metis Nat.size_nat_def size_bin_to_bl)

lemma nat_bin_nth_bl: "n < m \<Longrightarrow> w !! n = nth (rev (bin_to_bl m (int w))) n" for w :: nat
  apply (induct n arbitrary: m w)
  subgoal for m w
    apply clarsimp
    apply (case_tac m, clarsimp)
    using bin_nth_bl bin_to_bl_def test_bit_int_def test_bit_nat_def apply presburger
    done
  subgoal for n m w
    apply (clarsimp simp: bin_to_bl_def)
    apply (case_tac m, clarsimp)
    apply (clarsimp simp: bin_to_bl_def)
    apply (subst bin_to_bl_aux_alt)
    apply (simp add: bin_nth_bl test_bit_nat_def)
    done
  done

lemma bin_nth_ge_size: \<open>nat na \<le> n \<Longrightarrow> 0 \<le> na \<Longrightarrow> bin_nth na n = False\<close>
proof (induction \<open>n\<close> arbitrary: na)
  case 0
  then show ?case by auto
next
  case (Suc n na) note IH = this(1) and H = this(2-)
  have \<open>na = 1 \<or> 0 \<le> na div 2\<close>
    using H by auto
  moreover have
    \<open>na = 0 \<or> na = 1 \<or> nat (na div 2) \<le> n\<close>
    using H by auto
  ultimately show ?case
    using IH[rule_format,  of \<open>bin_rest na\<close>] H
    by (auto simp: bin_rest_def)
qed

lemma test_bit_nat_outside: "n > size w \<Longrightarrow> \<not>w !! n" for w :: nat
  unfolding test_bit_nat_def
  by (auto simp: bin_nth_ge_size)

lemma nat_bin_nth_bl':
  \<open>a !! n \<longleftrightarrow> (n < size a \<and> (rev (bin_to_bl (size a) (int a)) ! n))\<close>
  by (metis (full_types) Nat.size_nat_def bin_nth_ge_size leI nat_bin_nth_bl nat_int
      of_nat_less_0_iff test_bit_int_def test_bit_nat_def)

lemma nat_set_bit_test_bit: \<open>set_bit w n x !! m = (if m = n then x else w !! m)\<close> for w n :: nat
  unfolding nat_bin_nth_bl'
  apply auto
        apply (metis bin_nth_bl bin_nth_sc bin_nth_simps(3) bin_to_bl_def int_nat_eq set_bit_nat_def)
       apply (metis bin_nth_ge_size bin_nth_sc bin_sc_ge0 leI of_nat_less_0_iff set_bit_nat_def)
      apply (metis bin_nth_bl bin_nth_ge_size bin_nth_sc bin_sc_ge0 bin_to_bl_def int_nat_eq leI
      of_nat_less_0_iff set_bit_nat_def)
     apply (metis Nat.size_nat_def bin_nth_sc_gen bin_nth_simps(3) bin_to_bl_def int_nat_eq
      nat_bin_nth_bl' set_bit_nat_def test_bit_int_def test_bit_nat_def)
    apply (metis Nat.size_nat_def bin_nth_bl bin_nth_sc_gen bin_to_bl_def int_nat_eq nat_bin_nth_bl
      nat_bin_nth_bl' of_nat_less_0_iff of_nat_less_iff set_bit_nat_def)
   apply (metis (full_types) bin_nth_bl bin_nth_ge_size bin_nth_sc_gen bin_sc_ge0 bin_to_bl_def leI of_nat_less_0_iff set_bit_nat_def)
  by (metis bin_nth_bl bin_nth_ge_size bin_nth_sc_gen bin_sc_ge0 bin_to_bl_def int_nat_eq leI of_nat_less_0_iff set_bit_nat_def)

lemma unat_or: "unat (x OR y) = unat x OR unat y"
  unfolding unat_def
  by (simp add: uint_or bitOR_nat_def)

lemma unat_and: "unat (x AND y) = unat x AND unat y"
  unfolding unat_def
  by (simp add: uint_and bitAND_nat_def)

lemma unat_xor: "unat (x XOR y) = unat x XOR unat y"
  unfolding unat_def
  by (simp add: uint_xor bitXOR_nat_def)

(* TODO: Add OR-numerals, XOR-numerals! *)

lemma nat_and_numerals [simp]:
  "(numeral (Num.Bit0 x) :: nat) AND (numeral (Num.Bit0 y) :: nat) = (2 :: nat) * (numeral x AND numeral y)"
  "numeral (Num.Bit0 x) AND numeral (Num.Bit1 y) = (2 :: nat) * (numeral x AND numeral y)"
  "numeral (Num.Bit1 x) AND numeral (Num.Bit0 y) = (2 :: nat) * (numeral x AND numeral y)"
  "numeral (Num.Bit1 x) AND numeral (Num.Bit1 y) = (2 :: nat) * (numeral x AND numeral y)+1"
  "0 AND n = 0"
  "n AND 0 = 0"
  "(1::nat) AND numeral (Num.Bit0 y) = 0"
  "(1::nat) AND numeral (Num.Bit1 y) = 1"
  "numeral (Num.Bit0 x) AND (1::nat) = 0"
  "numeral (Num.Bit1 x) AND (1::nat) = 1"
  "(Suc 0::nat) AND numeral (Num.Bit0 y) = 0"
  "(Suc 0::nat) AND numeral (Num.Bit1 y) = 1"
  "numeral (Num.Bit0 x) AND (Suc 0::nat) = 0"
  "numeral (Num.Bit1 x) AND (Suc 0::nat) = 1"
  "Suc 0 AND Suc 0 = 1"
  for n::nat
  by (auto simp: bitAND_nat_def Bit_def nat_add_distrib)

lemma nat_and_comm: "a AND b = b AND a" for a b :: nat
  unfolding bitAND_nat_def by (auto simp: int_and_comm)

lemma AND_upper_nat1: "a AND b \<le> a" for a b :: nat
proof -
  have "int a AND int b \<le> int a"
    by (rule AND_upper1) simp
  thus ?thesis unfolding bitAND_nat_def by linarith
qed

lemma AND_upper_nat2: "a AND b \<le> b" for a b :: nat
  using AND_upper_nat1[of b a] by (simp add: nat_and_comm)

lemmas AND_upper_nat1' [simp] = order_trans [OF AND_upper_nat1]
lemmas AND_upper_nat1'' [simp] = order_le_less_trans [OF AND_upper_nat1]

lemmas AND_upper_nat2' [simp] = order_trans [OF AND_upper_nat2]
lemmas AND_upper_nat2'' [simp] = order_le_less_trans [OF AND_upper_nat2]

lemma msb_shiftr_nat [simp]: "msb ((x :: nat) >> r) \<longleftrightarrow> msb x"
  by (auto simp: msb_nat_def shiftr_nat_def simp flip: shiftr_int_def)

lemma bintrunc_le: \<open>a \<ge> 0 \<Longrightarrow> a < b \<Longrightarrow> bintrunc n a < b\<close>
  by (smt bintr_lt2p bintrunc_mod2p mod_pos_pos_trivial)

lemma msb_shiftr_word [simp]: "r < LENGTH('a) \<Longrightarrow> msb ((x :: 'a :: {len} word) >> r) \<longleftrightarrow> ((r = 0 \<and> msb x))"
  apply (cases r)
  apply (auto simp: shiftr_nat_def simp flip: shiftr_int_def sint_uint)
  apply (auto simp: bl_shiftr word_size msb_word_def
    simp flip: sint_uint[unfolded One_nat_def] hd_bl_sign_sint)
  done

lemma msb_shiftl_word [simp]: "r < LENGTH('a)  \<Longrightarrow> x << r < 2 ^ (LENGTH('a) - Suc 0) \<Longrightarrow>
     msb ((x :: 'a :: {len} word) << r) = (r = 0 \<and> msb x)"
  using less_is_drop_replicate[of \<open>x << r\<close> \<open>(LENGTH('a) - Suc 0)\<close>]
  apply (cases r)
  apply (auto simp: shiftl_nat_def simp flip: shiftl_int_def sint_uint)
  apply (auto simp: bl_shiftl word_size msb_word_def
    simp flip: sint_uint[unfolded One_nat_def] hd_bl_sign_sint)
  done

end


(* Author: Alexander Bentkamp, Universität des Saarlandes
*)
section \<open>Lebesgue Measure of Polynomial Zero Sets\<close>

theory Lebesgue_Zero_Set
  imports
    Polynomials.More_MPoly_Type
    Lebesgue_Functional
    Polynomials.MPoly_Type_Univariate
begin

lemma measurable_insertion [measurable]:
assumes "vars p \<subseteq> {..<n}"
shows "(\<lambda>f. insertion f p) \<in> borel_measurable (lborel_f n)"
using assms proof (induction p rule:mpoly_induct)
  case (monom m a)
  then show ?case
  proof (cases "a = 0")
    case True
    show ?thesis unfolding insertion_single \<open>a = 0\<close> MPoly_Type.monom.abs_eq single_zero
      zero_mpoly.abs_eq[symmetric] insertion_zero by measurable
  next
    case False
    have "Poly_Mapping.keys m \<subseteq> {..<n}" using monom by (simp add: False vars_monom_keys)
    then show ?thesis using \<open>a\<noteq>0\<close>
    proof (induction m arbitrary:a rule:poly_mapping_induct)
      case (single x i a)
      then show ?case
      proof (cases "i = 0")
        case True
        show ?thesis unfolding insertion_single \<open>i = 0\<close> by simp
      next
        case False
        then show ?thesis unfolding insertion_single apply measurable
          using vars_monom_single_cases single False insert_subset lessThan_iff \<open>a\<noteq>0\<close> by fastforce
      qed
    next
      case (sum m1 m2 x i)
      then have "Poly_Mapping.keys m1 \<inter> Poly_Mapping.keys m2 = {}" by simp
      then have "Poly_Mapping.keys m1 \<union> Poly_Mapping.keys m2 = Poly_Mapping.keys (m1 + m2)" using keys_add by metis
      then have 1:"Poly_Mapping.keys m1 \<subseteq> {..<n}" and 2:"Poly_Mapping.keys m2 \<subseteq> {..<n}" using sum.prems by auto
      show ?case unfolding MPoly_Type.mult_monom[of m1 a m2 1,simplified,symmetric]
        insertion_mult using sum.IH(1)[OF 1 \<open>a\<noteq>0\<close>] sum.IH(2)[OF 2, of 1, simplified] by measurable
    qed
  qed
next
  case (sum p1 p2 m a)
  then have "(\<lambda>f. insertion f p1) \<in> borel_measurable (lborel_f n)"
            "(\<lambda>f. insertion f p2) \<in> borel_measurable (lborel_f n)"
    using vars_add_monom[OF sum.hyps]  le_sup_iff by blast+
  then show ?case unfolding insertion_add by measurable
qed

text \<open>This proof follows Richard Caron and Tim Traynor, "The zero set of a polynomial"
http://www1.uwindsor.ca/math/sites/uwindsor.ca.math/files/05-03.pdf\<close>

lemma lebesgue_mpoly_zero_set:
fixes p::"real mpoly"
assumes "p \<noteq> 0" "vars p \<subseteq> {..<n}"
shows "{f\<in>space (lborel_f n). insertion f p = 0} \<in> null_sets (lborel_f n)"
using assms proof (induction n arbitrary:p)
  case 0
  then have "vars p = {}" by simp then have "\<And>f. insertion f p = MPoly_Type.coeff p 0"
      unfolding insertion_trivial[symmetric] using insertion_irrelevant_vars by blast
  have "\<And>m. m\<noteq>0 \<Longrightarrow> MPoly_Type.coeff p m = 0"
  proof (rule ccontr)
    fix m::"nat \<Rightarrow>\<^sub>0 nat" assume "m\<noteq>0" "MPoly_Type.coeff p m \<noteq> 0"
    then obtain v where "Poly_Mapping.lookup m v \<noteq> 0" using aux by auto
    then have "v\<in>vars p" unfolding More_MPoly_Type.vars_def using \<open>MPoly_Type.coeff p m \<noteq> 0\<close>
      by (meson UN_I coeff_keys lookup_not_eq_zero_eq_in_keys)
    then show False using \<open>vars p = {}\<close> by auto
  qed
  then have "MPoly_Type.coeff p 0 \<noteq> 0" using \<open>p \<noteq> 0\<close>
    by (metis coeff_all_0)
  then have "{f. insertion f p = 0} = {}" using \<open>\<And>f. insertion f p = MPoly_Type.coeff p 0\<close> by auto
  then show ?case by auto
next
  case (Suc n p)

text \<open>Show that N is finite:\<close>
  then have "extract_var p n \<noteq> 0" using reduce_nested_mpoly_0
    by (metis reduce_nested_mpoly_extract_var)
  let ?q = "\<lambda>j. MPoly_Type.coeff (extract_var p n) j"
  obtain j where "?q j \<noteq> 0" using \<open>extract_var p n \<noteq> 0\<close>
    by (metis coeff_all_0)
  then have "finite {x. insertion (\<lambda>_. x) (?q j) = 0}"
    using univariate_mpoly_roots_finite[OF vars_coeff_extract_var] by metis
  then have "finite (\<Inter>j. {x. insertion (\<lambda>_. x) (?q j) = 0})" by auto
  moreover have "{x. \<forall>j. insertion (\<lambda>_. x) (?q j) = 0} = (\<Inter>j. {x. insertion (\<lambda>v. x) (?q j) = 0})" by blast
  ultimately have "finite {x. \<forall>j. insertion (\<lambda>_. x) (?q j) = 0}" by metis

  define p_fix1 where "p_fix1 x1 = replace_coeff (insertion (\<lambda>_. x1)) (extract_var p n)" for x1
  define N where "N = {x1. p_fix1 x1 = 0}"
  have "N \<subseteq> {x. \<forall>j. insertion (\<lambda>_. x) (?q j) = 0}"
  proof
    fix x assume "x\<in>N"
    then have "p_fix1 x = 0" using N_def by auto
    then have "\<And>m. MPoly_Type.coeff (p_fix1 x) m = 0" by (metis More_MPoly_Type.coeff_monom monom_zero when_def)
    have "\<And>j. insertion (\<lambda>_. x) (?q j) = 0"
      using \<open>\<And>m. MPoly_Type.coeff (p_fix1 x) m = 0\<close>[unfolded p_fix1_def coeff_replace_coeff[of "insertion (\<lambda>_. x)", OF insertion_zero]]
      by metis
    then show "x \<in> {x. \<forall>j. insertion (\<lambda>_. x) (MPoly_Type.coeff (extract_var p n) j) = 0}" by blast
  qed
  then have "finite N" by (simp add: \<open>finite {x. \<forall>j. insertion (\<lambda>_. x) (MPoly_Type.coeff (extract_var p n) j) = 0}\<close> finite_subset)

text \<open>Use the IH:\<close>

  define A where "A = {f\<in>space (lborel_f (Suc n)). insertion f p = 0}"

  have "\<And>x1. vars (p_fix1 x1) \<subseteq> {..<n}"
  proof -
    fix x1
    have "vars (extract_var p n) \<subseteq> {..<n}"
      using \<open>vars p \<subseteq> {..<Suc n}\<close> lessThan_Suc v_not_in_vars_extract_var vars_extract_var_subset by fastforce
    then show "vars (p_fix1 x1) \<subseteq> {..<n}" unfolding p_fix1_def
      using vars_replace_coeff[of "insertion (\<lambda>_. x1)", OF insertion_zero] by blast
  qed
  have set_eq:"\<And>x1. {x \<in> space (lborel_f n). x(n := x1) \<in> A} = {f \<in> space (lborel_f n). insertion f (p_fix1 x1) = 0}"
  proof -
    fix x1
    show "{x\<in>space (lborel_f n). x(n := x1) \<in> A} = {f\<in>space (lborel_f n). insertion f (p_fix1 x1) = 0}"
    proof (rule subset_antisym;rule subsetI)
      fix x assume "x \<in> {x\<in>space (lborel_f n). x(n := x1) \<in> A}"
      then have "insertion (x(n := x1)) p = 0" "x \<in> space (lborel_f n)"
        using A_def by auto
      then have "insertion x (p_fix1 x1) = 0" unfolding p_fix1_def
        unfolding replace_coeff_extract_var_cong[of "\<lambda>_. x1" n "x(n := x1)" p, OF fun_upd_same[symmetric]]
        using insertion_replace_coeff[of "x(n := x1)"]
        using  insertion_irrelevant_vars[of "replace_coeff (insertion (x(n := x1))) (extract_var p n)" x "x(n := x1)"]
         vars_replace_coeff fun_upd_other insertion_zero reduce_nested_mpoly_extract_var subset_eq
         v_not_in_vars_extract_var by metis
      then show "x \<in> {f\<in>space (lborel_f n). insertion f (p_fix1 x1) = 0}" using \<open>x \<in> space (lborel_f n)\<close> by blast
    next
      fix f assume "f \<in> {f\<in>space (lborel_f n). insertion f (p_fix1 x1) = 0}"
      then have "f\<in>space (lborel_f n)" "insertion f (p_fix1 x1) = 0" by auto
      have "insertion (f(n := x1)) p = 0" using \<open>insertion f (p_fix1 x1) = 0\<close>[unfolded p_fix1_def]
        insertion_replace_coeff insertion_irrelevant_vars replace_coeff_extract_var_cong
        by (metis (no_types, lifting) \<open>insertion f (p_fix1 x1) = 0\<close> \<open>vars (p_fix1 x1) \<subseteq> {..<n}\<close>
        fun_upd_other fun_upd_same lessThan_iff order_less_irrefl p_fix1_def reduce_nested_mpoly_extract_var subsetCE)
      then have "f(n := x1) \<in> A" unfolding A_def using space_lborel_add_dim
        using \<open>f \<in> space (lborel_f n)\<close> lborel_f_def mem_Collect_eq by blast
      then show "f \<in> {f\<in>space (lborel_f n). f(n := x1) \<in> A}" using \<open>f \<in> space (lborel_f n)\<close> by auto
    qed
  qed

  have "\<And>x1. x1\<in>N \<Longrightarrow> {x\<in>space (lborel_f n). x(n := x1) \<in> A} \<in> sets (lborel_f n)"
       and emeasure_in_N: "\<And>x1. x1\<in>N \<Longrightarrow> emeasure (lborel_f n) {x\<in>space (lborel_f n). x(n := x1) \<in> A} = emeasure (lborel_f n) (space (lborel_f n))"
  proof -
    fix x1 assume "x1\<in>N"
    then have "p_fix1 x1 = 0" using N_def by auto
    then have "\<And>f. insertion f (p_fix1 x1) = 0" using insertion_zero by auto
    then have "{f \<in> space (lborel_f n). insertion f (p_fix1 x1) = 0} = space (lborel_f n)" by simp
    show "{x\<in>space (lborel_f n). x(n := x1) \<in> A} \<in> sets (lborel_f n)" unfolding set_eq
      by (simp add: \<open>{f \<in> space (lborel_f n). insertion f (p_fix1 x1) = 0} = space (lborel_f n)\<close>)
    show "emeasure (lborel_f n) {x\<in>space (lborel_f n). x(n := x1) \<in> A} = emeasure (lborel_f n) (space (lborel_f n))"
      unfolding set_eq
      by (simp add: \<open>{f \<in> space (lborel_f n). insertion f (p_fix1 x1) = 0} = space (lborel_f n)\<close>)
  qed

  have emeasure_not_in_N: "\<And>x1. x1\<notin>N \<Longrightarrow> emeasure (lborel_f n) {x\<in>space (lborel_f n). x(n := x1) \<in> A} = 0"
       and "\<And>x1. x1\<notin>N \<Longrightarrow> {x\<in>space (lborel_f n). x(n := x1) \<in> A} \<in> sets (lborel_f n)"
  proof -
    fix x1 assume "x1\<notin>N"
    then have "p_fix1 x1 \<noteq> 0" using p_fix1_def N_def by auto
    then have "emeasure (lborel_f n) {f\<in>space (lborel_f n). insertion f (p_fix1 x1) = 0} = 0"
              "{f\<in>space (lborel_f n). insertion f (p_fix1 x1) = 0} \<in> sets (lborel_f n)"
      using Suc.IH[OF \<open>p_fix1 x1 \<noteq> 0\<close>] \<open>\<And>x1. vars (p_fix1 x1) \<subseteq> {..<n}\<close> by auto
    then show "emeasure (lborel_f n) {x\<in>space (lborel_f n). x(n := x1) \<in> A} = 0"
      "{x\<in>space (lborel_f n). x(n := x1) \<in> A} \<in> sets (lborel_f n)"
      using \<open>{f\<in>space (lborel_f n). insertion f (p_fix1 x1) = 0} \<in> sets (lborel_f n)\<close>
        \<open>emeasure (lborel_f n) {f\<in>space (lborel_f n). insertion f (p_fix1 x1) = 0} = 0\<close>
      using set_eq
      by auto
  qed

  have "N \<in> null_sets lborel" using \<open>finite N\<close> finite_imp_null_set_lborel by blast
  have ae_zero: "AE x1 in lborel. emeasure (lborel_f n) {x \<in> space (lborel_f n). x(n := x1) \<in> A} = 0"
    apply (rule AE_I'[OF \<open>N \<in> null_sets lborel\<close>])
    using \<open>\<And>x1. x1\<notin>N \<Longrightarrow> emeasure (lborel_f n) {x\<in>space (lborel_f n). x(n := x1) \<in> A} = 0\<close>
    by force

  have measurable: "(\<lambda>x1. emeasure (lborel_f n) {x \<in> space (lborel_f n). x(n := x1) \<in> A}) \<in> borel_measurable lborel"
  proof (rule borel_measurableI)
    let ?f = "(\<lambda>x1. emeasure (lborel_f n) {x \<in> space (lborel_f n). x(n := x1) \<in> A})"
    fix S::"ennreal set" assume "open S"
    have 0:"0\<in>S \<Longrightarrow> - N \<subseteq> ?f -` S"
      using emeasure_not_in_N by auto
    have 1:"emeasure (lborel_f n) (space (lborel_f n)) \<in> S \<Longrightarrow> N \<subseteq> ?f -` S"
      using emeasure_in_N by auto
    have 2:"0\<notin>S \<Longrightarrow> ?f -` S \<subseteq> N" using emeasure_not_in_N by fastforce
    have 3:"emeasure (lborel_f n) (space (lborel_f n)) \<notin> S \<Longrightarrow> ?f -` S \<subseteq> -N" using emeasure_in_N by auto
    have "?f -` S = {} \<or> ?f -` S = N \<or> ?f -` S = UNIV \<or> ?f -` S = - N"
      apply (cases "0\<in>S"; cases "emeasure (lborel_f n) (space (lborel_f n)) \<notin> S")
      using 0 1 2 3 by auto
    then show "?f -` S  \<inter> space lborel \<in> sets lborel"
      using \<open>finite N\<close> finite_imp_null_set_lborel borel_comp null_setsD2 sets_lborel by fastforce
  qed

  have "A \<in> sets (lborel_f (Suc n))" unfolding A_def
    using pred_eq_const1[OF measurable_insertion[OF \<open>vars p \<subseteq> {..<Suc n}\<close>]] pred_def by force
  then have in_sets: "{f \<in> space (lborel_f (Suc n)). insertion f p = 0} \<in> sets (lborel_f (Suc n))" using A_def by metis
  have "\<And>x1. {x\<in>space (lborel_f n). x(n := x1) \<in> A} \<in> sets (lborel_f n)"
    using \<open>\<And>x1. x1\<in>N \<Longrightarrow> {x\<in>space (lborel_f n). x(n := x1) \<in> A} \<in> sets (lborel_f n)\<close>
    \<open>\<And>x1. x1\<notin>N \<Longrightarrow> {x\<in>space (lborel_f n). x(n := x1) \<in> A} \<in> sets (lborel_f n)\<close> by auto
  have "emeasure (lborel_f (Suc n)) A = \<integral>\<^sup>+ y. emeasure (lborel_f n) {x \<in> space (lborel_f n). x(n := y) \<in> A} \<partial>lborel"
    using emeasure_lborel_f_Suc[OF \<open>A \<in> sets (lborel_f (Suc n))\<close>]
     \<open>\<And>x1. {x\<in>space (lborel_f n). x(n := x1) \<in> A} \<in> sets (lborel_f n)\<close> by blast
  also have "... = 0"
    using nn_integral_0_iff_AE[OF measurable] ae_zero by blast
  finally have "emeasure (lborel_f (Suc n)) A = 0" by auto
  then show ?case unfolding null_sets_def using in_sets A_def by blast
qed

end


(*  Title:      CTT/ex/Typechecking.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge
*)

section "Easy examples: type checking and type deduction"

theory Typechecking
imports "../CTT"
begin

subsection \<open>Single-step proofs: verifying that a type is well-formed\<close>

schematic_goal "?A type"
apply (rule form_rls)
done

schematic_goal "?A type"
apply (rule form_rls)
back
apply (rule form_rls)
apply (rule form_rls)
done

schematic_goal "\<Prod>z:?A . N + ?B(z) type"
apply (rule form_rls)
apply (rule form_rls)
apply (rule form_rls)
apply (rule form_rls)
apply (rule form_rls)
done

subsection \<open>Multi-step proofs: Type inference\<close>

lemma "\<Prod>w:N. N + N type"
apply form
done

schematic_goal "<0, succ(0)> : ?A"
apply intr
done

schematic_goal "\<Prod>w:N . Eq(?A,w,w) type"
apply typechk
done

schematic_goal "\<Prod>x:N . \<Prod>y:N . Eq(?A,x,y) type"
apply typechk
done

text "typechecking an application of fst"
schematic_goal "(\<^bold>\<lambda>u. split(u, \<lambda>v w. v)) ` <0, succ(0)> : ?A"
apply typechk
done

text "typechecking the predecessor function"
schematic_goal "\<^bold>\<lambda>n. rec(n, 0, \<lambda>x y. x) : ?A"
apply typechk
done

text "typechecking the addition function"
schematic_goal "\<^bold>\<lambda>n. \<^bold>\<lambda>m. rec(n, m, \<lambda>x y. succ(y)) : ?A"
apply typechk
done

(*Proofs involving arbitrary types.
  For concreteness, every type variable left over is forced to be N*)
method_setup N =
  \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD (TRYALL (resolve_tac ctxt @{thms NF})))\<close>

schematic_goal "\<^bold>\<lambda>w. <w,w> : ?A"
apply typechk
apply N
done

schematic_goal "\<^bold>\<lambda>x. \<^bold>\<lambda>y. x : ?A"
apply typechk
apply N
done

text "typechecking fst (as a function object)"
schematic_goal "\<^bold>\<lambda>i. split(i, \<lambda>j k. j) : ?A"
apply typechk
apply N
done

end


section \<open>Preliminaries\<close>
theory Terms_Positions
  imports Regular_Tree_Relations.Ground_Terms
begin

subsection \<open>Additional operations on terms and positions\<close>

subsubsection \<open>Linearity\<close>
fun linear_term :: "('f, 'v) term \<Rightarrow> bool" where
  "linear_term (Var _) = True" |
  "linear_term (Fun _ ts) = (is_partition (map vars_term ts) \<and> (\<forall>t\<in>set ts. linear_term t))"
abbreviation "linear_sys \<R> \<equiv> \<forall> (l, r) \<in> \<R>. linear_term l \<and> linear_term r"

subsubsection \<open>Positions induced by contexts, by variables and by given subterms\<close>

definition "possc C = {p | p t. p \<in> poss C\<langle>t\<rangle>}"
definition "varposs s = {p | p. p \<in> poss s \<and> is_Var (s |_ p)}"
definition "poss_of_term u t = {p. p \<in> poss t \<and> t |_ p = u}"

subsubsection \<open>Replacing functions symbols that aren't specified in the signature by variables\<close>

definition "funas_rel \<R> = (\<Union> (l, r) \<in> \<R>. funas_term l \<union> funas_term r)"

fun term_to_sig where
  "term_to_sig \<F> v (Var x) = Var x"
| "term_to_sig \<F> v (Fun f ts) =
    (if (f, length ts) \<in> \<F> then Fun f (map (term_to_sig \<F> v) ts) else Var v)"

fun ctxt_well_def_hole_path where
  "ctxt_well_def_hole_path \<F> Hole \<longleftrightarrow> True"
| "ctxt_well_def_hole_path \<F> (More f ss C ts) \<longleftrightarrow> (f, Suc (length ss + length ts)) \<in> \<F> \<and> ctxt_well_def_hole_path \<F> C"

fun inv_const_ctxt where
  "inv_const_ctxt \<F> v Hole = Hole"
| "inv_const_ctxt \<F> v ((More f ss C ts))
              = (More f (map (term_to_sig \<F> v) ss) (inv_const_ctxt \<F> v C) (map (term_to_sig \<F> v) ts))"

fun inv_const_ctxt' where
  "inv_const_ctxt' \<F> v Hole = Var v"
| "inv_const_ctxt' \<F> v ((More f ss C ts))
              = (if (f, Suc (length ss + length ts)) \<in> \<F> then Fun f (map (term_to_sig \<F> v) ss @ inv_const_ctxt' \<F> v C # map (term_to_sig \<F> v) ts) else Var v)"

subsubsection \<open>Replace term at a given position in contexts\<close>

fun replace_term_context_at :: "('f, 'v) ctxt \<Rightarrow> pos \<Rightarrow> ('f, 'v) term \<Rightarrow> ('f, 'v) ctxt"
  ("_[_ \<leftarrow> _]\<^sub>C" [1000, 0] 1000) where
  "replace_term_context_at \<box> p u = \<box>"
| "replace_term_context_at (More f ss C ts) (i # ps) u =
    (if i < length ss then More f (ss[i := (ss ! i)[ps \<leftarrow> u]]) C ts
     else if i = length ss then More f ss (replace_term_context_at C ps u) ts
     else More f ss C (ts[(i - Suc (length ss)) := (ts ! (i - Suc (length ss)))[ps \<leftarrow> u]]))"

abbreviation "constT c \<equiv> Fun c []"

subsubsection \<open>Multihole context closure of a term relation as inductive set\<close>

definition all_ctxt_closed where
  "all_ctxt_closed F r \<longleftrightarrow> (\<forall>f ts ss. (f, length ss) \<in> F \<longrightarrow> length ts = length ss \<longrightarrow>
    (\<forall>i. i < length ts \<longrightarrow> (ts ! i, ss ! i) \<in> r) \<longrightarrow>
    (\<forall> i. i < length ts \<longrightarrow> funas_term (ts ! i) \<union> funas_term (ss ! i) \<subseteq> F) \<longrightarrow> (Fun f ts, Fun f ss) \<in> r) \<and>
    (\<forall> x. (Var x, Var x) \<in> r)"

subsection \<open>Destruction and introduction of @{const all_ctxt_closed}\<close>

lemma all_ctxt_closedD: "all_ctxt_closed F r \<Longrightarrow> (f,length ss) \<in> F \<Longrightarrow> length ts = length ss
  \<Longrightarrow> \<lbrakk>\<And> i. i < length ts \<Longrightarrow> (ts ! i, ss ! i) \<in> r \<rbrakk>
  \<Longrightarrow> \<lbrakk>\<And> i. i < length ts \<Longrightarrow> funas_term (ts ! i) \<subseteq> F \<rbrakk>
  \<Longrightarrow> \<lbrakk>\<And> i. i < length ts \<Longrightarrow> funas_term (ss ! i) \<subseteq> F \<rbrakk>
  \<Longrightarrow> (Fun f ts, Fun f ss) \<in> r"
  unfolding all_ctxt_closed_def by auto

lemma trans_ctxt_sig_imp_all_ctxt_closed: assumes tran: "trans r"
  and refl: "\<And> t. funas_term t \<subseteq> F \<Longrightarrow> (t,t) \<in> r"
  and ctxt: "\<And> C s t. funas_ctxt C \<subseteq> F \<Longrightarrow> funas_term s \<subseteq> F \<Longrightarrow> funas_term t \<subseteq> F \<Longrightarrow> (s,t) \<in> r \<Longrightarrow> (C \<langle> s \<rangle>, C \<langle> t \<rangle>) \<in> r"
  shows "all_ctxt_closed F r" unfolding all_ctxt_closed_def
proof (rule, intro allI impI)
  fix f ts ss
  assume f: "(f,length ss) \<in> F" and
         l: "length ts = length ss" and
         steps: "\<forall> i < length ts. (ts ! i, ss ! i) \<in> r" and
         sig: "\<forall> i < length ts. funas_term (ts ! i) \<union>  funas_term (ss ! i) \<subseteq> F"
  from sig have sig_ts: "\<And> t. t \<in> set ts \<Longrightarrow> funas_term t \<subseteq> F"  unfolding set_conv_nth by auto
  let ?p = "\<lambda> ss. (Fun f ts, Fun f ss) \<in> r \<and> funas_term (Fun f ss) \<subseteq> F"
  let ?r = "\<lambda> xsi ysi. (xsi, ysi) \<in> r \<and> funas_term ysi \<subseteq> F"
  have init: "?p ts" by (rule conjI[OF refl], insert f sig_ts l, auto)
  have "?p ss"
  proof (rule parallel_list_update[where p = ?p and r = ?r, OF _ HOL.refl init l[symmetric]])
    fix xs i y
    assume len: "length xs = length ts"
       and i: "i < length ts"
       and r: "?r (xs ! i) y"
       and p: "?p xs"
    let ?C = "More f (take i xs) Hole (drop (Suc i) xs)"
    have id1: "Fun f xs = ?C \<langle> xs ! i\<rangle>" using id_take_nth_drop[OF i[folded len]] by simp
    have id2: "Fun f (xs[i := y]) = ?C \<langle> y \<rangle>" using upd_conv_take_nth_drop[OF i[folded len]] by simp
    from p[unfolded id1] have C: "funas_ctxt ?C \<subseteq> F" and xi: "funas_term (xs ! i) \<subseteq> F" by auto
    from r have "funas_term y \<subseteq> F" "(xs ! i, y) \<in> r" by auto
    with ctxt[OF C xi this] C have r: "(Fun f xs, Fun f (xs[i := y])) \<in> r"
      and f: "funas_term (Fun f (xs[i := y])) \<subseteq> F" unfolding id1 id2 by auto
    from p r tran have "(Fun f ts, Fun f (xs[i := y])) \<in> r" unfolding trans_def by auto
    with f
    show "?p (xs[i := y])"  by auto
  qed (insert sig steps, auto)
  then show "(Fun f ts, Fun f ss) \<in> r" ..
qed (insert refl, auto)

subsection \<open>Lemmas for @{const poss} and ordering of positions\<close>

lemma subst_poss_mono: "poss s \<subseteq> poss (s \<cdot> \<sigma>)"
  by (induct s) force+

lemma par_pos_prefix [simp]:
  "(i # p) \<bottom> (i # q) \<Longrightarrow> p \<bottom> q"
  by (simp add: par_Cons_iff)

lemma pos_diff_itself [simp]: "p -\<^sub>p p = []"
  by (simp add: pos_diff_def)

lemma pos_les_eq_append_diff [simp]:
  "p \<le>\<^sub>p q \<Longrightarrow> p @ (q -\<^sub>p p) = q"
  by (metis option.sel pos_diff_def position_less_eq_def remove_prefix_append)

lemma pos_diff_append_itself [simp]: "(p @ q) -\<^sub>p p = q"
  by (simp add: pos_diff_def remove_prefix_append)

lemma poss_pos_diffI:
  "p \<le>\<^sub>p q \<Longrightarrow> q \<in> poss s \<Longrightarrow> q -\<^sub>p p \<in> poss (s |_ p)"
  using poss_append_poss by fastforce

lemma less_eq_poss_append_itself [simp]: "p \<le>\<^sub>p (p @ q)"
  using position_less_eq_def by blast

lemma poss_ctxt_apply [simp]:
  "hole_pos C @ p \<in> poss C\<langle>s\<rangle> \<longleftrightarrow> p \<in> poss s"
  by (induct C) auto

lemma pos_replace_at_pres:
  "p \<in> poss s \<Longrightarrow> p \<in> poss s[p \<leftarrow> t]"
proof (induct p arbitrary: s)
  case (Cons i p)
  show ?case using Cons(1)[of "args s ! i"] Cons(2-)
    by (cases s) auto
qed auto

lemma par_pos_replace_pres:
  "p \<in> poss s \<Longrightarrow> p \<bottom> q \<Longrightarrow> p \<in> poss s[q \<leftarrow> t]"
proof (induct p arbitrary: s q)
  case (Cons i p)
  show ?case using Cons(1)[of "args s ! i" "tl q"] Cons(2-)
    by (cases s; cases q) (auto simp add: nth_list_update par_Cons_iff)
qed auto

lemma poss_of_termE [elim]:
  assumes "p \<in> poss_of_term u s"
    and "p \<in> poss s \<Longrightarrow> s |_ p = u \<Longrightarrow> P"
  shows "P" using assms unfolding poss_of_term_def
  by blast

lemma poss_of_term_Cons:
  "i # p \<in> poss_of_term u (Fun f ts) \<Longrightarrow> p \<in> poss_of_term u (ts ! i)"
  unfolding poss_of_term_def by auto

lemma poss_of_term_const_ctxt_apply:
  assumes "p \<in> poss_of_term (constT c) C\<langle>s\<rangle>"
  shows "p \<bottom> (hole_pos C) \<or> (hole_pos C) \<le>\<^sub>p p" using assms
proof (induct p arbitrary: C)
  case Nil then show ?case
    by (cases C) auto
next
  case (Cons i p) then show ?case
    by (cases C) (fastforce simp add: par_Cons_iff dest!: poss_of_term_Cons)+
qed

subsection \<open>Lemmas for @{const subt_at} and @{const replace_term_at}\<close>

lemma subt_at_append_dist:
  "p @ q \<in> poss s \<Longrightarrow> s |_ (p @ q) = (s |_ p) |_ q"
proof (induct p arbitrary: s)
  case (Cons i p) then show ?case
    by (cases s) auto
qed auto

lemma ctxt_apply_term_subt_at_hole_pos [simp]:
  "C\<langle>s\<rangle> |_ (hole_pos C @ q) = s |_ q"
  by (induct C) auto

lemma subst_subt_at_dist:
  "p \<in> poss s \<Longrightarrow> s \<cdot> \<sigma> |_ p = s |_ p \<cdot> \<sigma>"
proof (induct p arbitrary: s)
  case (Cons i p) then show ?case
    by (cases s) auto
qed auto

lemma replace_term_at_subt_at_id [simp]: "s[p \<leftarrow> (s |_ p)] = s"
proof (induct p arbitrary: s)
  case (Cons i p) then show ?case
    by (cases s) auto
qed auto

lemma replace_term_at_same_pos [simp]:
  "s[p \<leftarrow> u][p \<leftarrow> t] = s[p \<leftarrow> t]"
  using position_less_refl replace_term_at_above by blast

\<comment> \<open>Replacement at under substitution\<close>
lemma subt_at_vars_term:
  "p \<in> poss s \<Longrightarrow> s |_ p = Var x \<Longrightarrow> x \<in> vars_term s"
  by (metis UnCI ctxt_at_pos_subt_at_id term.set_intros(3) vars_term_ctxt_apply)

lemma linear_term_varposs_subst_replace_term:
  "linear_term s \<Longrightarrow> p \<in> varposs s \<Longrightarrow> p \<le>\<^sub>p q \<Longrightarrow>
     (s \<cdot> \<sigma>)[q \<leftarrow> u] = s \<cdot> (\<lambda> x. if Var x = s |_ p then (\<sigma> x)[q -\<^sub>p p \<leftarrow> u] else (\<sigma> x))"
proof (induct q arbitrary: s p)
  case (Cons i q)
  show ?case using Cons(1)[of "args s ! i" "tl p"] Cons(2-)
    by (cases s) (auto simp: varposs_def nth_list_update term_subst_eq_conv
      is_partition_alt is_partition_alt_def disjoint_iff subt_at_vars_term intro!: nth_equalityI)
qed (auto simp: varposs_def)

\<comment> \<open>Replacement at context parallel to the hole position\<close>
lemma par_hole_pos_replace_term_context_at:
  "p \<bottom> hole_pos C \<Longrightarrow> C\<langle>s\<rangle>[p \<leftarrow> u] = (C[p \<leftarrow> u]\<^sub>C)\<langle>s\<rangle>"
proof (induct p arbitrary: C)
  case (Cons i p)
  from Cons(2) obtain f ss D ts where [simp]: "C = More f ss D ts" by (cases C) auto
  show ?case using Cons(1)[of D] Cons(2)
    by (auto simp: list_update_append nth_append_Cons minus_nat.simps(2) split: nat.splits)
qed auto

lemma par_pos_replace_term_at:
  "p \<in> poss s \<Longrightarrow> p \<bottom> q \<Longrightarrow> s[q \<leftarrow> t] |_ p = s |_ p"
proof (induct p arbitrary: s q)
  case (Cons i p)
  show ?case using Cons(1)[of "args s ! i" "tl q"] Cons(2-)
    by (cases s; cases q) (auto, metis nth_list_update par_Cons_iff)
qed auto

lemma less_eq_subt_at_replace:
  "p \<in> poss s \<Longrightarrow> p \<le>\<^sub>p q \<Longrightarrow> s[q \<leftarrow> t] |_ p = (s |_ p)[q -\<^sub>p p \<leftarrow> t]"
proof (induct p arbitrary: s q)
  case (Cons i p)
  show ?case using Cons(1)[of "args s ! i" "tl q"] Cons(2-)
    by (cases s; cases q) auto
qed auto

lemma greater_eq_subt_at_replace:
  "p \<in> poss s \<Longrightarrow> q \<le>\<^sub>p p \<Longrightarrow> s[q \<leftarrow> t] |_ p = t |_ (p -\<^sub>p q)"
proof (induct p arbitrary: s q)
  case (Cons i p)
  show ?case using Cons(1)[of "args s ! i" "tl q"] Cons(2-)
    by (cases s; cases q) auto
qed auto

lemma replace_subterm_at_itself [simp]:
  "s[p \<leftarrow> (s |_ p)[q \<leftarrow> t]] = s[p @ q \<leftarrow> t]"
proof (induct p arbitrary: s)
  case (Cons i p)
  show ?case using Cons(1)[of "args s ! i"]
    by (cases s) auto
qed auto

lemma hole_pos_replace_term_at [simp]:
  "hole_pos C \<le>\<^sub>p p \<Longrightarrow> C\<langle>s\<rangle>[p \<leftarrow> u] = C\<langle>s[p -\<^sub>p hole_pos C \<leftarrow> u]\<rangle>"
proof (induct C arbitrary: p)
  case (More f ss C ts) then show ?case
    by (cases p) auto
qed auto

lemma ctxt_of_pos_term_apply_replace_at_ident:
  assumes "p \<in> poss s"
  shows "(ctxt_at_pos s p)\<langle>t\<rangle> = s[p \<leftarrow> t]"
  using assms
proof (induct p arbitrary: s)
  case (Cons i p)
  show ?case using Cons(1)[of "args s ! i"] Cons(2-)
    by (cases s) (auto simp: nth_append_Cons intro!: nth_equalityI)
qed auto

lemma ctxt_apply_term_replace_term_hole_pos [simp]:
  "C\<langle>s\<rangle>[hole_pos C @ q  \<leftarrow> u] = C\<langle>s[q  \<leftarrow> u]\<rangle>"
  by (simp add: pos_diff_def position_less_eq_def remove_prefix_append)

lemma ctxt_apply_subt_at_hole_pos [simp]: "C\<langle>s\<rangle> |_ hole_pos C = s"
  by (induct C) auto

lemma subt_at_imp_supteq':
  assumes "p \<in> poss s" and "s|_p = t" shows "s \<unrhd> t" using assms
proof (induct p arbitrary: s)
  case (Cons i p)
  from Cons(2-) show ?case using Cons(1)[of "args s ! i"]
    by (cases s) force+
qed auto

lemma subt_at_imp_supteq:
  assumes "p \<in> poss s" shows "s \<unrhd> s|_p"
proof -
 have "s|_p = s|_p" by auto
 with assms show ?thesis by (rule subt_at_imp_supteq')
qed

subsection \<open>@{const term_to_sig} invariants and distributions\<close>

lemma fuans_term_term_to_sig [simp]: "funas_term (term_to_sig \<F> v t) \<subseteq> \<F>"
  by (induct t) auto

lemma term_to_sig_id [simp]:
  "funas_term t \<subseteq> \<F> \<Longrightarrow> term_to_sig \<F> v t = t"
  by (induct t) (auto simp add: UN_subset_iff map_idI)

lemma term_to_sig_subst_sig [simp]:
  "funas_term t \<subseteq> \<F> \<Longrightarrow> term_to_sig \<F> v (t \<cdot> \<sigma>) = t \<cdot> (\<lambda> x.  term_to_sig \<F> v (\<sigma> x))"
  by (induct t) auto

lemma funas_ctxt_ctxt_inv_const_ctxt_ind [simp]:
  "funas_ctxt C \<subseteq> \<F> \<Longrightarrow> inv_const_ctxt \<F> v C = C"
  by (induct C) (auto simp add: UN_subset_iff intro!: nth_equalityI)

lemma term_to_sig_ctxt_apply [simp]:
  "ctxt_well_def_hole_path \<F> C \<Longrightarrow> term_to_sig \<F> v C\<langle>s\<rangle> = (inv_const_ctxt \<F> v C)\<langle>term_to_sig \<F> v s\<rangle>"
  by (induct C) auto

lemma term_to_sig_ctxt_apply' [simp]:
  "\<not> ctxt_well_def_hole_path \<F> C \<Longrightarrow> term_to_sig \<F> v C\<langle>s\<rangle> = inv_const_ctxt' \<F> v C"
  by (induct C) auto

lemma funas_ctxt_ctxt_well_def_hole_path:
  "funas_ctxt C \<subseteq> \<F> \<Longrightarrow> ctxt_well_def_hole_path \<F> C"
  by (induct C) auto

subsection \<open>Misc\<close>

lemma funas_term_subt_at:
  "(f, n) \<in> funas_term t \<Longrightarrow> (\<exists> p ts. p \<in> poss t \<and> t |_ p = Fun f ts \<and> length ts = n)"
proof (induct t)
  case (Fun g ts) note IH = this
  show ?case
  proof (cases "g = f \<and> length ts = n")
    case False
    then obtain i where i: "i < length ts" "(f, n) \<in> funas_term (ts ! i)" using IH(2)
      using in_set_idx by force
    from IH(1)[OF nth_mem[OF this(1)] this(2)] show ?thesis using i(1)
      by (metis poss_Cons_poss subt_at.simps(2) term.sel(4))
  qed auto
qed simp

lemma finite_poss: "finite (poss s)"
proof (induct s)
  case (Fun f ts)
  have "poss (Fun f ts) = insert [] (\<Union> (set (map2 (\<lambda> i p. ((#) i) ` p) [0..< length ts] (map poss ts))))"
    by (auto simp: image_iff set_zip split: prod.splits)
  then show ?case using Fun
    by (auto simp del: poss.simps dest!: set_zip_rightD)
qed simp

lemma finite_varposs: "finite (varposs s)"
  by (intro finite_subset[of "varposs s" "poss s"]) (auto simp: varposs_def finite_poss)

lemma gound_linear [simp]: "ground t \<Longrightarrow> linear_term t"
  by (induct t) (auto simp: is_partition_alt is_partition_alt_def)

declare ground_substI[intro, simp]
lemma ground_ctxt_substI:
  "(\<And> x. x \<in> vars_ctxt C \<Longrightarrow> ground (\<sigma> x)) \<Longrightarrow> ground_ctxt (C \<cdot>\<^sub>c \<sigma>)"
  by (induct C) auto

lemma funas_ctxt_subst_apply_ctxt:
  "funas_ctxt (C \<cdot>\<^sub>c \<sigma>) = funas_ctxt C \<union> (\<Union> (funas_term ` \<sigma> ` vars_ctxt C))"
proof (induct C)
  case (More f ss C ts)
  then show ?case
    by (fastforce simp add: funas_term_subst)
qed simp

lemma varposs_Var[simp]:
  "varposs (Var x) = {[]}"
  by (auto simp: varposs_def)

lemma varposs_Fun[simp]:
  "varposs (Fun f ts) = { i # p| i p. i < length ts \<and> p \<in> varposs (ts ! i)}"
  by (auto simp: varposs_def)

lemma vars_term_varposs_iff:
  "x \<in> vars_term s \<longleftrightarrow> (\<exists> p \<in> varposs s. s |_ p = Var x)"
proof (induct s)
  case (Fun f ts)
  show ?case using Fun[OF nth_mem]
    by (force simp: in_set_conv_nth Bex_def)
qed auto

lemma vars_term_empty_ground:
  "vars_term s = {} \<Longrightarrow> ground s"
  by (metis equals0D ground_substI subst_ident)

lemma ground_subst_apply: "ground t \<Longrightarrow> t \<cdot> \<sigma> = t"
  by (induct t) (auto intro: nth_equalityI)

lemma varposs_imp_poss:
  "p \<in> varposs s \<Longrightarrow> p \<in> poss s" by (auto simp: varposs_def)

lemma varposs_empty_gound:
 "varposs s = {} \<longleftrightarrow> ground s"
  by (induct s) (fastforce simp: in_set_conv_nth)+

lemma funas_term_subterm_atI [intro]:
  "p \<in> poss s \<Longrightarrow> funas_term s \<subseteq> \<F> \<Longrightarrow> funas_term (s |_ p) \<subseteq> \<F>"
  by (metis ctxt_at_pos_subt_at_id funas_ctxt_apply le_sup_iff)

lemma varposs_ground_replace_at:
  "p \<in> varposs s \<Longrightarrow> ground u \<Longrightarrow> varposs s[p \<leftarrow> u] = varposs s - {p}"
proof (induct p arbitrary: s)
  case Nil then show ?case
    by (cases s) (auto simp: varposs_empty_gound)
next
  case (Cons i p)
  from Cons(2) obtain f ts where [simp]: "s = Fun f ts" by (cases s) auto
  from Cons(2) have var: "p \<in> varposs (ts ! i)" by auto
  from Cons(1)[OF var Cons(3)] have "j < length ts \<Longrightarrow> {j # q| q. q \<in> varposs (ts[i := (ts ! i)[p \<leftarrow> u]] ! j)} =
           {j # q |q. q \<in> varposs (ts ! j)} - {i # p}" for j
    by (cases "j = i") (auto simp add: nth_list_update)
  then show ?case by auto blast
qed

lemma funas_term_replace_at_upper:
  "funas_term s[p \<leftarrow> t] \<subseteq> funas_term s \<union> funas_term t"
proof (induct p arbitrary: s)
  case (Cons i p)
  show ?case using Cons(1)[of "args s ! i"]
    by (cases s) (fastforce simp: in_set_conv_nth nth_list_update split!: if_splits)+
qed simp

lemma funas_term_replace_at_lower:
  "p \<in> poss s \<Longrightarrow> funas_term t \<subseteq> funas_term (s[p \<leftarrow> t])"
proof (induct p arbitrary: s)
  case (Cons i p)
  show ?case using Cons(1)[of "args s ! i"] Cons(2-)
    by (cases s) (fastforce simp: in_set_conv_nth nth_list_update split!: if_splits)+
qed simp

lemma poss_of_term_possI [intro!]:
  "p \<in> poss s \<Longrightarrow> s |_ p = u \<Longrightarrow> p \<in> poss_of_term u s"
  unfolding poss_of_term_def by blast

lemma poss_of_term_replace_term_at:
  "p \<in> poss s \<Longrightarrow> p \<in> poss_of_term u s[p \<leftarrow> u]"
proof (induct p arbitrary: s)
  case (Cons i p) then show ?case
    by (cases s) (auto simp: poss_of_term_def)
qed auto

lemma constT_nfunas_term_poss_of_term_empty:
  "(c, 0) \<notin> funas_term t \<longleftrightarrow> poss_of_term (constT c) t = {}"
  unfolding poss_of_term_def
  using funas_term_subt_at[of c 0 t]
  using funas_term_subterm_atI[where ?\<F> ="funas_term t" and ?s = t, THEN subsetD]
  by auto

lemma poss_of_term_poss_emptyD:
  assumes "poss_of_term u s = {}"
  shows "p \<in> poss s \<Longrightarrow> s |_ p \<noteq> u" using assms
  unfolding poss_of_term_def by blast

lemma possc_subt_at_ctxt_apply:
  "p \<in> possc C \<Longrightarrow> p \<bottom> hole_pos C \<Longrightarrow> C\<langle>s\<rangle> |_ p = C\<langle>t\<rangle> |_ p"
proof (induct p arbitrary: C)
  case (Cons i p)
  have [dest]: "length ss # p \<in> possc (More f ss D ts) \<Longrightarrow> p \<in> possc D" for f ss D ts
    by (auto simp: possc_def)
  show ?case using Cons
    by (cases C) (auto simp: nth_append_Cons)
qed simp

end


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

theory Domain_T
imports CSP.Prefix
begin

(*****************************************************************

         1.
         2.
         3.
         4.

 *****************************************************************)

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)

(* for Isabelle 2013
declare Union_image_eq [simp del]
declare Inter_image_eq [simp del]
*)
(* no simp rules in Isabelle 2017
declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]
*)

(***********************************************************
                 type def (Trace Part)
 ***********************************************************)

definition
  HC_T1    :: "'a trace set => bool"
  where
  HC_T1_def : "HC_T1 T == (T ~= {} & prefix_closed T)"

definition "domT  = {T::('a trace set). HC_T1(T)}"
typedef 'a domT = "domT :: 'a trace set set"
(* typedef 'a domT = "{T::('a trace set). HC_T1(T)}" *)
apply (rule_tac x ="{<>}" in exI)
apply (simp add: domT_def)
by (simp add: HC_T1_def prefix_closed_def)

declare Rep_domT         [simp]

(***********************************************************
                   operators on domT
 ***********************************************************)

definition
  memT     :: "'a trace => 'a domT => bool"  ("(_/ :t _)" [50, 51] 50)
  where
  memT_def     : "x :t T     == x : (Rep_domT T)"

definition
  CollectT :: "('a trace => bool) => 'a domT"("CollectT")
  where
  CollectT_def : "CollectT P == Abs_domT (Collect P)"

definition
  UnionT   :: "'a domT set => 'a domT"       ("UnionT _" [90] 90)
  where
  UnionT_def   : "UnionT Ts  == Abs_domT (Union (Rep_domT ` Ts))"

definition
  InterT   :: "'a domT set => 'a domT"       ("InterT _" [90] 90)
  where
  InterT_def   : "InterT Ts  == Abs_domT (Inter (Rep_domT ` Ts))"

definition
  empT     :: "'a domT"                      ("{}t")
  where
  empT_def     : "{}t        == Abs_domT {}"

definition
  UNIVT    :: "'a domT"                      ("UNIVt")
  where
  UNIVT_def    : "UNIVt      == Abs_domT UNIV"

(******** X-symbols ********)
(*
notation (xsymbols) memT ("(_/ \<in>t _)" [50, 51] 50)
notation (xsymbols) UnionT ("\<Union>t _" [90] 90)
notation (xsymbols) InterT ("\<Inter>t _" [90] 90)
*)
(******** syntactic sugar ********)

abbreviation
 nonmemT :: "'a trace => 'a domT => bool"   ("(_/ ~:t _)" [50, 51] 50)
 where "x ~:t T == ~ x :t T"

abbreviation
 UnT :: "'a domT => 'a domT => 'a domT" ("_ UnT _" [65,66] 65)
 where "T UnT S == UnionT {T,S}"

abbreviation
 IntT :: "'a domT => 'a domT => 'a domT" ("_ IntT _" [70,71] 70)
 where "T IntT S == InterT {T,S}"

syntax
  "@CollT"    :: "pttrn => bool => 'a domT"      ("(1{_./ _}t)" [1000,10] 1000)
  "@FindomT"  :: "args => 'a domT"               ("{(_)}t" [1000] 1000)

translations
  "{x. P}t"    == "CONST Abs_domT {x. P}"  (* "CONST" for isabelle2009-2 *)
  "{X}t"       == "CONST Abs_domT {X}"     (* "CONST" for isabelle2009-2 *)

(******** X-symbols ********)
(*
notation (xsymbols) nonmemT ("(_/ \<notin>t _)" [50, 51] 50)
notation (xsymbols) UnT  ("_ \<union>t _" [65,66] 65)
notation (xsymbols) IntT ("_ \<inter>t _" [70,71] 70)
*)
(*********************************************************
          The relation (<=) is defined over domT
 *********************************************************)

instantiation domT :: (type) ord
begin
definition
  subdomT_def:
     "T <= S  ==  (Rep_domT T) <= (Rep_domT S)"
definition
  psubdomT_def:
     "T < S  ==  (Rep_domT T) < (Rep_domT S)"
(*
instance ..
*)
instance
by (intro_classes)
end

(*********************************************************
          The relation (<=) is a partial order
 *********************************************************)

instance domT :: (type) order
apply (intro_classes)
apply (unfold subdomT_def psubdomT_def)
(*apply (simp add: less_fun_def)                (* isabelle 2009-2011 !! *)*)

apply (simp only: order_less_le Rep_domT_inject)
apply (auto simp add: Rep_domT_inject)
done

(***********************************************************
                          lemmas
 ***********************************************************)

(*******************************
             basic
 *******************************)

lemma domT_is_non_empty: "T:domT ==> T ~= {}"
by (simp add: domT_def HC_T1_def)

lemma domT_is_prefix_closed:
  "T:domT ==> prefix_closed T"
by (simp add: domT_def HC_T1_def)

lemma domT_is_prefix_closed_unfold:
  "[| T:domT ; t : T ; prefix s t |] ==> s : T"
apply (simp add: domT_def HC_T1_def)
apply (rule prefix_closed_iff)
by (simp_all)

(*** {<>} in domT ***)

lemma nilt_set_in[simp]: "{<>} : domT"
by (simp add: domT_def HC_T1_def prefix_closed_def)

(*** {<>, <a>} in domT ***)

lemma one_t_set_in[simp]: "{<>,  <a>} : domT"
apply (simp add: domT_def HC_T1_def)
apply (simp add: prefix_closed_def)
apply (intro allI impI)
apply (erule exE)
apply (erule conjE)
apply (erule disjE)
by (simp_all)

(* <> is contained in all domT *)

lemma nilt_in_all_dom: "T : domT ==> <> : T"
apply (simp add: domT_def HC_T1_def)
apply (erule conjE)
apply (subgoal_tac "EX t. t : T")
apply (erule exE)
apply (rule prefix_closed_iff)
by (auto)

(*******************************
        check in domT
 *******************************)

(*** Union ***)

lemma domT_Union_in_domT:
  "Ts ~= {} ==> (Union (Rep_domT ` Ts)) : domT"
apply (simp add: domT_def HC_T1_def)
apply (simp add: prefix_closed_def)
apply (rule conjI)

apply (subgoal_tac "EX T. T : Ts")
apply (erule exE)
apply (rule_tac x="T" in bexI)
apply (simp add: domT_is_non_empty)
apply (simp)
apply (force)

apply (intro allI impI)
apply (elim conjE exE bexE)
apply (rule_tac x="x" in bexI)

apply (rule prefix_closed_iff, simp_all)
apply (rule domT_is_prefix_closed)
apply (simp)
done

(*** Un ***)

lemma domT_Un_in_domT:
  "(Rep_domT T Un Rep_domT S) : domT"
apply (insert domT_Union_in_domT[of "{T,S}"])
by (simp)

(*** Inter ***)

lemma domT_Inter_in_domT:
  "(Inter (Rep_domT ` Ts)) : domT"
apply (simp add: domT_def HC_T1_def)
apply (rule conjI)
apply (subgoal_tac "<> : Inter (Rep_domT ` Ts)", force)
(* apply (simp add: Inter_def)  Isabelle 2012 *)
apply (simp add: nilt_in_all_dom)

apply (simp add: prefix_closed_def)
apply (intro allI impI ballI)
apply (elim conjE exE)
apply (drule_tac x="x" in bspec, simp)

apply (rule prefix_closed_iff, simp_all)
apply (simp add: domT_is_prefix_closed)
done

(*** Int ***)

lemma domT_Int_in_domT:
  "(Rep_domT T Int Rep_domT S) : domT"
apply (insert domT_Inter_in_domT[of "{T,S}"])
by (simp)

lemmas in_domT = domT_Union_in_domT domT_Un_in_domT
                 domT_Inter_in_domT domT_Int_in_domT

(*******************************
    domT type --> set type
 *******************************)

(*** UnionT ***)

(* declare [[simp_trace]] *)

lemma domT_UnionT_Rep:
  "Ts ~= {} ==> Rep_domT (UnionT Ts) = Union (Rep_domT ` Ts)"
apply (simp add: UnionT_def)
apply (simp add: Abs_domT_inverse in_domT)
done

(*** UnT ***)

lemma domT_UnT_Rep:
  "Rep_domT (T UnT S) = (Rep_domT T) Un (Rep_domT S)"
by (simp add: domT_UnionT_Rep)

(*** InterT ***)

lemma domT_InterT_Rep:
  "Rep_domT (InterT Ts) = Inter (Rep_domT ` Ts)"
by (simp add: InterT_def Abs_domT_inverse in_domT)

(*** IntT ***)

lemma domT_IntT_Rep:
  "Rep_domT (T IntT S) = (Rep_domT T) Int (Rep_domT S)"
by (simp add: domT_InterT_Rep)

(*********************************************************
                       memT
 *********************************************************)

(* prefix closed *)

lemma memT_prefix_closed:
  "[| t :t T ; prefix s t |] ==> s :t T"
apply (simp add: memT_def)
apply (rule domT_is_prefix_closed_unfold)
by (simp_all)

(* <> *)

lemma nilt_in_T[simp]: "<> :t T"
by (simp add: memT_def nilt_in_all_dom)

(* UnionT *)

lemma memT_UnionT_only_if:
  "[| Ts ~= {} ; t :t UnionT Ts |] ==> EX T:Ts. t :t T"
by (simp add: memT_def domT_UnionT_Rep)

lemma memT_UnionT_if:
  "[| T:Ts ; t :t T |] ==> t :t UnionT Ts"
apply (subgoal_tac "Ts ~= {}")
apply (simp add: memT_def domT_UnionT_Rep)
apply (rule_tac x="T" in bexI)
by (auto)

lemma memT_UnionT[simp]:
  "Ts ~= {} ==> t :t UnionT Ts = (EX T:Ts. t :t T)"
apply (rule iffI)
apply (simp add: memT_UnionT_only_if)
by (auto simp add: memT_UnionT_if)

(* InterT *)

lemma memT_InterT_only_if:
  "t :t InterT Ts ==> ALL T:Ts. t :t T"
by (simp add: memT_def domT_InterT_Rep)

lemma memT_InterT_if:
  "ALL T:Ts. t :t T ==> t :t InterT Ts"
by (simp add: memT_def domT_InterT_Rep)

lemma memT_InterT[simp]:
  "t :t InterT Ts = (ALL T:Ts. t :t T)"
apply (rule iffI)
apply (rule memT_InterT_only_if, simp_all)
by (simp add: memT_InterT_if)

(* <> *)

lemma memT_nilt[simp]: "t :t {<>}t = (t = <>)"
by (simp add: memT_def Abs_domT_inverse)

(* [e]t, <> *)

lemma memT_nilt_one[simp]: "t :t {<>, <a>}t = (t = <> | t = <a>)"
by (simp add: memT_def Abs_domT_inverse)

(*********************************************************
                       subdomT
 *********************************************************)

lemma subdomTI [intro!]: "(!! t. t :t S ==> t :t T) ==> S <= T"
by (auto simp add: subdomT_def memT_def)

lemma subdomTE [elim!]: "[| S <= T ; (!!t. t :t S ==> t :t T) ==> R |] ==> R"
by (auto simp add: subdomT_def memT_def)

lemma subdomTE_ALL: "[| S <= T ; (ALL t. t :t S --> t :t T) ==> R |] ==> R"
by (auto simp add: subdomT_def memT_def)

lemma subdomT_iff: "((S::'a domT) <= T) = (ALL t. t :t S --> t :t T)"
by (auto)

(*** {<>}t is bottom ***)

lemma BOT_is_bottom_domT[simp]: "{<>}t <= T"
by (simp add: subdomT_iff)

lemma memT_subdomT: "[| t :t S ; S <= T |] ==> t :t T"
by (simp add: subdomT_iff)

(*********************************************************
                         UnT
 *********************************************************)

lemma UnT_commut: "S UnT T = T UnT S"
apply (rule order_antisym)
by (simp_all add: subdomT_iff)

lemma UnT_assoc: "(S UnT T) UnT R = S UnT (T UnT R)"
apply (rule order_antisym)
by (simp_all add: subdomT_iff)

lemma UnT_left_commut: "S UnT (T UnT R) = T UnT (S UnT R)"
apply (rule order_antisym)
by (simp_all add: subdomT_iff)

lemmas UnT_rules = UnT_commut UnT_assoc UnT_left_commut

lemma UnT_nilt_left[simp]: "{<>}t UnT T = T"
apply (rule order_antisym)
by (auto)

lemma UnT_nilt_right[simp]: "T UnT {<>}t = T"
apply (rule order_antisym)
by (auto)

(*********************************************************
                         IntT
 *********************************************************)

lemma IntT_commut: "S IntT T = T IntT S"
apply (rule order_antisym)
by (simp_all add: subdomT_iff)

lemma IntT_assoc: "(S IntT T) IntT R = S IntT (T IntT R)"
apply (rule order_antisym)
by (simp_all add: subdomT_iff)

lemma IntT_left_commut: "S IntT (T IntT R) = T IntT (S IntT R)"
apply (rule order_antisym)
by (simp_all add: subdomT_iff)

lemmas IntT_rules = IntT_commut IntT_assoc IntT_left_commut

(*********************************************************
                         CollectT
 *********************************************************)

(*** open ***)

lemma CollectT_open[simp]: "{u. u :t T}t = T"
apply (subgoal_tac "{u. u :t T} : domT")
apply (auto simp add: memT_def Abs_domT_inverse)
by (simp add: Rep_domT_inverse)

lemma CollectT_open_memT: "{t. P t} : domT ==> t :t {t. P t}t = P t"
by (simp add: memT_def Abs_domT_inverse)

(*** implies {  }t ***)

lemma set_CollectT_eq:
  "{t. Pr1 t} = {t. Pr2 t} ==>{t. Pr1 t}t = {t. Pr2 t}t"
by (simp)

lemma CollectT_eq:
  "[| !! t. Pr1 t = Pr2 t |] ==>{t. Pr1 t}t = {t. Pr2 t}t"
by (simp)

(****************** to add them again ******************)
(*
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)
(*
declare Sup_image_eq [simp]
declare Inf_image_eq [simp]
*)
end


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

section \<open>Minimax Rule\<close>

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

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

subsection \<open>Definition\<close>

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

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

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

end


(*  Title:      HOL/Proofs/Extraction/Higman.thy
    Author:     Stefan Berghofer, TU Muenchen
    Author:     Monika Seisenberger, LMU Muenchen
*)

section \<open>Higman's lemma\<close>

theory Higman
imports Main
begin

text \<open>
  Formalization by Stefan Berghofer and Monika Seisenberger,
  based on Coquand and Fridlender \<^cite>\<open>Coquand93\<close>.
\<close>

datatype letter = A | B

inductive emb :: "letter list \<Rightarrow> letter list \<Rightarrow> bool"
where
  emb0 [Pure.intro]: "emb [] bs"
| emb1 [Pure.intro]: "emb as bs \<Longrightarrow> emb as (b # bs)"
| emb2 [Pure.intro]: "emb as bs \<Longrightarrow> emb (a # as) (a # bs)"

inductive L :: "letter list \<Rightarrow> letter list list \<Rightarrow> bool"
  for v :: "letter list"
where
  L0 [Pure.intro]: "emb w v \<Longrightarrow> L v (w # ws)"
| L1 [Pure.intro]: "L v ws \<Longrightarrow> L v (w # ws)"

inductive good :: "letter list list \<Rightarrow> bool"
where
  good0 [Pure.intro]: "L w ws \<Longrightarrow> good (w # ws)"
| good1 [Pure.intro]: "good ws \<Longrightarrow> good (w # ws)"

inductive R :: "letter \<Rightarrow> letter list list \<Rightarrow> letter list list \<Rightarrow> bool"
  for a :: letter
where
  R0 [Pure.intro]: "R a [] []"
| R1 [Pure.intro]: "R a vs ws \<Longrightarrow> R a (w # vs) ((a # w) # ws)"

inductive T :: "letter \<Rightarrow> letter list list \<Rightarrow> letter list list \<Rightarrow> bool"
  for a :: letter
where
  T0 [Pure.intro]: "a \<noteq> b \<Longrightarrow> R b ws zs \<Longrightarrow> T a (w # zs) ((a # w) # zs)"
| T1 [Pure.intro]: "T a ws zs \<Longrightarrow> T a (w # ws) ((a # w) # zs)"
| T2 [Pure.intro]: "a \<noteq> b \<Longrightarrow> T a ws zs \<Longrightarrow> T a ws ((b # w) # zs)"

inductive bar :: "letter list list \<Rightarrow> bool"
where
  bar1 [Pure.intro]: "good ws \<Longrightarrow> bar ws"
| bar2 [Pure.intro]: "(\<And>w. bar (w # ws)) \<Longrightarrow> bar ws"

theorem prop1: "bar ([] # ws)"
  by iprover

theorem lemma1: "L as ws \<Longrightarrow> L (a # as) ws"
  by (erule L.induct) iprover+

lemma lemma2': "R a vs ws \<Longrightarrow> L as vs \<Longrightarrow> L (a # as) ws"
  supply [[simproc del: defined_all]]
  apply (induct set: R)
  apply (erule L.cases)
  apply simp+
  apply (erule L.cases)
  apply simp_all
  apply (rule L0)
  apply (erule emb2)
  apply (erule L1)
  done

lemma lemma2: "R a vs ws \<Longrightarrow> good vs \<Longrightarrow> good ws"
  supply [[simproc del: defined_all]]
  apply (induct set: R)
  apply iprover
  apply (erule good.cases)
  apply simp_all
  apply (rule good0)
  apply (erule lemma2')
   apply assumption
  apply (erule good1)
  done

lemma lemma3': "T a vs ws \<Longrightarrow> L as vs \<Longrightarrow> L (a # as) ws"
  supply [[simproc del: defined_all]]
  apply (induct set: T)
  apply (erule L.cases)
  apply simp_all
  apply (rule L0)
  apply (erule emb2)
  apply (rule L1)
  apply (erule lemma1)
  apply (erule L.cases)
  apply simp_all
  apply iprover+
  done

lemma lemma3: "T a ws zs \<Longrightarrow> good ws \<Longrightarrow> good zs"
  supply [[simproc del: defined_all]]
  apply (induct set: T)
  apply (erule good.cases)
  apply simp_all
  apply (rule good0)
  apply (erule lemma1)
  apply (erule good1)
  apply (erule good.cases)
  apply simp_all
  apply (rule good0)
  apply (erule lemma3')
  apply iprover+
  done

lemma lemma4: "R a ws zs \<Longrightarrow> ws \<noteq> [] \<Longrightarrow> T a ws zs"
  supply [[simproc del: defined_all]]
  apply (induct set: R)
  apply iprover
  apply (case_tac vs)
  apply (erule R.cases)
  apply simp
  apply (case_tac a)
  apply (rule_tac b=B in T0)
  apply simp
  apply (rule R0)
  apply (rule_tac b=A in T0)
  apply simp
  apply (rule R0)
  apply simp
  apply (rule T1)
  apply simp
  done

lemma letter_neq: "a \<noteq> b \<Longrightarrow> c \<noteq> a \<Longrightarrow> c = b" for a b c :: letter
  apply (case_tac a)
  apply (case_tac b)
  apply (case_tac c, simp, simp)
  apply (case_tac c, simp, simp)
  apply (case_tac b)
  apply (case_tac c, simp, simp)
  apply (case_tac c, simp, simp)
  done

lemma letter_eq_dec: "a = b \<or> a \<noteq> b" for a b :: letter
  apply (case_tac a)
  apply (case_tac b)
  apply simp
  apply simp
  apply (case_tac b)
  apply simp
  apply simp
  done

theorem prop2:
  assumes ab: "a \<noteq> b" and bar: "bar xs"
  shows "\<And>ys zs. bar ys \<Longrightarrow> T a xs zs \<Longrightarrow> T b ys zs \<Longrightarrow> bar zs"
  using bar
proof induct
  fix xs zs
  assume "T a xs zs" and "good xs"
  then have "good zs" by (rule lemma3)
  then show "bar zs" by (rule bar1)
next
  fix xs ys
  assume I: "\<And>w ys zs. bar ys \<Longrightarrow> T a (w # xs) zs \<Longrightarrow> T b ys zs \<Longrightarrow> bar zs"
  assume "bar ys"
  then show "\<And>zs. T a xs zs \<Longrightarrow> T b ys zs \<Longrightarrow> bar zs"
  proof induct
    fix ys zs
    assume "T b ys zs" and "good ys"
    then have "good zs" by (rule lemma3)
    then show "bar zs" by (rule bar1)
  next
    fix ys zs
    assume I': "\<And>w zs. T a xs zs \<Longrightarrow> T b (w # ys) zs \<Longrightarrow> bar zs"
      and ys: "\<And>w. bar (w # ys)" and Ta: "T a xs zs" and Tb: "T b ys zs"
    show "bar zs"
    proof (rule bar2)
      fix w
      show "bar (w # zs)"
      proof (cases w)
        case Nil
        then show ?thesis by simp (rule prop1)
      next
        case (Cons c cs)
        from letter_eq_dec show ?thesis
        proof
          assume ca: "c = a"
          from ab have "bar ((a # cs) # zs)" by (iprover intro: I ys Ta Tb)
          then show ?thesis by (simp add: Cons ca)
        next
          assume "c \<noteq> a"
          with ab have cb: "c = b" by (rule letter_neq)
          from ab have "bar ((b # cs) # zs)" by (iprover intro: I' Ta Tb)
          then show ?thesis by (simp add: Cons cb)
        qed
      qed
    qed
  qed
qed

theorem prop3:
  assumes bar: "bar xs"
  shows "\<And>zs. xs \<noteq> [] \<Longrightarrow> R a xs zs \<Longrightarrow> bar zs"
  using bar
proof induct
  fix xs zs
  assume "R a xs zs" and "good xs"
  then have "good zs" by (rule lemma2)
  then show "bar zs" by (rule bar1)
next
  fix xs zs
  assume I: "\<And>w zs. w # xs \<noteq> [] \<Longrightarrow> R a (w # xs) zs \<Longrightarrow> bar zs"
    and xsb: "\<And>w. bar (w # xs)" and xsn: "xs \<noteq> []" and R: "R a xs zs"
  show "bar zs"
  proof (rule bar2)
    fix w
    show "bar (w # zs)"
    proof (induct w)
      case Nil
      show ?case by (rule prop1)
    next
      case (Cons c cs)
      from letter_eq_dec show ?case
      proof
        assume "c = a"
        then show ?thesis by (iprover intro: I [simplified] R)
      next
        from R xsn have T: "T a xs zs" by (rule lemma4)
        assume "c \<noteq> a"
        then show ?thesis by (iprover intro: prop2 Cons xsb xsn R T)
      qed
    qed
  qed
qed

theorem higman: "bar []"
proof (rule bar2)
  fix w
  show "bar [w]"
  proof (induct w)
    show "bar [[]]" by (rule prop1)
  next
    fix c cs assume "bar [cs]"
    then show "bar [c # cs]" by (rule prop3) (simp, iprover)
  qed
qed

primrec is_prefix :: "'a list \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool"
where
  "is_prefix [] f = True"
| "is_prefix (x # xs) f = (x = f (length xs) \<and> is_prefix xs f)"

theorem L_idx:
  assumes L: "L w ws"
  shows "is_prefix ws f \<Longrightarrow> \<exists>i. emb (f i) w \<and> i < length ws"
  using L
proof induct
  case (L0 v ws)
  then have "emb (f (length ws)) w" by simp
  moreover have "length ws < length (v # ws)" by simp
  ultimately show ?case by iprover
next
  case (L1 ws v)
  then obtain i where emb: "emb (f i) w" and "i < length ws"
    by simp iprover
  then have "i < length (v # ws)" by simp
  with emb show ?case by iprover
qed

theorem good_idx:
  assumes good: "good ws"
  shows "is_prefix ws f \<Longrightarrow> \<exists>i j. emb (f i) (f j) \<and> i < j"
  using good
proof induct
  case (good0 w ws)
  then have "w = f (length ws)" and "is_prefix ws f" by simp_all
  with good0 show ?case by (iprover dest: L_idx)
next
  case (good1 ws w)
  then show ?case by simp
qed

theorem bar_idx:
  assumes bar: "bar ws"
  shows "is_prefix ws f \<Longrightarrow> \<exists>i j. emb (f i) (f j) \<and> i < j"
  using bar
proof induct
  case (bar1 ws)
  then show ?case by (rule good_idx)
next
  case (bar2 ws)
  then have "is_prefix (f (length ws) # ws) f" by simp
  then show ?case by (rule bar2)
qed

text \<open>
  Strong version: yields indices of words that can be embedded into each other.
\<close>

theorem higman_idx: "\<exists>(i::nat) j. emb (f i) (f j) \<and> i < j"
proof (rule bar_idx)
  show "bar []" by (rule higman)
  show "is_prefix [] f" by simp
qed

text \<open>
  Weak version: only yield sequence containing words
  that can be embedded into each other.
\<close>

theorem good_prefix_lemma:
  assumes bar: "bar ws"
  shows "is_prefix ws f \<Longrightarrow> \<exists>vs. is_prefix vs f \<and> good vs"
  using bar
proof induct
  case bar1
  then show ?case by iprover
next
  case (bar2 ws)
  from bar2.prems have "is_prefix (f (length ws) # ws) f" by simp
  then show ?case by (iprover intro: bar2)
qed

theorem good_prefix: "\<exists>vs. is_prefix vs f \<and> good vs"
  using higman
  by (rule good_prefix_lemma) simp+

end


(*  Title:      HOL/Library/Old_Recdef.thy
    Author:     Konrad Slind and Markus Wenzel, TU Muenchen
*)

section \<open>TFL: recursive function definitions\<close>

theory Old_Recdef
imports Main
keywords
  "recdef" :: thy_defn and
  "permissive" "congs" "hints"
begin

subsection \<open>Lemmas for TFL\<close>

lemma tfl_wf_induct: "\<forall>R. wf R \<longrightarrow>
       (\<forall>P. (\<forall>x. (\<forall>y. (y,x)\<in>R \<longrightarrow> P y) \<longrightarrow> P x) \<longrightarrow> (\<forall>x. P x))"
apply clarify
apply (rule_tac r = R and P = P and a = x in wf_induct, assumption, blast)
done

lemma tfl_cut_def: "cut f r x \<equiv> (\<lambda>y. if (y,x) \<in> r then f y else undefined)"
  unfolding cut_def .

lemma tfl_cut_apply: "\<forall>f R. (x,a)\<in>R \<longrightarrow> (cut f R a)(x) = f(x)"
apply clarify
apply (rule cut_apply, assumption)
done

lemma tfl_wfrec:
     "\<forall>M R f. (f=wfrec R M) \<longrightarrow> wf R \<longrightarrow> (\<forall>x. f x = M (cut f R x) x)"
apply clarify
apply (erule wfrec)
done

lemma tfl_eq_True: "(x = True) \<longrightarrow> x"
  by blast

lemma tfl_rev_eq_mp: "(x = y) \<longrightarrow> y \<longrightarrow> x"
  by blast

lemma tfl_simp_thm: "(x \<longrightarrow> y) \<longrightarrow> (x = x') \<longrightarrow> (x' \<longrightarrow> y)"
  by blast

lemma tfl_P_imp_P_iff_True: "P \<Longrightarrow> P = True"
  by blast

lemma tfl_imp_trans: "(A \<longrightarrow> B) \<Longrightarrow> (B \<longrightarrow> C) \<Longrightarrow> (A \<longrightarrow> C)"
  by blast

lemma tfl_disj_assoc: "(a \<or> b) \<or> c \<equiv> a \<or> (b \<or> c)"
  by simp

lemma tfl_disjE: "P \<or> Q \<Longrightarrow> P \<longrightarrow> R \<Longrightarrow> Q \<longrightarrow> R \<Longrightarrow> R"
  by blast

lemma tfl_exE: "\<exists>x. P x \<Longrightarrow> \<forall>x. P x \<longrightarrow> Q \<Longrightarrow> Q"
  by blast

ML_file \<open>old_recdef.ML\<close>

subsection \<open>Rule setup\<close>

lemmas [recdef_simp] =
  inv_image_def
  measure_def
  lex_prod_def
  same_fst_def
  less_Suc_eq [THEN iffD2]

lemmas [recdef_cong] =
  if_cong let_cong image_cong INF_cong SUP_cong bex_cong ball_cong imp_cong
  map_cong filter_cong takeWhile_cong dropWhile_cong foldl_cong foldr_cong

lemmas [recdef_wf] =
  wf_trancl
  wf_less_than
  wf_lex_prod
  wf_inv_image
  wf_measure
  wf_measures
  wf_pred_nat
  wf_same_fst
  wf_empty

end


theory "Cardinality-Domain"
imports "Launchbury.HOLCF-Utils"
begin

type_synonym oneShot = "one"
abbreviation notOneShot :: oneShot where "notOneShot \<equiv> ONE"
abbreviation oneShot :: oneShot where "oneShot \<equiv> \<bottom>"

type_synonym two = "oneShot\<^sub>\<bottom>"
abbreviation many :: two where "many \<equiv> up\<cdot>notOneShot"
abbreviation once :: two where "once \<equiv> up\<cdot>oneShot"
abbreviation none :: two where "none \<equiv> \<bottom>"

lemma many_max[simp]: "a \<sqsubseteq> many" by (cases a) auto

lemma two_conj: "c = many \<or> c = once \<or> c = none" by (metis Exh_Up one_neq_iffs(1))

lemma two_cases[case_names many once none]:
  obtains "c = many" | "c = once" | "c = none" using two_conj by metis

definition two_pred where "two_pred = (\<Lambda> x. if x \<sqsubseteq> once then \<bottom> else x)"

lemma two_pred_simp: "two_pred\<cdot>c = (if c \<sqsubseteq> once then \<bottom> else c)"
  unfolding two_pred_def
  apply (rule beta_cfun)
  apply (rule cont_if_else_above)
  apply (auto elim: below_trans)
  done

lemma two_pred_simps[simp]:
  "two_pred\<cdot>many = many"
  "two_pred\<cdot>once = none"
  "two_pred\<cdot>none = none"
by (simp_all add: two_pred_simp)

lemma two_pred_below_arg: "two_pred \<cdot> f \<sqsubseteq> f"
  by (auto simp add: two_pred_simp)

lemma two_pred_none: "two_pred\<cdot>c = none \<longleftrightarrow> c \<sqsubseteq> once"
  by (auto simp add: two_pred_simp)

definition record_call where "record_call x = (\<Lambda> ce. (\<lambda> y. if x = y then two_pred\<cdot>(ce y) else ce y))"

lemma record_call_simp: "(record_call x \<cdot> f) x' = (if x = x' then two_pred \<cdot> (f x') else f x')"
  unfolding record_call_def by auto

lemma record_call[simp]: "(record_call x \<cdot> f) x = two_pred \<cdot> (f x)"
  unfolding record_call_simp by auto

lemma record_call_other[simp]: "x' \<noteq> x \<Longrightarrow> (record_call x \<cdot> f) x' = f x'"
  unfolding record_call_simp by auto

lemma record_call_below_arg: "record_call x \<cdot> f \<sqsubseteq> f"
  unfolding record_call_def
  by (auto intro!: fun_belowI two_pred_below_arg)

definition two_add :: "two \<rightarrow> two \<rightarrow> two"
  where "two_add = (\<Lambda> x. (\<Lambda> y. if x \<sqsubseteq> \<bottom> then y else (if y \<sqsubseteq> \<bottom> then x else many)))"

lemma two_add_simp: "two_add\<cdot>x\<cdot>y = (if x \<sqsubseteq> \<bottom> then y else (if y \<sqsubseteq> \<bottom> then x else many))"
  unfolding two_add_def
  apply (subst beta_cfun)
  apply (rule cont2cont)
  apply (rule cont_if_else_above)
  apply (auto elim: below_trans)[1]
  apply (rule cont_if_else_above)
  apply (auto elim: below_trans)[8]
  apply (rule beta_cfun)
  apply (rule cont_if_else_above)
  apply (auto elim: below_trans)[1]
  apply (rule cont_if_else_above)
  apply auto
  done

lemma two_pred_two_add_once: "c \<sqsubseteq> two_pred\<cdot>(two_add\<cdot>once\<cdot>c)"
  by (cases c rule: two_cases) (auto simp add: two_add_simp)

end


(*  Title:      HOL/HOLCF/Ssum.thy
    Author:     Franz Regensburger
    Author:     Brian Huffman
*)

section \<open>The type of strict sums\<close>

theory Ssum
  imports Tr
begin

default_sort pcpo

subsection \<open>Definition of strict sum type\<close>

definition "ssum =
  {p :: tr \<times> ('a \<times> 'b). p = \<bottom> \<or>
    (fst p = TT \<and> fst (snd p) \<noteq> \<bottom> \<and> snd (snd p) = \<bottom>) \<or>
    (fst p = FF \<and> fst (snd p) = \<bottom> \<and> snd (snd p) \<noteq> \<bottom>)}"

pcpodef ('a, 'b) ssum  ("(_ \<oplus>/ _)" [21, 20] 20) = "ssum :: (tr \<times> 'a \<times> 'b) set"
  by (simp_all add: ssum_def)

instance ssum :: ("{chfin,pcpo}", "{chfin,pcpo}") chfin
  by (rule typedef_chfin [OF type_definition_ssum below_ssum_def])

type_notation (ASCII)
  ssum  (infixr "++" 10)

subsection \<open>Definitions of constructors\<close>

definition sinl :: "'a \<rightarrow> ('a ++ 'b)"
  where "sinl = (\<Lambda> a. Abs_ssum (seq\<cdot>a\<cdot>TT, a, \<bottom>))"

definition sinr :: "'b \<rightarrow> ('a ++ 'b)"
  where "sinr = (\<Lambda> b. Abs_ssum (seq\<cdot>b\<cdot>FF, \<bottom>, b))"

lemma sinl_ssum: "(seq\<cdot>a\<cdot>TT, a, \<bottom>) \<in> ssum"
  by (simp add: ssum_def seq_conv_if)

lemma sinr_ssum: "(seq\<cdot>b\<cdot>FF, \<bottom>, b) \<in> ssum"
  by (simp add: ssum_def seq_conv_if)

lemma Rep_ssum_sinl: "Rep_ssum (sinl\<cdot>a) = (seq\<cdot>a\<cdot>TT, a, \<bottom>)"
  by (simp add: sinl_def cont_Abs_ssum Abs_ssum_inverse sinl_ssum)

lemma Rep_ssum_sinr: "Rep_ssum (sinr\<cdot>b) = (seq\<cdot>b\<cdot>FF, \<bottom>, b)"
  by (simp add: sinr_def cont_Abs_ssum Abs_ssum_inverse sinr_ssum)

lemmas Rep_ssum_simps =
  Rep_ssum_inject [symmetric] below_ssum_def
  prod_eq_iff below_prod_def
  Rep_ssum_strict Rep_ssum_sinl Rep_ssum_sinr

subsection \<open>Properties of \emph{sinl} and \emph{sinr}\<close>

text \<open>Ordering\<close>

lemma sinl_below [simp]: "sinl\<cdot>x \<sqsubseteq> sinl\<cdot>y \<longleftrightarrow> x \<sqsubseteq> y"
  by (simp add: Rep_ssum_simps seq_conv_if)

lemma sinr_below [simp]: "sinr\<cdot>x \<sqsubseteq> sinr\<cdot>y \<longleftrightarrow> x \<sqsubseteq> y"
  by (simp add: Rep_ssum_simps seq_conv_if)

lemma sinl_below_sinr [simp]: "sinl\<cdot>x \<sqsubseteq> sinr\<cdot>y \<longleftrightarrow> x = \<bottom>"
  by (simp add: Rep_ssum_simps seq_conv_if)

lemma sinr_below_sinl [simp]: "sinr\<cdot>x \<sqsubseteq> sinl\<cdot>y \<longleftrightarrow> x = \<bottom>"
  by (simp add: Rep_ssum_simps seq_conv_if)

text \<open>Equality\<close>

lemma sinl_eq [simp]: "sinl\<cdot>x = sinl\<cdot>y \<longleftrightarrow> x = y"
  by (simp add: po_eq_conv)

lemma sinr_eq [simp]: "sinr\<cdot>x = sinr\<cdot>y \<longleftrightarrow> x = y"
  by (simp add: po_eq_conv)

lemma sinl_eq_sinr [simp]: "sinl\<cdot>x = sinr\<cdot>y \<longleftrightarrow> x = \<bottom> \<and> y = \<bottom>"
  by (subst po_eq_conv) simp

lemma sinr_eq_sinl [simp]: "sinr\<cdot>x = sinl\<cdot>y \<longleftrightarrow> x = \<bottom> \<and> y = \<bottom>"
  by (subst po_eq_conv) simp

lemma sinl_inject: "sinl\<cdot>x = sinl\<cdot>y \<Longrightarrow> x = y"
  by (rule sinl_eq [THEN iffD1])

lemma sinr_inject: "sinr\<cdot>x = sinr\<cdot>y \<Longrightarrow> x = y"
  by (rule sinr_eq [THEN iffD1])

text \<open>Strictness\<close>

lemma sinl_strict [simp]: "sinl\<cdot>\<bottom> = \<bottom>"
  by (simp add: Rep_ssum_simps)

lemma sinr_strict [simp]: "sinr\<cdot>\<bottom> = \<bottom>"
  by (simp add: Rep_ssum_simps)

lemma sinl_bottom_iff [simp]: "sinl\<cdot>x = \<bottom> \<longleftrightarrow> x = \<bottom>"
  using sinl_eq [of "x" "\<bottom>"] by simp

lemma sinr_bottom_iff [simp]: "sinr\<cdot>x = \<bottom> \<longleftrightarrow> x = \<bottom>"
  using sinr_eq [of "x" "\<bottom>"] by simp

lemma sinl_defined: "x \<noteq> \<bottom> \<Longrightarrow> sinl\<cdot>x \<noteq> \<bottom>"
  by simp

lemma sinr_defined: "x \<noteq> \<bottom> \<Longrightarrow> sinr\<cdot>x \<noteq> \<bottom>"
  by simp

text \<open>Compactness\<close>

lemma compact_sinl: "compact x \<Longrightarrow> compact (sinl\<cdot>x)"
  by (rule compact_ssum) (simp add: Rep_ssum_sinl)

lemma compact_sinr: "compact x \<Longrightarrow> compact (sinr\<cdot>x)"
  by (rule compact_ssum) (simp add: Rep_ssum_sinr)

lemma compact_sinlD: "compact (sinl\<cdot>x) \<Longrightarrow> compact x"
  unfolding compact_def
  by (drule adm_subst [OF cont_Rep_cfun2 [where f=sinl]], simp)

lemma compact_sinrD: "compact (sinr\<cdot>x) \<Longrightarrow> compact x"
  unfolding compact_def
  by (drule adm_subst [OF cont_Rep_cfun2 [where f=sinr]], simp)

lemma compact_sinl_iff [simp]: "compact (sinl\<cdot>x) = compact x"
  by (safe elim!: compact_sinl compact_sinlD)

lemma compact_sinr_iff [simp]: "compact (sinr\<cdot>x) = compact x"
  by (safe elim!: compact_sinr compact_sinrD)

subsection \<open>Case analysis\<close>

lemma ssumE [case_names bottom sinl sinr, cases type: ssum]:
  obtains "p = \<bottom>"
  | x where "p = sinl\<cdot>x" and "x \<noteq> \<bottom>"
  | y where "p = sinr\<cdot>y" and "y \<noteq> \<bottom>"
  using Rep_ssum [of p] by (auto simp add: ssum_def Rep_ssum_simps)

lemma ssum_induct [case_names bottom sinl sinr, induct type: ssum]:
  "\<lbrakk>P \<bottom>;
   \<And>x. x \<noteq> \<bottom> \<Longrightarrow> P (sinl\<cdot>x);
   \<And>y. y \<noteq> \<bottom> \<Longrightarrow> P (sinr\<cdot>y)\<rbrakk> \<Longrightarrow> P x"
  by (cases x) simp_all

lemma ssumE2 [case_names sinl sinr]:
  "\<lbrakk>\<And>x. p = sinl\<cdot>x \<Longrightarrow> Q; \<And>y. p = sinr\<cdot>y \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
  by (cases p, simp only: sinl_strict [symmetric], simp, simp)

lemma below_sinlD: "p \<sqsubseteq> sinl\<cdot>x \<Longrightarrow> \<exists>y. p = sinl\<cdot>y \<and> y \<sqsubseteq> x"
  by (cases p, rule_tac x="\<bottom>" in exI, simp_all)

lemma below_sinrD: "p \<sqsubseteq> sinr\<cdot>x \<Longrightarrow> \<exists>y. p = sinr\<cdot>y \<and> y \<sqsubseteq> x"
  by (cases p, rule_tac x="\<bottom>" in exI, simp_all)

subsection \<open>Case analysis combinator\<close>

definition sscase :: "('a \<rightarrow> 'c) \<rightarrow> ('b \<rightarrow> 'c) \<rightarrow> ('a ++ 'b) \<rightarrow> 'c"
  where "sscase = (\<Lambda> f g s. (\<lambda>(t, x, y). If t then f\<cdot>x else g\<cdot>y) (Rep_ssum s))"

translations
  "case s of XCONST sinl\<cdot>x \<Rightarrow> t1 | XCONST sinr\<cdot>y \<Rightarrow> t2" \<rightleftharpoons> "CONST sscase\<cdot>(\<Lambda> x. t1)\<cdot>(\<Lambda> y. t2)\<cdot>s"
  "case s of (XCONST sinl :: 'a)\<cdot>x \<Rightarrow> t1 | XCONST sinr\<cdot>y \<Rightarrow> t2" \<rightharpoonup> "CONST sscase\<cdot>(\<Lambda> x. t1)\<cdot>(\<Lambda> y. t2)\<cdot>s"

translations
  "\<Lambda>(XCONST sinl\<cdot>x). t" \<rightleftharpoons> "CONST sscase\<cdot>(\<Lambda> x. t)\<cdot>\<bottom>"
  "\<Lambda>(XCONST sinr\<cdot>y). t" \<rightleftharpoons> "CONST sscase\<cdot>\<bottom>\<cdot>(\<Lambda> y. t)"

lemma beta_sscase: "sscase\<cdot>f\<cdot>g\<cdot>s = (\<lambda>(t, x, y). If t then f\<cdot>x else g\<cdot>y) (Rep_ssum s)"
  by (simp add: sscase_def cont_Rep_ssum)

lemma sscase1 [simp]: "sscase\<cdot>f\<cdot>g\<cdot>\<bottom> = \<bottom>"
  by (simp add: beta_sscase Rep_ssum_strict)

lemma sscase2 [simp]: "x \<noteq> \<bottom> \<Longrightarrow> sscase\<cdot>f\<cdot>g\<cdot>(sinl\<cdot>x) = f\<cdot>x"
  by (simp add: beta_sscase Rep_ssum_sinl)

lemma sscase3 [simp]: "y \<noteq> \<bottom> \<Longrightarrow> sscase\<cdot>f\<cdot>g\<cdot>(sinr\<cdot>y) = g\<cdot>y"
  by (simp add: beta_sscase Rep_ssum_sinr)

lemma sscase4 [simp]: "sscase\<cdot>sinl\<cdot>sinr\<cdot>z = z"
  by (cases z) simp_all

subsection \<open>Strict sum preserves flatness\<close>

instance ssum :: (flat, flat) flat
  apply (intro_classes, clarify)
  apply (case_tac x, simp)
   apply (case_tac y, simp_all add: flat_below_iff)
  apply (case_tac y, simp_all add: flat_below_iff)
  done

end