theory AFold
imports
  "~~/src/HOL/IMP/Sem_Equiv"
  "~~/src/HOL/IMP/Vars"
begin
text {*

\exercise
Extend @{text afold} with simplifying addition of @{text 0}. That is, for any
expression $e$, $e+0$ and $0+e$ should be simplified to just $e$, including
the case where the $0$ is produced by knowledge of the content of variables.

*}
type_synonym  tab = "vname \<Rightarrow> val option"

fun afold :: "aexp \<Rightarrow> tab \<Rightarrow> aexp" where
(* your definition/proof here *)

text {*
Re-prove the results in this section with the extended version by
copying and adjusting the contents of theory @{text Fold}.
*}

theorem "fold c empty \<sim> c"
(* your definition/proof here *)

text{*
\endexercise
*}

end


(*<*)
theory ex12_tmpl
imports
  Complex_Main
  "HOL-Library.Multiset"
begin
(*>*)
text {* \ExerciseSheet{12}{29.~6.~2018} *}

text \<open>
  \Exercise{Sparse Binary Numbers}

  Implement operations carry, inc, and add on sparse binary numbers,
  analogously to the operations link, ins, and meld on binomial heaps.

  Show that the operations have logarithmic worst-case complexity.
\<close>

type_synonym rank = nat
type_synonym snat = "rank list"

abbreviation invar :: "snat \<Rightarrow> bool" where "invar s \<equiv> sorted_wrt op< s"
definition \<alpha> :: "snat \<Rightarrow> nat" where "\<alpha> s = (\<Sum>i\<leftarrow>s. 2^i)"

lemmas [simp] = sorted_wrt_Cons sorted_wrt_append

fun carry :: "rank \<Rightarrow> snat \<Rightarrow> snat"
  where
  "carry _ _ = undefined"

lemma carry_invar[simp]: specify_something_meaningful oops

lemma carry_\<alpha>: specify_something_meaningful oops

definition inc :: "snat \<Rightarrow> snat" where "inc \<equiv> undefined"

lemma inc_invar[simp]: "invar rs \<Longrightarrow> invar (inc rs)" sorry

lemma inc_\<alpha>[simp]: "invar rs \<Longrightarrow> \<alpha> (inc rs) = Suc (\<alpha> rs)" sorry

fun add :: "snat \<Rightarrow> snat \<Rightarrow> snat"
  where
  "add _ _ = undefined"

lemma add_invar[simp]:
  assumes "invar rs\<^sub>1"
  assumes "invar rs\<^sub>2"
  shows "invar (add rs\<^sub>1 rs\<^sub>2)"
  sorry

lemma add_\<alpha>[simp]:
  assumes "invar rs\<^sub>1"
  assumes "invar rs\<^sub>2"
  shows "\<alpha> (add rs\<^sub>1 rs\<^sub>2) = \<alpha> rs\<^sub>1 + \<alpha> rs\<^sub>2"
  sorry

(** Size in relation to represented number *)
lemma size_snat:
  assumes "invar rs"
  shows "2^length rs \<le> \<alpha> rs + 1"
  sorry

(** Timing *)

fun t_carry :: "rank \<Rightarrow> snat \<Rightarrow> nat"
  where
  "t_carry _ _ = undefined"

definition t_inc :: "snat \<Rightarrow> nat"
  where "t_inc rs = undefined"

lemma t_inc_bound:
  assumes "invar rs"
  shows "t_inc rs \<le> log 2 (\<alpha> rs + 1) + 1"
  sorry

fun t_add :: "snat \<Rightarrow> snat \<Rightarrow> nat"
  where
  "t_add _ _ = undefined"

lemma t_add_bound:
  fixes rs\<^sub>1 rs\<^sub>2
  defines "n\<^sub>1 \<equiv> \<alpha> rs\<^sub>1"
  defines "n\<^sub>2 \<equiv> \<alpha> rs\<^sub>2"
  assumes INVARS: "invar rs\<^sub>1" "invar rs\<^sub>2"
  shows "t_add rs\<^sub>1 rs\<^sub>2 \<le> 4*log 2 (n\<^sub>1 + n\<^sub>2 + 1) + 2"
  sorry

(*<*)
end
(*>*)


subsection \<open>Preliminary commutation relations\<close>

theory CommutationRelations
  imports RegisterMachineSimulation MachineEquations
begin

lemma aux_commute_bitAND_sum:
  fixes N C :: nat
    and fxt :: "nat \<Rightarrow> nat"
  shows "\<forall>i\<le>N. \<forall>j\<le>N. i \<noteq> j \<longrightarrow> (\<forall>k. (fct i) \<exclamdown> k * (fct j) \<exclamdown> k = 0)
          \<Longrightarrow> (\<Sum>k \<le> N. fct k && C) = (\<Sum>k \<le> N. fct k) && C"
proof (induct N)
  case 0
  then show ?case by auto
next
  case (Suc N)
  assume Suc_assms: "\<forall>i\<le>Suc N. \<forall>j\<le>Suc N. i \<noteq> j \<longrightarrow> (\<forall>k. fct i \<exclamdown> k * fct j \<exclamdown> k = 0)"

  have "(\<Sum>k\<le>Suc N. fct k && C) = (\<Sum>k\<le>N. fct k && C) + (fct (Suc N) && C)"
    by (auto cong: sum.cong)
  also have "... = (sum fct {..N} && C) + (fct (Suc N) && C)"
    using Suc by auto
  also have "... = (sum fct {..N} + fct (Suc N)) && C"
  proof -
    let ?a = "sum fct {..N} && C"
    let ?b = "fct (Suc N) && C"

    have formula: "\<forall>d. ( ?a + ?b ) \<exclamdown> d = ( ?a \<exclamdown> d + ?b \<exclamdown> d + bin_carry ?a ?b d ) mod 2"
      using sum_digit_formula by auto

    (* mutual proof of both statements, they are interdependent in the inductive step *)
    have nocarry4: "\<forall>n\<le>Suc N. \<forall>d. (sum fct {..n} \<exclamdown> d > 0 \<longrightarrow> (\<exists>i\<le>n. (fct i) \<exclamdown> d > 0))
                        \<and> bin_carry (sum fct {..<n}) (fct n) d = 0"
    proof -
      {
        fix n

        (* contrapositive of first statement*)
        have "n \<le> Suc N \<Longrightarrow>
                \<forall>d. ((\<forall>i\<le>n. (fct i) \<exclamdown> d = 0)
                \<longrightarrow> sum fct {..n} \<exclamdown> d = 0) \<and> bin_carry (sum fct {..<n}) (fct n) d = 0"
        proof (induction n)
          case 0
          then show ?case by (simp add: bin_carry_def)
        next
          case (Suc m)
          (* using IH of first statement, obtain helper result *)
          from Suc Suc.prems have ex: "\<forall>d. sum fct {..<Suc m} \<exclamdown> d > 0 \<longrightarrow> (\<exists>i<Suc m. fct i \<exclamdown> d = 1)"
            using nth_bit_def
            by (metis One_nat_def Suc_less_eq lessThan_Suc_atMost less_Suc_eq nat_less_le
                      not_mod2_eq_Suc_0_eq_0)

          (* then show another helper result ... *)
          have h1: "\<forall>d. sum fct {..<Suc m} \<exclamdown> d + fct (Suc m) \<exclamdown> d \<le> 1"
          proof -
            {
              fix d
              have "sum fct {..<Suc m} \<exclamdown> d + fct (Suc m) \<exclamdown> d \<le> 1"
              proof (cases "sum fct {..<Suc m} \<exclamdown> d = 0")
                case True
                have "fct (Suc m) \<exclamdown> d \<le> 1"
                  using nth_bit_def by auto
                then show ?thesis using True by auto
              next
                case False
                then have "\<exists>i<Suc m. fct i \<exclamdown> d > 0"
                  using ex by (metis neq0_conv zero_less_one)
                then obtain i where i: "i<Suc m \<and> fct i \<exclamdown> d > 0" by auto
                hence "i \<le> Suc N" using Suc.prems by auto
                hence "\<forall>j\<le>Suc N. i \<noteq> j \<longrightarrow> (\<forall>k. fct i \<exclamdown> k * fct j \<exclamdown> k = 0)"
                  using Suc_assms by auto
                then have "fct (Suc m) \<exclamdown> d = 0"
                  using Suc.prems i nat_neq_iff
                  by (auto) (blast)
                moreover from False have "sum fct {..<Suc m} \<exclamdown> d = 1"
                  by (simp add: nth_bit_def)
                ultimately show ?thesis by auto
              qed
            }
            thus ?thesis by auto
          qed

          (* ... in order to show the inductive step of the second statement *)
          from h1 have h2: "\<forall>d. bin_carry (sum fct {..<Suc m}) (fct (Suc m)) d = 0"
            using carry_digit_impl by (metis Suc_1 Suc_n_not_le_n)
          then have nocarry3: "\<forall>d. bin_carry (sum fct {..m}) (fct (Suc m)) d = 0"
            by (simp add: lessThan_Suc_atMost)

          (* finally use the just proven inductive step for the 2nd statement to show the
              inductive step for the first statement *)
          {
            fix d
            assume a: "\<forall>i\<le>Suc m. (fct i) \<exclamdown> d = 0"
            have "sum fct {..Suc m} \<exclamdown> d = (sum fct {..m} + fct (Suc m)) \<exclamdown> d"
              by auto
            also have "... =
              (sum fct {..m} \<exclamdown> d + fct (Suc m) \<exclamdown> d + bin_carry (sum fct {..m}) (fct (Suc m)) d) mod 2"
              using sum_digit_formula[of "sum fct {..m}" "fct (Suc m)" "d"] by auto
            finally have "sum fct {..Suc m} \<exclamdown> d = 0"
              using nocarry3 Suc a by auto
          }
          with h2 show ?case by auto
        qed

        then have "n \<le> Suc N \<Longrightarrow> \<forall>d. (sum fct {..n} \<exclamdown> d > 0 \<longrightarrow> (\<exists>i\<le>n. (fct i) \<exclamdown> d > 0))
                      \<and> bin_carry (sum fct {..<n}) (fct n) d = 0"
          by auto
      }
      thus ?thesis by auto
    qed

    from Suc_assms have h3: "\<forall>d. ?a \<exclamdown> d + ?b \<exclamdown> d \<le> 1"
    proof -
      have "\<forall>d. ?a \<exclamdown> d + ?b \<exclamdown> d = (sum fct {..N} \<exclamdown> d + fct (Suc N) \<exclamdown> d) * C \<exclamdown> d"
        using bitAND_digit_mult add_mult_distrib by auto
      then have "\<forall>d. ?a \<exclamdown> d + ?b \<exclamdown> d \<le> (sum fct {..N} \<exclamdown> d + fct (Suc N) \<exclamdown> d)"
        using nth_bit_def by auto
      thus ?thesis
        using sum_carry_formula nocarry4 no_carry_mult_equiv nth_bit_bounded bitAND_digit_mult
        by (metis One_nat_def add.commute add_decreasing le_Suc_eq lessThan_Suc_atMost
                  nat_1_eq_mult_iff)
    qed
    from h3 have h4: "\<forall>d. bin_carry ?a ?b d = 0"
      by (metis Suc_1 Suc_n_not_le_n carry_digit_impl)

    (* Helper for proof chain below *)
    have h5: "\<forall>d. bin_carry (sum fct {..N}) (fct (Suc N)) d = 0"
      using nocarry4 lessThan_Suc_atMost by auto

    from formula h3 h4 have "\<forall>d. ( ?a + ?b ) \<exclamdown> d = ?a \<exclamdown> d + ?b \<exclamdown> d"
      by (metis (no_types, lifting) add_cancel_right_left add_le_same_cancel1 add_self_mod_2
            le_zero_eq not_mod2_eq_Suc_0_eq_0 nth_bit_def one_mod_two_eq_one plus_1_eq_Suc)

    then have "\<forall>d. ( ?a + ?b ) \<exclamdown> d = sum fct {..N} \<exclamdown> d * C \<exclamdown> d + fct (Suc N) \<exclamdown> d * C \<exclamdown> d"
      using bitAND_digit_mult by auto

    then have "\<forall>d. ( ?a + ?b ) \<exclamdown> d = (sum fct {..N} \<exclamdown> d + fct (Suc N) \<exclamdown> d) * C \<exclamdown> d"
      by (simp add: add_mult_distrib)
    moreover have "\<forall>d. sum fct {..N} \<exclamdown> d + fct (Suc N) \<exclamdown> d
      = ( sum fct {..N} \<exclamdown> d + fct (Suc N) \<exclamdown> d + bin_carry (sum fct {..N}) (fct (Suc N)) d ) mod 2"
      using h5 sum_carry_formula
      by (metis add_diff_cancel_left' add_diff_cancel_right' mult_div_mod_eq mult_is_0)
    ultimately have "\<forall>d. ( ?a + ?b ) \<exclamdown> d = (sum fct {..N} + fct (Suc N)) \<exclamdown> d * C \<exclamdown> d"
      using sum_digit_formula by auto

    then have "\<forall>d. ( ?a + ?b ) \<exclamdown> d = ( (sum fct {..N} + fct (Suc N)) && C ) \<exclamdown> d"
      using bitAND_digit_mult by auto
    thus ?thesis using digit_wise_equiv by blast
  qed
  ultimately show ?case by auto
qed

lemma aux_commute_bitAND_sum_if:
  fixes N const :: nat
  assumes nocarry: "\<forall>i\<le>N. \<forall>j\<le>N. i \<noteq> j \<longrightarrow> (\<forall>k. (fct i) \<exclamdown> k * (fct j) \<exclamdown> k = 0)"
  shows "(\<Sum>k \<le> N. if cond k then fct k && const else 0)
       = (\<Sum>k \<le> N. if cond k then fct k else 0) && const"
proof -
  from nocarry have nocarry_if:
    "\<forall>i\<le>N. \<forall>j\<le>N. i \<noteq> j \<longrightarrow> (\<forall>k. (if cond i then fct i else 0) \<exclamdown> k *  (if cond j then fct j else 0) \<exclamdown> k = 0)"
    by (metis (full_types) aux1_digit_wise_equiv mult.commute mult_zero_left)

  have "(if cond k then fct k && const else 0) = (if cond k then fct k else 0) && const" for k
    by auto
  hence "(\<Sum>k \<le> N. if cond k then fct k && const else 0)
          = (\<Sum>k \<le> N. (if cond k then fct k else 0) && const)"
    by auto
  also have "... = (\<Sum>k \<le> N. if cond k then fct k else 0) && const"
    using nocarry_if aux_commute_bitAND_sum[where ?fct = "\<lambda>k. (if cond k then fct k else 0)"]
    by blast
  ultimately show ?thesis by auto
qed

lemma mod_mod:
  fixes x a b :: nat
  shows "x mod 2^a mod 2^b = x mod 2^(min a b)"
  by (metis min.commute take_bit_eq_mod take_bit_take_bit)

lemma carry_gen_pow2_reduct:
  assumes "c>0"
  defines b: "b \<equiv> 2 ^ (Suc c)"
  assumes "nth_digit x (t-1) (2^Suc c) \<exclamdown> c = 0"
      and "nth_digit y (t-1) (2^Suc c) \<exclamdown> c = 0"
    shows "k\<le>c \<Longrightarrow> bin_carry (nth_digit x t b) (nth_digit y t b) k
                 = bin_carry x y (Suc c * t + k)"
proof (induction k)
  case 0
  then show ?case
  proof (cases "t=0")
    case True
    then show ?thesis using bin_carry_def by auto
  next
    case False
    hence "t>0" by auto
    from assms(3) have "x \<exclamdown> (Suc c * (t - 1) + c) = 0"
      using digit_gen_pow2_reduct[of "c" "Suc c" "x" "t-1"] by auto
    moreover have "y \<exclamdown> (Suc c * (t - 1) + c) = 0"
      using assms(4) digit_gen_pow2_reduct[of "c" "Suc c" "y" "t-1"] by auto
    moreover have "Suc c * (t - 1) + c = t + c * t - Suc 0"
      using add.left_commute gr0_conv_Suc \<open>t>0\<close> by auto
    ultimately have "(x \<exclamdown> (t + c * t - Suc 0) + y \<exclamdown> (t + c * t - Suc 0)
      + bin_carry x y (t + c * t - Suc 0)) \<le> 1" using carry_bounded by auto
    hence "bin_carry x y (Suc c * t) = 0"
      using sum_carry_formula[of "x" "y" "Suc c * t - 1"] \<open>c>0\<close> \<open>t>0\<close> by auto

    moreover have "bin_carry (nth_digit x t b) (nth_digit y t b) 0 = 0"
      using 0 bin_carry_def by auto
    ultimately show ?thesis by auto
  qed
next
  case (Suc k)
  have "k<Suc c \<Longrightarrow> x \<exclamdown> (Suc c * t + k) = nth_digit x t b \<exclamdown> k"
    using digit_gen_pow2_reduct[of "k" "Suc c" "x" "t"] b by auto
  moreover have "k<Suc c \<Longrightarrow> y \<exclamdown> (Suc c * t + k) = nth_digit y t b \<exclamdown> k"
    using digit_gen_pow2_reduct[of "k" "Suc c" "y" "t"] b by auto
  ultimately show ?case using Suc
      sum_carry_formula[of "nth_digit x t b" "nth_digit y t b" "k"]
      sum_carry_formula[of "x" "y" "Suc c * t + k"]
      by auto
qed

lemma nth_digit_bound:
  fixes c defines "b \<equiv> 2 ^ (Suc c)"
  shows "nth_digit x t b < 2 ^ (Suc c)"
  using nth_digit_def b_def by auto

lemma digit_wise_block_additivity:
  fixes c
  defines "b \<equiv> 2 ^ Suc c"
  assumes "nth_digit x (t-1) (2^Suc c) \<exclamdown> c = 0"
      and "nth_digit y (t-1) (2^Suc c) \<exclamdown> c = 0"
      and "k\<le>c"
      and "c>0"
  shows "nth_digit (x+y) t b \<exclamdown> k = (nth_digit x t b + nth_digit y t b) \<exclamdown> k"
proof -
  have "k < Suc c" using `k\<le>c` by simp
  have x: "nth_digit x t b \<exclamdown> k = x \<exclamdown> (Suc c * t + k)"
    using digit_gen_pow2_reduct[of "k" "Suc c" "x" "t"] b_def `k<Suc c` by auto
  have y: "nth_digit y t b \<exclamdown> k = y \<exclamdown> (Suc c * t + k)"
    using digit_gen_pow2_reduct[of "k" "Suc c" "y" "t"] b_def `k<Suc c` by auto

  have "(nth_digit x t b + nth_digit y t b) \<exclamdown> k
      = ((nth_digit x t b) \<exclamdown> k + (nth_digit y t b) \<exclamdown> k
      + bin_carry (nth_digit x t b) (nth_digit y t b) k) mod 2"
    using sum_digit_formula[of "nth_digit x t b" "nth_digit y t b" "k"] by auto
  also have "... = (x \<exclamdown> (Suc c * t + k) + y \<exclamdown> (Suc c * t + k)
      + bin_carry (nth_digit x t b) (nth_digit y t b) k) mod 2"
    using x y by auto
  also have "... = (x \<exclamdown> (Suc c * t + k) + y \<exclamdown> (Suc c * t + k)
      + bin_carry x y (Suc c * t + k)) mod 2"
    using carry_gen_pow2_reduct[of "c" "x" "t" "y" "k"] assms by auto
  also have "... = (x + y) \<exclamdown> (Suc c * t + k)"
    using sum_digit_formula by auto
  also have "... = nth_digit (x+y) t b \<exclamdown> k"
    using digit_gen_pow2_reduct[of "k" "Suc c" "x+y" "t"] b_def `k<Suc c` by auto
  finally show ?thesis by auto
qed

lemma block_additivity:
  assumes "c > 0"
  defines "b \<equiv> 2 ^ Suc c"
  assumes "nth_digit x (t-1) b \<exclamdown> c = 0"
      and "nth_digit y (t-1) b \<exclamdown> c = 0"
      and "nth_digit x t b \<exclamdown> c = 0"
      and "nth_digit y t b \<exclamdown> c = 0"
      (* needs stronger assumptions than digit_wise_block_additivity *)
  shows "nth_digit (x+y) t b = nth_digit x t b + nth_digit y t b"
proof -
  {
    have "nth_digit x t b < b" using nth_digit_bound b_def by auto
    hence x_digit_bound: "\<And>k. k\<ge>Suc c \<longrightarrow> nth_digit x t b \<exclamdown> k = 0"
      using nth_bit_def b_def aux_lt_implies_mask b_def by metis

    have "nth_digit y t b < b" using nth_digit_bound b_def by auto
    hence y_digit_bound: "\<And>k. k\<ge>Suc c \<longrightarrow> nth_digit y t b \<exclamdown> k = 0"
      using nth_bit_def b_def aux_lt_implies_mask b_def by metis

    fix k
    assume k: "k\<ge>Suc c"
    have carry0: "bin_carry (nth_digit x t b) (nth_digit y t b) k = 0"
    proof - (* induction proof using rule nat_induct_at_least to accommodate fact k *)
      (* base case *)
      have base: "bin_carry (nth_digit x t b) (nth_digit y t b) (Suc c) = 0"
        using sum_carry_formula[where ?k = "c"] bin_carry_bounded[where ?k = "c"]
        using assms(5-6) by (metis Suc_eq_plus1 add_cancel_left_left mod_div_trivial)

      (* inductive step *)
      {
        fix n
        assume n: "n \<ge> Suc c"
        assume IH: "bin_carry (nth_digit x t b) (nth_digit y t b) n = 0"
        have "bin_carry (nth_digit x t b) (nth_digit y t b) (Suc n)
          = (nth_digit x t b \<exclamdown> n + nth_digit y t b \<exclamdown> n
          + bin_carry (nth_digit x t b) (nth_digit y t b) n) div 2"
          using sum_carry_formula[of "nth_digit x t b" "nth_digit y t b"] by auto
        also have "... = bin_carry (nth_digit x t b) (nth_digit y t b) n div 2"
          using x_digit_bound y_digit_bound n by auto
        also have "... = 0" using IH by auto

        finally have "bin_carry (nth_digit x t b) (nth_digit y t b) (Suc n) = 0"
          by auto
      }

      then show ?thesis
        using k base
        using nat_induct_at_least[where ?P = "\<lambda>k. bin_carry (nth_digit x t b)
                                                            (nth_digit y t b) k = 0"]
        by auto
    qed

    have "(nth_digit x t b + nth_digit y t b) \<exclamdown> k
        = (nth_digit x t b \<exclamdown> k + nth_digit y t b \<exclamdown> k
        + bin_carry (nth_digit x t b) (nth_digit y t b) k) mod 2"
      using sum_digit_formula[of "nth_digit x t b" "nth_digit y t b" "k"] by auto
    hence separate_sum: "(nth_digit x t b + nth_digit y t b) \<exclamdown> k = 0"
      using x_digit_bound y_digit_bound carry0 k by auto

    have "nth_digit (x+y) t b < b"
      using nth_digit_bound b_def by auto
    hence xy_sum: "nth_digit (x+y) t b \<exclamdown> k = 0"
      using nth_bit_def b_def aux_lt_implies_mask b_def k by metis
    from xy_sum separate_sum have k_ge: "nth_digit (x+y) t b \<exclamdown> k
                                  = (nth_digit x t b + nth_digit y t b) \<exclamdown> k"
      by auto
  }
  hence k_ge: "k\<ge>Suc c \<longrightarrow> nth_digit (x+y) t b \<exclamdown> k
                         = (nth_digit x t b + nth_digit y t b) \<exclamdown> k" for k
    by auto

  moreover have k_lt:"k<Suc c \<longrightarrow> nth_digit (x+y) t b \<exclamdown> k
                               = (nth_digit x t b + nth_digit y t b) \<exclamdown> k" for k
    using digit_wise_block_additivity assms by auto

  ultimately have "nth_digit (x+y) t b \<exclamdown> k
                = (nth_digit x t b + nth_digit y t b) \<exclamdown> k" for k
    by(cases "k<Suc c"; auto)

  thus ?thesis using digit_wise_equiv[of "nth_digit (x+y) t b"] by auto
qed

lemma block_to_sum:
  assumes "c>0"
  defines b: "b \<equiv> 2 ^ (Suc c)"
  assumes yltx_digits: "\<forall>t'. nth_digit y t' b \<le> nth_digit x t' b"
  shows "y mod b^t \<le> x mod b^t"
proof(cases "t=0")
  case True
  then show ?thesis by auto
next
  case False
  show ?thesis using yltx_digits apply(induct t, auto) using yltx_digits
    by (smt add.commute add_left_cancel add_mono_thms_linordered_semiring(1) mod_mult2_eq
        mult_le_cancel2 nth_digit_def semiring_normalization_rules(7))
qed

lemma narry_gen_pow2_reduct:
  assumes "c>0"
  defines b: "b \<equiv> 2 ^ (Suc c)"
  assumes yltx_digits: "\<forall>t'. nth_digit y t' b \<le> nth_digit x t' b"
  shows "k\<le>c \<Longrightarrow> bin_narry (nth_digit x t b) (nth_digit y t b) k
    = bin_narry x y (Suc c * t + k)"
proof (induction k)
  case 0
  then show ?case
  proof (cases "t=0")
    case True
    then show ?thesis by (simp add: bin_narry_def)
  next
    case False
    have "bin_narry x y (Suc c * t) = 0" using yltx_digits block_to_sum bin_narry_def assms
      by (metis not_less power_mult)
    then show ?thesis by (simp add: bin_narry_def)
  qed
next
  case (Suc k)
  have ylex: "y\<le>x" using yltx_digits digitwise_leq b Suc_1 lessI power_gt1 by metis
  have "k<Suc c \<Longrightarrow> x \<exclamdown> (Suc c * t + k) = nth_digit x t b \<exclamdown> k"
    using digit_gen_pow2_reduct[of "k" "Suc c" "x" "t"] b by auto
  moreover have "k<Suc c \<Longrightarrow> y \<exclamdown> (Suc c * t + k) = nth_digit y t b \<exclamdown> k"
    using digit_gen_pow2_reduct[of "k" "Suc c" "y" "t"] b by auto
  ultimately show ?case using Suc yltx_digits
      dif_narry_formula[of "(nth_digit y t b)" "(nth_digit x t b)" k]
      dif_narry_formula[of y x "Suc c * t + k"] ylex by auto
qed

lemma digit_wise_block_subtractivity:
  fixes c
  defines "b \<equiv> 2 ^ Suc c"
  assumes yltx_digits: "\<forall>t'. nth_digit y t' b \<le> nth_digit x t' b"
      and "k\<le>c"
      and "c>0"
  shows "nth_digit (x-y) t b \<exclamdown> k = (nth_digit x t b - nth_digit y t b) \<exclamdown> k"
proof -
  have x: "nth_digit x t b \<exclamdown> k = x \<exclamdown> (Suc c * t + k)"
    using digit_gen_pow2_reduct[of "k" "Suc c" "x" "t"] b_def `k\<le>c` by auto
  have y: "nth_digit y t b \<exclamdown> k = y \<exclamdown> (Suc c * t + k)"
    using digit_gen_pow2_reduct[of "k" "Suc c" "y" "t"] b_def `k\<le>c` by auto

  have "b > 1" using `c>0` b_def
    by (metis Suc_1 lessI power_gt1)
  then have yltx: "y \<le> x" using digitwise_leq yltx_digits by auto

  have "(nth_digit x t b - nth_digit y t b) \<exclamdown> k
      = ((nth_digit x t b) \<exclamdown> k + (nth_digit y t b) \<exclamdown> k
        + bin_narry (nth_digit x t b) (nth_digit y t b) k) mod 2"
    using dif_digit_formula yltx_digits by auto
  also have "... = (x \<exclamdown> (Suc c * t + k) + y \<exclamdown> (Suc c * t + k)
                    + bin_narry (nth_digit x t b) (nth_digit y t b) k) mod 2"
    using x y by auto
  also have "... = (x \<exclamdown> (Suc c * t + k) + y \<exclamdown> (Suc c * t + k)
                    + bin_narry x y (Suc c * t + k)) mod 2"
  using narry_gen_pow2_reduct using assms(3) assms(4) b_def yltx_digits by auto
  also have "... = nth_digit (x-y) t b \<exclamdown> k"
    using digit_gen_pow2_reduct[of "k" "Suc c" "x-y" "t"] b_def `k\<le>c` dif_digit_formula yltx
    by auto
  finally show ?thesis by auto
qed

lemma block_subtractivity:
  assumes "c > 0"
  defines "b \<equiv> 2 ^ Suc c"
  assumes block_wise_lt: "\<forall>t'. nth_digit y t' b \<le> nth_digit x t' b"
  shows "nth_digit (x-y) t b = nth_digit x t b - nth_digit y t b"
proof -
  have "k\<le>c \<longrightarrow> nth_digit (x-y) t b \<exclamdown> k = (x - y) \<exclamdown> (Suc c * t + k)" for k
    using digit_gen_pow2_reduct[of "k" "Suc c" "x-y" "t"] b_def by auto
  have "k\<le>c \<longrightarrow> nth_digit x t b \<exclamdown> k = x \<exclamdown> (Suc c * t + k)" for k
    using digit_gen_pow2_reduct[of "k" "Suc c" "x" "t"] b_def by auto
  have "k\<le>c \<longrightarrow> nth_digit y t b \<exclamdown> k = y \<exclamdown> (Suc c * t + k)" for k
    using digit_gen_pow2_reduct[of "k" "Suc c" "y" "t"] b_def by auto

  have k_le: "k \<le> c \<longrightarrow> nth_digit (x-y) t b \<exclamdown> k
               = (nth_digit x t b - nth_digit y t b) \<exclamdown> k" for k
    using assms digit_wise_block_subtractivity by auto

  have "nth_digit x t b - nth_digit y t b < b" using
      nth_digit_bound b_def by (simp add: less_imp_diff_less)
  hence diff: "k\<ge>Suc c \<longrightarrow> (nth_digit x t b - nth_digit y t b) \<exclamdown> k = 0" for k
    using nth_bit_def b_def aux_lt_implies_mask b_def by metis

  have "nth_digit (x-y) t b < b" using nth_digit_bound b_def by auto
  hence "k\<ge>Suc c \<longrightarrow> nth_digit (x-y) t b \<exclamdown> k = 0" for k
    using nth_bit_def b_def aux_lt_implies_mask b_def by metis
  with diff have k_gt: "k > c \<longrightarrow> nth_digit (x-y) t b \<exclamdown> k
               = (nth_digit x t b - nth_digit y t b) \<exclamdown> k" for k
    by auto
  from k_le k_gt have "nth_digit (x-y) t b \<exclamdown> k
              = (nth_digit x t b - nth_digit y t b) \<exclamdown> k" for k by(cases "k>c"; auto)
  thus ?thesis using digit_wise_equiv[of "nth_digit x t b - nth_digit y t b"
                                         "nth_digit (x-y) t b"] by auto
qed

lemma bitAND_nth_digit_commute:
  assumes b_def: "b = 2^(Suc c)"
  shows "nth_digit (x && y) t b = nth_digit x t b && nth_digit y t b"
proof -
  {
    fix k
    assume k: "k < Suc c"
    have prod: "nth_digit (x && y) t b \<exclamdown> k = (x && y) \<exclamdown> (Suc c * t + k)"
      using digit_gen_pow2_reduct[of _ "Suc c" "x && y" "t"] b_def k by auto
    moreover have x: "nth_digit x t b \<exclamdown> k = x \<exclamdown> (Suc c * t + k)"
      using digit_gen_pow2_reduct[of _ "Suc c" "x"] b_def k by auto
    moreover have y: "nth_digit y t b \<exclamdown> k = y \<exclamdown> (Suc c * t + k)"
      using digit_gen_pow2_reduct[of _ "Suc c" "y"] b_def k by auto
    moreover have "(x && y) \<exclamdown> (Suc c * t + k) = (x \<exclamdown> (Suc c * t + k)) * (y \<exclamdown> (Suc c * t + k))"
      using bitAND_digit_mult by auto

    ultimately have "nth_digit (x && y) t b \<exclamdown> k
                     = nth_digit x t b \<exclamdown> k * nth_digit y t b \<exclamdown> k"
      by auto

    also have "... = (nth_digit x t b && nth_digit y t b) \<exclamdown> k"
      using bitAND_digit_mult by auto

    finally have "nth_digit (x && y) t b \<exclamdown> k
                  = (nth_digit x t b && nth_digit y t b) \<exclamdown> k"
      by auto
  }

  (* now also consider k \<ge> Suc c *)
  then have "nth_digit (x && y) t b \<exclamdown> k
                  = (nth_digit x t b && nth_digit y t b) \<exclamdown> k" for k
    by (metis aux_lt_implies_mask b_def bitAND_digit_mult leI mult_eq_0_iff nth_digit_bound)

  then show ?thesis using b_def digit_wise_equiv[of "nth_digit (x && y) t b"] by auto
qed

lemma bx_aux:
  shows "b>1 \<Longrightarrow> nth_digit (b^x) t' b = (if x=t' then 1 else 0)"
  by (cases "t' > x", auto simp: nth_digit_def)
     (metis dvd_imp_mod_0 dvd_power leI less_SucI nat_neq_iff power_diff zero_less_diff)

context
  fixes c b :: nat
  assumes b_def: "b \<equiv> 2^(Suc c)"
  assumes c_gt0: "c>0"
begin

lemma b_gt1: "b>1" using c_gt0 b_def
  using one_less_numeral_iff one_less_power semiring_norm(76) by blast

text \<open>Commutation relations with sums\<close>

(* Commute outside, need assumption for nth_digit inside sum *)

lemma finite_sum_nth_digit_commute:
  fixes M :: nat
  shows "\<forall>t. \<forall>k\<le>M. nth_digit (fct k) t b < 2^c \<Longrightarrow>
         \<forall>t. (\<Sum>i=0..M. nth_digit (fct i) t b) < 2^c \<Longrightarrow>
         nth_digit (\<Sum>i=0..M. fct i) t b = (\<Sum>i=0..M. (nth_digit (fct i) t b))"
proof (induct M arbitrary: t)
  case 0 thus ?case by auto
next
  case (Suc M)

  have assm1: "\<forall>t. \<forall>k\<le>Suc M. nth_digit (fct k) t b < 2^c"
    using Suc.prems by auto
  have assm1_reduced: "\<forall>t. \<forall>k\<le>M. nth_digit (fct k) t b < 2^c"
    using assm1 by auto
  have nocarry2: "\<forall>t. \<forall>k\<le>Suc M. nth_digit (fct k) t b \<exclamdown> c = 0"
    using assm1 nth_bit_def by auto

  have assm2:
    "\<forall>t. nth_digit (fct (Suc M)) t b + (\<Sum>i=0..M. nth_digit (fct i) t b) < 2^c"
    using Suc.prems by (simp add: add.commute)
  hence assm2_reduced: "\<forall>t. (\<Sum>i=0..M. nth_digit (fct i) t b) < 2^c"
    using Suc.prems(2) add_lessD1 by fastforce

  have IH: "\<forall>t. nth_digit (\<Sum>i=0..M. fct i) t b
                = (\<Sum>i=0..M. nth_digit (fct i) t b)"
    using assm1_reduced assm2_reduced Suc.hyps by blast
  then have assm2_IH_commuted: "\<forall>t. nth_digit (\<Sum>i=0..M. fct i) t b < 2^c"
    using assm2_reduced by auto
  hence nocarry3: "\<forall>t. nth_digit (\<Sum>i=0..M. fct i) t b \<exclamdown> c = 0"
    using aux_lt_implies_mask by blast

  have 1: "nth_digit (sum fct {0..M}) (t - 1) b \<exclamdown> c = 0" using nocarry3 by auto
  have 2: "nth_digit (fct (Suc M)) (t - 1) b \<exclamdown> c = 0" using nocarry2 by auto
  have 3: "nth_digit (sum fct {0..M}) t b \<exclamdown> c = 0" using nocarry3 by auto
  have 4: "nth_digit (fct (Suc M)) t b \<exclamdown> c = 0" using nocarry2 by auto
  from block_additivity show ?case using 1 2 3 4 c_gt0 Suc b_def
    using IH by auto
qed

lemma sum_nth_digit_commute_aux:
  fixes g
  defines SX_def: "SX \<equiv> \<lambda>l m (fct :: nat \<Rightarrow> nat). (\<Sum>k = 0..m. if g l k then fct k else 0)"
    assumes nocarry: "\<forall>t. \<forall>k\<le>M. nth_digit (fct k) t b < 2^c"
    and nocarry_sum: "\<forall>t. (SX l M (\<lambda>k. nth_digit (fct k) t b)) < 2^c"
  shows "nth_digit (SX l M fct) t b = SX l M (\<lambda>k. nth_digit (fct k) t b)"
proof -
  have aux: "nth_digit (if g l i then fct i else 0) t b
              = (if g l i then nth_digit (fct i) t b else 0)" for i t
    using aux1_digit_wise_gen_equiv b_gt1 by auto

  from nocarry have "\<forall>t. \<forall>k\<le>M. nth_digit (if g l k then fct k else 0) t b < 2^c"
    using aux by auto

  moreover from nocarry_sum have
    "\<forall>t. (\<Sum>i = 0..M. nth_digit (if g l i then fct i else 0) t b) < 2 ^ c"
    unfolding SX_def by (auto simp: aux)

  ultimately have "nth_digit (\<Sum>k = 0..M. if g l k then fct k else 0) t b
      = (\<Sum>k = 0..M. nth_digit (if g l k then fct k else 0) t b)"
    using finite_sum_nth_digit_commute[where ?fct = "\<lambda>k. if g l k then fct k else 0"]
    by (simp add: SX_def)
  moreover have "\<forall>k. nth_digit (if g l k then fct k else 0) t b
                 = (if g l k then nth_digit (fct k) t b else 0)"
    by (auto simp: nth_digit_def)
  ultimately show ?thesis by (auto simp: SX_def)
qed

lemma sum_nth_digit_commute:
  fixes g
  defines SX_def: "SX \<equiv> \<lambda>p l (fct :: nat \<Rightarrow> nat). (\<Sum>k = 0..length p - 1. if g l k then fct k else 0)"
    assumes nocarry: "\<forall>t. \<forall>k\<le>length p - 1. nth_digit (fct k) t b < 2^c"
    and nocarry_sum: "\<forall>t. (SX p l (\<lambda>k. nth_digit (fct k) t b)) < 2^c"
  shows "nth_digit (SX p l fct) t b = SX p l (\<lambda>k. nth_digit (fct k) t b)"
proof -
  let ?m = "length p - 1"

  have "\<forall>t. (\<Sum>k = 0..?m. if g l k then nth_digit (fct k) t b else 0) < 2^c"
    using nocarry_sum unfolding SX_def by blast

  then have "nth_digit (\<Sum>k = 0..length p - 1. if g l k then fct k else 0) t b
             = (\<Sum>k = 0..length p - 1. if g l k then nth_digit (fct k) t b else 0)"
    using nocarry
    using sum_nth_digit_commute_aux[where ?M = "length p - 1"]
    by auto

  then show ?thesis using SX_def by auto
qed

text \<open>Commute inside, need assumption for all partial sums\<close>
lemma finite_sum_nth_digit_commute2:
  fixes M :: nat
  shows "\<forall>t. \<forall>k\<le>M. nth_digit (fct k) t b < 2^c \<Longrightarrow>
         \<forall>t. \<forall>m\<le>M. nth_digit (\<Sum>i=0..m. fct i) t b < 2^c \<Longrightarrow>
         nth_digit (\<Sum>i=0..M. fct i) t b = (\<Sum>i=0..M. (nth_digit (fct i) t b))"
proof (induct M arbitrary: t)
  case 0 thus ?case by auto
next
  case (Suc M)

  have assm1: "\<forall>t. \<forall>k\<le>Suc M. nth_digit (fct k) t b < 2^c"
    using Suc.prems by auto
  have assm1_reduced: "\<forall>t. \<forall>k\<le>M. nth_digit (fct k) t b < 2^c"
    using assm1 by auto
  have nocarry2: "\<forall>t. \<forall>k\<le>Suc M. nth_digit (fct k) t b \<exclamdown> c = 0"
    using assm1 nth_bit_def by auto

  have assm2:
    "\<forall>t. nth_digit (\<Sum>i=0..M. (fct i)) t b < 2^c"
    using Suc.prems by (simp add: add.commute)
  hence nocarry3: "\<forall>t. nth_digit (\<Sum>i=0..M. fct i) t b \<exclamdown> c = 0"
    using aux_lt_implies_mask by blast

  have 1: "nth_digit (sum fct {0..M}) (t - 1) b \<exclamdown> c = 0" using nocarry3 by auto
  have 2: "nth_digit (fct (Suc M)) (t - 1) b \<exclamdown> c = 0" using nocarry2 by auto
  have 3: "nth_digit (sum fct {0..M}) t b \<exclamdown> c = 0" using nocarry3 by auto
  have 4: "nth_digit (fct (Suc M)) t b \<exclamdown> c = 0" using nocarry2 by auto
  from block_additivity show ?case using 1 2 3 4 c_gt0 Suc b_def by auto
qed

lemma sum_nth_digit_commute_aux2:
  fixes g
  defines SX_def: "SX \<equiv> \<lambda>l m (fct :: nat \<Rightarrow> nat). (\<Sum>k = 0..m. if g l k then fct k else 0)"
    assumes nocarry: "\<forall>t. \<forall>k\<le>M. nth_digit (fct k) t b < 2^c"
    and nocarry_sum: "\<forall>t. \<forall>m\<le>M. nth_digit (SX l m fct) t b < 2^c"
  shows "nth_digit (SX l M fct) t b = SX l M (\<lambda>k. nth_digit (fct k) t b)"
proof -
  have aux: "nth_digit (if g l i then fct i else 0) t b
              = (if g l i then nth_digit (fct i) t b else 0)" for i t
    using aux1_digit_wise_gen_equiv b_gt1 by auto

  from nocarry have "\<forall>t. \<forall>k\<le>M. nth_digit (if g l k then fct k else 0) t b < 2^c"
    using aux by auto

  moreover from nocarry_sum have
    "\<forall>t. \<forall>m\<le>M. nth_digit (\<Sum>i = 0..m. (if g l i then fct i else 0)) t b < 2 ^ c"
    unfolding SX_def by (auto simp: aux)

  ultimately have "nth_digit (\<Sum>k = 0..M. if g l k then fct k else 0) t b
      = (\<Sum>k = 0..M. nth_digit (if g l k then fct k else 0) t b)"
    using finite_sum_nth_digit_commute2[where ?fct = "\<lambda>k. if g l k then fct k else 0"]
    by (simp add: SX_def)
  moreover have "\<forall>k. nth_digit (if g l k then fct k else 0) t b
                 = (if g l k then nth_digit (fct k) t b else 0)"
    by (auto simp: nth_digit_def)
  ultimately show ?thesis by (auto simp: SX_def)
qed

lemma sum_nth_digit_commute2:
  fixes g p
  defines SX_def: "SX \<equiv> \<lambda>p l (fct :: nat \<Rightarrow> nat). (\<Sum>k = 0..length p - 1. if g l k then fct k else 0)"
    assumes nocarry: "\<forall>t. \<forall>k\<le>length p - 1. nth_digit (fct k) t b < 2^c"
    and nocarry_sum: "\<forall>t. \<forall>m\<le>length p - 1. nth_digit (SX (take (Suc m) p) l fct) t b < 2^c"
  shows "nth_digit (SX p l fct) t b = SX p l (\<lambda>k. nth_digit (fct k) t b)"
proof -
  have "\<forall>m \<le> length p - 1. (SX (take (Suc m) p) l fct) = (\<Sum>k = 0..m. if g l k then fct k else 0)"
    unfolding SX_def
    by (auto) (metis (no_types, lifting) One_nat_def diff_Suc_1 min_absorb2 min_diff)
  hence "\<forall>t m. m \<le> length p - 1 \<longrightarrow>
            nth_digit (\<Sum>k = 0..m.  if g l k then fct k else 0) t b < 2 ^ c"
    using nocarry_sum by auto

  then have "nth_digit (\<Sum>k = 0..length p - 1. if g l k then fct k else 0) t b
             = (\<Sum>k = 0..length p - 1. if g l k then nth_digit (fct k) t b else 0)"
    using nocarry
    using sum_nth_digit_commute_aux2[where ?M = "length p - 1" and ?fct = "fct" and ?g = g]
    by blast

  then show ?thesis using SX_def by auto
qed

end

end


theory LangCompFullAlt
imports LangCompSimple
begin

(* need a convenient way to map a set of functions
over inputs drawn from another set *)

definition scross :: "('a \<Rightarrow> 'b) set \<Rightarrow> 'a set \<Rightarrow> 'b set" where
"scross Fs Xs =
  { x . \<exists> f y . f \<in> Fs \<and> y \<in> Xs \<and> x = f y }"

lemma scross_inI :
  assumes Hf : "f \<in> Fs"
  assumes Hx : "x \<in> Xs"
  assumes Heq : "res = f x"
  shows "res \<in> scross Fs Xs" using assms
  unfolding scross_def
  by blast

lemma scross_inD  :
  assumes "res \<in> scross Fs Xs"
  shows "\<exists> f y . f \<in> Fs \<and> y \<in> Xs \<and> res = f y" using assms
  unfolding scross_def
  by blast

(* NB: we strengthen this by addding subsets of functions Fs' *)
(* TODO: do we really need the nonemptiness requirement for Fs'? *)
definition sups_pres ::
  "('a \<Rightarrow> ('b :: Mergeable) \<Rightarrow> 'b) set \<Rightarrow> bool" where
"sups_pres Fs =
  (\<forall> x syn Xs Fs' f .
    x \<in> Xs \<longrightarrow>
    finite Xs \<longrightarrow>
    has_sup Xs \<longrightarrow>
    Fs' \<subseteq> Fs \<longrightarrow>
    f \<in> Fs' \<longrightarrow>
    has_sup (scross ((\<lambda> f . f syn) ` Fs') Xs))"

(* for this version, syntaxes are assumed to match.
   i think this will always be the case...
*)

lemma sups_presI [intro] :
  assumes "\<And> x syn Xs Fs' f . has_sup Xs \<Longrightarrow> finite Xs \<Longrightarrow> x \<in> Xs \<Longrightarrow>  Fs' \<subseteq> Fs \<Longrightarrow> f \<in> Fs' \<Longrightarrow>
   has_sup (scross ((\<lambda> f . f syn) ` Fs') Xs)"
  shows "sups_pres Fs"
  using assms unfolding sups_pres_def by blast

(* should we require that mapping fs preserves the upper bound?
or just its existence?

the former would look more like Scott continuity.  but we neeed to make sure that
it is realistic for  the kinds of cases we care about
*)
lemma sups_presD :
  assumes "sups_pres Fs"
  assumes "has_sup Xs"
  assumes "finite Xs"
  assumes "x \<in> Xs"
  assumes "Fs' \<subseteq> Fs"
  assumes "f \<in> Fs'"
  shows "has_sup (scross ((\<lambda> f . f syn) ` Fs') Xs)" using assms
  unfolding sups_pres_def
  by blast

lemma scross_subset :
  assumes HF : "Fs1 \<subseteq> Fs2"
  assumes HX : "Xs1 \<subseteq> Xs2"
  shows "scross Fs1 Xs1 \<subseteq> scross Fs2 Xs2"
proof
  fix res
  assume Hres : "res \<in> scross Fs1 Xs1"

  obtain f x where
    F : "f \<in> Fs1" and
    X : "x \<in> Xs1" and
    Res : "res = f x" using scross_inD[OF Hres] by blast

  show "res \<in> scross Fs2 Xs2"
  proof(rule scross_inI)
    show "f \<in> Fs2"
      using F HF by blast
    show "x \<in> Xs2"
      using X HX by blast
    show "res = f x" using Res by auto
  qed
qed

definition scross_alt :: "('a \<Rightarrow> 'b) set \<Rightarrow> 'a set \<Rightarrow> 'b set" where
"scross_alt Fs Xs =
  (\<lambda> fx . (case fx of (f, x) \<Rightarrow> f x)) ` (Fs \<times> Xs)"

lemma scross_alt_eq :
  "scross_alt Fs Xs = scross Fs Xs"
  unfolding scross_def scross_alt_def
  by(auto)

lemma scross_finite :
  assumes HF : "finite Fs"
  assumes HX : "finite Xs"
  shows "finite (scross Fs Xs)"
  unfolding sym[OF scross_alt_eq] scross_alt_def
  using finite_cartesian_product[OF HF HX]
  by blast

lemma sups_pres_subset :
  fixes Fs :: "('a \<Rightarrow> ('b :: Mergeable) \<Rightarrow> 'b) set"
  assumes H : "sups_pres Fs"
  assumes Hfin : "finite Fs"
  assumes Hsub : "Fs' \<subseteq> Fs"
  assumes Hnemp : "f \<in> Fs'"
  shows "sups_pres Fs'"
proof(rule sups_presI)
  fix syn
  fix Xs :: "'b set"
  fix el :: "'b"
  fix Fs_sub :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) set"
  fix g :: "'a \<Rightarrow> 'b \<Rightarrow> 'b"

  assume H' : "has_sup Xs"
  assume Hfin_Xs : "finite Xs"
  assume Hnemp_Xs : "el \<in> Xs"
  assume HFs_sub : "Fs_sub \<subseteq> Fs'"
  assume HFs_nemp : "g \<in> Fs_sub"

  have HFs_sub_sub : "Fs_sub \<subseteq> Fs" using HFs_sub Hsub by auto

  obtain Rest where Rest : "Fs_sub \<union> Rest = Fs" using HFs_sub_sub by blast

  have El' : "g \<in> Fs" using HFs_sub Hsub HFs_nemp by auto

  have Rfin : "finite Rest" using Rest Hfin by auto

  have Conc' : "has_sup (scross ((\<lambda>f. f syn) ` (Fs_sub \<union> Rest)) Xs)" unfolding Rest
    using sups_presD[OF H H' Hfin_Xs Hnemp_Xs _ El'] by auto

  then obtain supr where Supr :
    "is_sup (scross ((\<lambda>f. f syn) ` (Fs_sub \<union> Rest)) Xs) supr"
    by(auto simp add: has_sup_def)

  have Subset' : "(\<lambda>f. f syn) ` Fs_sub \<subseteq> (\<lambda>f. f syn) ` Fs"
    unfolding sym[OF Rest] by blast

  have Subset : "(scross ((\<lambda>f. f syn) ` (Fs_sub)) Xs)  \<subseteq> (scross ((\<lambda>f. f syn) ` (Fs_sub \<union> Rest)) Xs)"
    using scross_subset[OF Subset', of Xs Xs]
    unfolding Rest
    by blast

  have Nemp : "(g syn el) \<in> scross ((\<lambda>f. f syn) ` Fs_sub) Xs"
    using HFs_nemp Hnemp_Xs
    unfolding scross_def by auto

  have Hfin_full' : "finite ((\<lambda>f. f syn) ` (Fs))"
    using Hfin by blast

  have Fin_full : "finite (scross ((\<lambda>f. f syn) ` (Fs)) Xs)"
    using scross_finite[OF Hfin_full' Hfin_Xs]
    by auto

  show "has_sup (scross ((\<lambda>f. f syn) ` Fs_sub) Xs)"
    using has_sup_subset[OF _ Supr Subset Nemp] Fin_full unfolding Rest
    by auto
qed

lemma sups_pres_pair :
  assumes Hf : "sups_pres {f1, f2}"
  assumes Hx : "has_sup {x1, x2}"
  shows "has_sup {f1 syn x1, f2 syn x2}"
proof-

  have "has_sup (scross ((\<lambda>f. f syn) ` {f1, f2}) {x1, x2})"
    (* using sups_presD[OF Hf Hx, of x1 syn] *)
    using sups_presD[OF Hf Hx _ _, of x1 "{f1, f2}" f1]
    by auto

  then obtain z where Z: "is_sup (scross ((\<lambda>f. f syn) ` {f1, f2}) {x1, x2}) z"
    unfolding has_sup_def by auto

  have Scross_eq :
    "(scross ((\<lambda>f. f syn) ` {f1, f2}) {x1, x2}) =
      { f1 syn x1, f1 syn x2, f2 syn x1, f2 syn x2 }"
    unfolding scross_def by blast

  have Sub : "{f1 syn x1, f2 syn x2} \<subseteq> { f1 syn x1, f1 syn x2, f2 syn x1, f2 syn x2 }"
    by blast

  show "has_sup {f1 syn x1, f2 syn x2}"
    using has_sup_subset[OF _ Z, of "{f1 syn x1, f2 syn x2}" "f1 syn x1"]
    unfolding Scross_eq
    by blast
qed

lemma scross_singleton1 :
"scross {f} Xs = f ` Xs"
  unfolding scross_def
  by blast

lemma scross_singleton2 :
"scross Fs {x} = (\<lambda> f . f x) ` Fs"
  unfolding scross_def
  by blast

(* do we need to generalize this using a set of states?
   - take a bunch of states having a LUB
   - cross (?)
   - hmm... what do we actually need from this?
     - pcomps associativity?
     - in Hoare logic we need to show that, when starting from states having a LUB,
       (in particular, sub lanugage L's state st is less than merged LUB language L' (st'))
       we eventually end up (?) in a state (st1 / st1') where st1 is less than st1'
 *)
lemma sups_pres_pcomps_sup :
  assumes Hp : "sups_pres (set l)"
  assumes Hnemp : "l \<noteq> []"
  shows "is_sup ((\<lambda> f . f syn sem) ` (set l)) (pcomps' l syn sem)" using assms
proof (induction l arbitrary: syn sem)
  case Nil
  then show ?case by auto
next
  case (Cons h1 t1)
  show ?case
  proof(cases t1)
    case Nil' : Nil
    then show ?thesis by(auto simp add: sup_singleton)
  next
    case Cons' : (Cons h2 t2)

    have SP : "sups_pres (set t1)"
      using sups_pres_subset[OF Cons.prems(1), of "set t1"] Cons' by auto

    have Sup : "is_sup ((\<lambda>f. f syn sem) ` set t1) (pcomps' t1 syn sem)"
      using Cons.IH[OF SP, of syn sem] Cons' by( auto)

    have HSup : "is_sup {h1 syn sem} (h1 syn sem)" using sup_singleton by auto

    have Conc' : "has_sup {h1 syn sem, pcomps' t1 syn sem}"
    proof-

      have Eq3 : "(\<lambda>f. f sem) ` (\<lambda>f. f syn) ` set (h1 # t1) = {h1 syn sem} \<union> (\<lambda>f. f syn sem) ` set t1"
        by auto

      have Sing : "has_sup {sem}"
        using sup_singleton[of sem] by(auto simp add: has_sup_def)

      have "has_sup (scross ((\<lambda>f. f syn) ` set (h1 # t1)) {sem})"
        using sups_presD[OF Cons.prems(1) Sing, of sem "set (h1#t1)" "h1" "syn"]
        by(auto)

      then obtain s where S: "is_sup (scross ((\<lambda>f. f syn) ` set (h1 # t1)) {sem}) s"
        by(auto simp add: has_sup_def)

      have Union : "is_sup ({h1 syn sem} \<union> (\<lambda>f. f syn sem) ` set t1) s" using S
        unfolding scross_singleton2 Eq3
        by auto

      show ?thesis using sup_union2[OF HSup Sup Union]
        by(auto simp add: has_sup_def)
    qed

    then obtain s' where S' : "is_sup {h1 syn sem, pcomps' t1 syn sem} s'"
      by(auto simp add: has_sup_def)

    have Conc'' : "is_sup {h1 syn sem, pcomps' t1 syn sem} [^ h1 syn sem, pcomps' (h2 # t2) syn sem ^]"
      using bsup_sup[OF S' bsup_spec] unfolding Cons'  by auto

    have Eqn :
  "(insert (h2 syn sem) (insert (h1 syn sem) ((\<lambda>x. x syn sem) ` set t2))) =
   (insert (h1 syn sem) (insert (h2 syn sem) ((\<lambda>x. x syn sem) ` set t2)))"
      by auto

    show ?thesis
      using sup_union1[OF HSup Sup Conc'']
      by(auto simp add: Cons' Eqn)
  qed
qed

lemma pcomps_assoc :
  assumes H : "sups_pres (set l1 \<union> set l2)"
  assumes Nemp1 : "l1 \<noteq> []"
  assumes Nemp2 : "l2 \<noteq> []"
  shows "pcomps' (l1 @ l2) = pcomps' [pcomps' l1, pcomps' l2]"
proof(rule ext; rule ext)
  fix syn sem

  obtain f1 where F1 : "f1 \<in> set l1" using Nemp1 by(cases l1; auto)

  have H1 : "sups_pres (set l1)"
    using sups_pres_subset[OF H _ _ F1]  by auto

  have Sup1: "is_sup ((\<lambda> f . f syn sem) ` (set l1)) (pcomps' l1 syn sem)"
    using sups_pres_pcomps_sup[OF H1 Nemp1] by auto

  obtain f2 where F2 : "f2 \<in> set l2" using Nemp2 by(cases l2; auto)

  have H2 : "sups_pres (set l2)"
    using sups_pres_subset[OF H _ _ F2]  by auto

  have Sup2: "is_sup ((\<lambda> f . f syn sem) ` (set l2)) (pcomps' l2 syn sem)"
    using sups_pres_pcomps_sup[OF H2 Nemp2] by auto

  have Unions : "set (l1 @ l2) = set l1 \<union> set l2" by auto

  have SupAll1 : "is_sup ((\<lambda> f . f syn sem) ` (set (l1 @ l2))) (pcomps' (l1 @ l2) syn sem)"
    using sups_pres_pcomps_sup[of "l1 @ l2"] H Nemp1
    unfolding Unions by(auto)

  have SupAll2 : "is_sup ((\<lambda> f . f syn sem) ` ({pcomps' l1, pcomps' l2})) (pcomps' (l1 @ l2) syn sem)"
    unfolding pcomps'.simps
    using sup_union2[OF Sup1 Sup2, of "(pcomps' (l1 @ l2) syn sem)"] SupAll1
    unfolding Unions Set.image_Un
    by(auto)

  hence SupAll2' : "is_sup {pcomps' l1 syn sem, pcomps' l2 syn sem} (pcomps' (l1 @ l2) syn sem)" by auto

  have Conc' : "[^ pcomps' l1 syn sem, pcomps' l2 syn sem ^] = (pcomps' (l1 @ l2) syn sem)"
    using is_sup_unique[OF SupAll2' bsup_sup[OF SupAll2' bsup_spec]] by auto

  thus "pcomps' (l1 @ l2) syn sem = pcomps' [pcomps' l1, pcomps' l2] syn sem"
    unfolding pcomps'.simps Conc' by auto
qed

(* has_sup of pcomps' l syn applied to xs? *)
lemma sups_pres_pcomps'_gen :
  assumes H : "sups_pres (set l)"
  assumes Hf : "f \<in> set l"
  assumes Hxs : "finite Xs"
  assumes Hx : "x \<in> Xs"
  assumes Hsup : "is_sup Xs xsup"
  shows "has_sup (pcomps' l syn ` Xs)" using assms
proof(induction l arbitrary: f x)
  case Nil
  then show ?case by auto
next
  case (Cons fh1 ft1)

  have Xs_has_sup : "has_sup Xs"
    using Cons.prems(5)
    unfolding has_sup_def
    by auto

  show ?case
  proof(cases ft1)
    case Nil' : Nil
    then show ?thesis
      using sups_presD[OF Cons.prems(1) Xs_has_sup Cons.prems(3) Cons.prems(4)
                      , of "{fh1}" fh1]
      unfolding has_sup_def
      by(auto simp add: scross_singleton1)
  next
    case Cons' : (Cons fh2 ft2)

    have SP : "sups_pres (set ft1)"
      using sups_pres_subset[OF Cons.prems(1), of "set ft1"] Cons' by auto

    obtain tsup where Tsup : "is_sup (pcomps' ft1 syn ` Xs) tsup"
      using Cons.IH[OF SP _ Hxs Hx Hsup, of fh2] Cons'
      unfolding has_sup_def
      by( auto)

    have Xs_has_sup : "has_sup Xs" using Cons.prems(5)
      unfolding has_sup_def by auto

    obtain hsup1 where Hsup1 : "is_sup (scross ((\<lambda>f. f syn) ` set (fh1 # ft1)) Xs) hsup1"
      using sups_presD[OF Cons.prems(1) Xs_has_sup Cons.prems(3) Cons.prems(4)
                      ,of "set (fh1 # ft1)" fh1]
      unfolding has_sup_def by auto

    have Hd_subset : "{fh1 syn} \<subseteq> ((\<lambda>f. f syn) ` set (fh1 # ft1))"
      by auto

    have Hd_cross_subset : "scross {fh1 syn} Xs \<subseteq> (scross ((\<lambda>f. f syn) ` set (fh1 # ft1)) Xs)"
      using scross_subset[OF Hd_subset, of Xs Xs]
      by auto

    have Hd_finite : "finite (scross ((\<lambda>f. f syn) ` set (fh1 # ft1)) Xs)"
      using scross_finite[OF _ Cons.prems(3), of "((\<lambda>f. f syn) ` set (fh1 # ft1))"]
      by blast

    have Hd_nemp : "fh1 syn x \<in> scross {fh1 syn} Xs"
      using Cons.prems(4)
      unfolding scross_singleton1
      by auto

    obtain hsup2 where Hsup2 : "is_sup (scross {fh1 syn} Xs) hsup2"
      using has_sup_subset[OF Hd_finite Hsup1 Hd_cross_subset Hd_nemp]
      unfolding has_sup_def by auto

    have Cross_fact :
      "(scross ((\<lambda>f. f syn) ` set (fh1 # ft1)) Xs) =
       (scross {fh1 syn} Xs) \<union>
       (scross ((\<lambda>f. f syn) ` set (ft1)) Xs)"
      unfolding scross_def
      by(simp; blast)

    have Conc' : "has_sup ({hsup2, tsup})" sorry
(*
    proof-
(*
      have Eq3 : "(\<lambda>f. f sem) ` (\<lambda>f. f syn) ` set (h1 # t1) = {h1 syn sem} \<union> (\<lambda>f. f syn sem) ` set t1"
        by auto

      have Sing : "has_sup {sem}"
        using sup_singleton[of sem] by(auto simp add: has_sup_def)

      have "has_sup (scross ((\<lambda>f. f syn) ` set (h1 # t1)) {sem})"
        using sups_presD[OF Cons.prems(1)] Sing
        by(auto)

      then obtain s where S: "is_sup (scross ((\<lambda>f. f syn) ` set (h1 # t1)) {sem}) s"
        by(auto simp add: has_sup_def)

      have Union : "is_sup ({h1 syn sem} \<union> (\<lambda>f. f syn sem) ` set t1) s" using S
        unfolding scross_singleton2 Eq3
        by auto

      show ?thesis using sup_union2[OF HSup Sup Union]
        by(auto simp add: has_sup_def)
*)

      have Test0 : "has_sup (scross ((\<lambda>f. f syn) ` set (fh1 # ft1)) Xs)"
        sorry

      have Test1 : "finite (scross ((\<lambda>f. f syn) ` set (fh1 # ft1)) Xs)"
        using scross_finite[OF _  Hxs, of "(\<lambda>f. f syn) ` set (fh1 # ft1)"]
        by auto

      have Test2 : "fh1 syn x \<in> scross ((\<lambda>f. f syn) ` set (fh1 # ft1)) Xs"
        unfolding sym[OF scross_alt_eq] scross_alt_def
        using Cons.prems(4)
        by(auto)

      have Test3 : "set (fh1 # ft1) \<subseteq> set (fh1 # ft1)"
        by auto

      have Test4 : "fh1 \<in> set (fh1 # ft1)" by auto

*)

    obtain cx where Cx : "is_sup ({hsup2, tsup}) cx"
      using Conc'
      unfolding has_sup_def
      by auto

    have Thing : "is_sup ((scross {fh1 syn} Xs) \<union> (pcomps' ft1 syn ` Xs)) cx"
      using sup_union1[OF Hsup2 Tsup Cx] by auto

      have Reassoc : "(scross {fh1 syn} Xs \<union> (pcomps' ft1 syn ` Xs)) =
                      (scross ((\<lambda>f. f syn) ` set (fh1 # ft1)) Xs)"
        unfolding sym[OF scross_alt_eq] scross_alt_def
        sorry
(*      proof
        show "(\<lambda>(f, y). f y) ` ({fh1 syn} \<times> Xs) \<union> pcomps' ft1 syn ` Xs
    \<subseteq> (\<lambda>(f, y). f y) ` ((\<lambda>f. f syn) ` set (fh1 # ft1) \<times> Xs)"
          sorry
      qed
*)

      obtain final where Conc'' : "is_sup ({hsup2, tsup}) final"
        using Conc'
        unfolding has_sup_def
        by auto

      show ?thesis using (*sups_presD[OF Cons.prems(1) (*Test0 Test1 Test2 Test3 Test4*)] *)
        sup_union1[OF Hsup2 Tsup Conc''] Hsup1
        unfolding Reassoc has_sup_def
        using Cons'
        apply(simp add: pcomps'.simps)
        by auto

    then obtain s' where S' : "is_sup {hsup2, tsup} s'"
      by(auto simp add: has_sup_def)

  have Test :
  "(\<lambda>x. [^ fh1 syn x, pcomps' (ft1) syn x ^]) ` Xs \<subseteq>
    (scross {fh1 syn} Xs \<union> pcomps' (ft1) syn ` Xs)"
    sorry

  have Conc_help : "is_sup (scross {fh1 syn} Xs \<union> pcomps' ft1 syn ` Xs) s'"
    using sup_union1[OF Hsup2 Tsup]
    by auto

  have Fin_help : "finite (scross {fh1 syn} Xs \<union> pcomps' ft1 syn ` Xs)"
    sorry

  obtain ne where Ne_help : "ne \<in> ((\<lambda>x. [^ fh1 syn x, pcomps' ft1 syn x ^]) ` Xs)"
    sorry

(*
    have "\<And> x . x \<in> Xs \<Longrightarrow>
          scross {fh1 syn} Xs \<union> pcomps' ft1 syn ` Xs)"
*)
(*
    have Conc'' : "is_sup {h1 syn sem, pcomps' t1 syn sem} [^ h1 syn sem, pcomps' (h2 # t2) syn sem ^]"
      using bsup_sup[OF S' bsup_spec] unfolding Cons'
*)
(*
    have Eqn :
  "(insert (h2 syn sem) (insert (h1 syn sem) ((\<lambda>x. x syn sem) ` set t2))) =
   (insert (h1 syn sem) (insert (h2 syn sem) ((\<lambda>x. x syn sem) ` set t2)))"
      by auto
*)
    show ?thesis using has_sup_subset[OF Fin_help Conc_help Test Ne_help]
      by(auto simp add: Cons')
  qed
qed

    have SP : "sups_pres (set ft)"
      using sups_pres_subset[OF Cons.prems(1), of "set ft"] Cons' by auto

    have Sup : "is_sup ((\<lambda>f. f syn sem) ` set t1) (pcomps' t1 syn sem)"
      using Cons.IH[OF SP, of syn sem] Cons' by( auto)

    have HSup : "is_sup {h1 syn sem} (h1 syn sem)" using sup_singleton by auto

qed

(*
proof(rule is_sup_intro)
  fix y
  assume Y_in : "y \<in> scross ((\<lambda>f. f syn) ` set l) Xs"

  have Hsup' : "has_sup Xs" using Hsup
    unfolding has_sup_def by auto

  show "y <[ pcomps' l syn xsup"
    using sups_presD[OF H Hsup' Hxs Hx, of syn]
*)

(*
  Would a more general version of this be useful?
  This one should be sufficient to prove the Hoare rule.
*)
(*
lemma sups_pres_step :
  assumes H : "sups_pres (set l)"
  assumes Hf : "f \<in> set l"
  assumes Hleq : "x1 <[ x2"
  shows "f syn x1 <[ pcomps' l syn x2"
proof-

  have "is_sup {x1, x2} x2"
  proof(rule is_sup_intro)
    fix x
    show "x \<in> {x1, x2} \<Longrightarrow> x <[ x2"
      using Hleq leq_refl[of x2] by auto
  next
    fix x'
    show "is_ub {x1, x2} x' \<Longrightarrow> x2 <[ x'"
      unfolding is_ub_def
      by auto
  qed

  hence Sup : "has_sup {x1, x2}" unfolding has_sup_def by auto

  have Sup1 : "has_sup (scross ((\<lambda>f. f syn) ` set l) {x1, x2})"
    using sups_presD[OF H Sup]
    by auto
    *)

end