(*  Title:       Primitive recursive coding of finite sets
    Author:      Michael Nedzelsky <MichaelNedzelsky at yandex.ru>, 2008
    Maintainer:  Michael Nedzelsky <MichaelNedzelsky at yandex.ru>
*)

section \<open>Finite sets\<close>

theory PRecFinSet
imports PRecFun
begin

text \<open>
  We introduce a particular mapping \<open>nat_to_set\<close> from natural
  numbers to finite sets of natural numbers and a particular mapping
  \<open>set_to_nat\<close> from finite sets of natural numbers to natural
  numbers.  See \<^cite>\<open>"Rogers"\<close> and \<^cite>\<open>"Soare"\<close> for more information.
\<close>

definition
  c_in :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "c_in = (\<lambda> x u. (u div (2 ^ x)) mod 2)"

lemma c_in_is_pr: "c_in \<in> PrimRec2"
proof -
  from mod_is_pr power_is_pr div_is_pr have "(\<lambda> x u. (u div (2 ^ x)) mod 2) \<in> PrimRec2" by prec
  with c_in_def show ?thesis by auto
qed

definition
  nat_to_set :: "nat \<Rightarrow> nat set" where
  "nat_to_set u \<equiv> {x. 2^x \<le> u \<and> c_in x u = 1}"

lemma c_in_upper_bound: "c_in x u = 1 \<Longrightarrow> 2 ^ x \<le> u"
proof -
  assume A: "c_in x u = 1"
  then have S1: "(u div (2^x)) mod 2 = 1" by (unfold c_in_def)
  then have S2: "u div (2^x) > 0" by arith
  show ?thesis
  proof (rule ccontr)
    assume "\<not> 2 ^ x \<le> u"
    then have "u < 2^x" by auto
    then have "u div (2^x) = 0" by (rule div_less)
    with S2 show False by auto
  qed
qed

lemma nat_to_set_upper_bound: "x \<in> nat_to_set u \<Longrightarrow> 2 ^ x \<le> u" by (simp add: nat_to_set_def)

lemma x_lt_2_x: "x < 2 ^ x"
  by (rule less_exp)

lemma nat_to_set_upper_bound1: "x \<in> nat_to_set u \<Longrightarrow> x < u"
proof -
  assume "x \<in> nat_to_set u"
  then have S1: "2 ^ x \<le> u" by (simp add: nat_to_set_def)
  have S2: "x < 2 ^ x" by (rule x_lt_2_x)
  from S2 S1 show ?thesis
    by (rule less_le_trans)
qed

lemma nat_to_set_upper_bound2: "nat_to_set u \<subseteq> {i. i < u}"
proof -
  from nat_to_set_upper_bound1 show ?thesis by blast
qed

lemma nat_to_set_is_finite: "finite (nat_to_set u)"
proof -
  have S1: "finite {i. i<u}"
  proof -
    let ?B = "{i. i<u}"
    let ?f = "(\<lambda> (x::nat). x)"
    have "?B = ?f ` ?B" by auto
    then show "finite ?B" by (rule nat_seg_image_imp_finite)
  qed
  have S2: "nat_to_set u \<subseteq> {i. i<u}" by (rule nat_to_set_upper_bound2)
  from S2 S1 show ?thesis by (rule finite_subset)
qed

lemma x_in_u_eq: "(x \<in> nat_to_set u) = (c_in x u = 1)" by (auto simp add: nat_to_set_def c_in_upper_bound)

definition
  log2 :: "nat \<Rightarrow> nat" where
  "log2 = (\<lambda> x. Least(%z. x < 2^(z+1)))"

lemma log2_at_0: "log2 0 = 0"
proof -
  let ?v = "log2 0"
  have S1: "0 \<le> ?v" by auto
  have S2: "?v = Least(%(z::nat). (0::nat)<2^(z+1))" by (simp add: log2_def)
  have S3: "(0::nat)<2^(0+1)" by auto
  from S3 have S4: "Least(%(z::nat). (0::nat)<2^(z+1)) \<le> 0" by (rule Least_le)
  from S2 S4 have S5: "?v \<le> 0" by auto
  from S1 S5 have S6: "?v = 0" by auto
  thus ?thesis by auto
qed

lemma log2_at_1: "log2 1 = 0"
proof -
  let ?v = "log2 1"
  have S1: "0 \<le> ?v" by auto
  have S2: "?v = Least(%(z::nat). (1::nat)<2^(z+1))" by (simp add: log2_def)
  have S3: "(1::nat)<2^(0+1)" by auto
  from S3 have S4: "Least(%(z::nat). (1::nat)<2^(z+1)) \<le> 0" by (rule Least_le)
  from S2 S4 have S5: "?v \<le> 0" by auto
  from S1 S5 have S6: "?v = 0" by auto
  thus ?thesis by auto
qed

lemma log2_le: "x > 0 \<Longrightarrow> 2 ^ log2 x \<le> x"
proof -
  assume A: "x > 0"
  show ?thesis
  proof (cases)
    assume A1: "log2 x = 0"
    with A show ?thesis by auto
  next
    assume A1: "log2 x \<noteq> 0"
    then have S1: "log2 x > 0" by auto
    define y where "y = log2 x - 1"
    from S1 y_def have S2: "log2 x = y + 1" by auto
    then have S3: "y < log2 x" by auto
    have "2^(y+1) \<le> x"
    proof (rule ccontr)
      assume A2: "\<not> 2^(y+1) \<le> x" then have "x < 2^(y+1)" by auto
      then have "log2 x \<le> y" by (simp add: log2_def Least_le)
      with S3 show False by auto
   qed
   with S2 show ?thesis by auto
  qed
qed

lemma log2_gt: "x < 2 ^ (log2 x + 1)"
proof -
  have "x < 2^x" by (rule x_lt_2_x)
  then have S1: "x < 2^(x+1)"
    by (simp add: numeral_2_eq_2)
  define y where "y = x"
  from S1 y_def have S2: "x < 2^(y+1)" by auto
  let ?P = "\<lambda> z. x < 2^(z+1)"
  from S2 have S3: "?P y" by auto
  then have S4: "?P (Least ?P)" by (rule LeastI)
  from log2_def have S5: "log2 x = Least ?P" by (unfold log2_def, auto)
  from S4 S5 show ?thesis by auto
qed

lemma x_div_x: "x > 0 \<Longrightarrow> (x::nat) div x = 1" by auto
lemma div_ge: "(k::nat) \<le> m div n \<Longrightarrow> n*k \<le> m"
proof -
  assume A: "k \<le> m div n"
  have S1: "n * (m div n) + m mod n = m" by (rule mult_div_mod_eq)
  have S2: "0 \<le> m mod n" by auto
  from S1 S2 have S3: "n * (m div n) \<le> m" by arith
  from A have S4: "n * k \<le>  n * (m div n)" by auto
  from S4 S3 show ?thesis by (rule order_trans)
qed
lemma div_lt: "m < n*k \<Longrightarrow> m div n < (k::nat)"
proof -
  assume A: "m < n*k"
  show ?thesis
  proof (rule ccontr)
    assume "\<not> m div n < k"
    then have S1: "k \<le> m div n" by auto
    then have S2: "n*k \<le> m" by (rule div_ge)
    with A show False by auto
  qed
qed

lemma log2_lm1: "u > 0 \<Longrightarrow> u div 2 ^ (log2 u) = 1"
proof -
  assume A: "u > 0"
  then have S1: "2^(log2 u) \<le> u" by (rule log2_le)
  have S2: "u < 2^(log2 u+1)" by (rule log2_gt)
  then have S3: "u < (2^log2 u)*2" by simp
  have "(2::nat) > 0" by simp
  then have "(2::nat)^log2 u > 0" by simp
  then have S4: "(2::nat)^log2 u div 2^log2 u = 1" by auto
  from S1 have S5: "(2::nat)^log2 u div 2^log2 u  \<le> u div 2^log2 u" by (rule div_le_mono)
  with S4 have S6: "1 \<le> u div 2^log2 u" by auto
  from S3 have S7: "u div 2^log2 u < 2" by (rule div_lt)
  from S6 S7 show ?thesis by auto
qed

lemma log2_lm2: "u > 0 \<Longrightarrow> c_in (log2 u) u = 1"
proof -
  assume A: "u > 0"
  then have S1: "u div 2 ^ (log2 u) = 1" by (rule log2_lm1)
  have "c_in (log2 u) u = (u div 2 ^ (log2 u)) mod 2" by (simp add: c_in_def)
  also from S1 have "\<dots> = 1 mod 2" by simp
  also have "\<dots> = 1" by auto
  finally show ?thesis by auto
qed

lemma log2_lm3: "log2 u < x \<Longrightarrow> c_in x u = 0"
proof -
  assume A: "log2 u < x"
  then have S1: "(log2 u)+1 \<le> x" by auto
  have S2: "1 \<le> (2::nat)" by auto
  from S1 S2 have S3: "(2::nat)^ ((log2 u)+1) \<le> 2^x" by (rule power_increasing)
  have S4: "u < (2::nat)^ ((log2 u)+1)" by (rule log2_gt)
  from S3 S4 have S5: "u < 2^x" by auto
  then have S6: "u div 2^x = 0" by (rule div_less)
  have "c_in x u = (u div 2^x) mod 2" by (simp add: c_in_def)
  also from S6 have "\<dots> = 0 mod 2" by simp
  also have "\<dots> = 0" by auto
  finally have ?thesis by auto
  thus ?thesis by auto
qed

lemma log2_lm4: "c_in x u = 1 \<Longrightarrow> x \<le> log2 u"
proof -
  assume A: "c_in x u = 1"
  show ?thesis
  proof (rule ccontr)
    assume "\<not> x \<le> log2 u"
    then have S1: "log2 u < x" by auto
    then have S2: "c_in x u = 0" by (rule log2_lm3)
    with A show False by auto
  qed
qed

lemma nat_to_set_lub: "x \<in> nat_to_set u \<Longrightarrow> x \<le> log2 u"
proof -
  assume "x \<in> nat_to_set u"
  then have S1: "c_in x u = 1" by (simp add: x_in_u_eq)
  then show ?thesis by (rule log2_lm4)
qed

lemma log2_lm5: "u > 0 \<Longrightarrow> log2 u \<in> nat_to_set u"
proof -
  assume A: "u > 0"
  then have "c_in (log2 u) u = 1" by (rule log2_lm2)
  then show ?thesis by (simp add: x_in_u_eq)
qed

lemma pos_imp_ne: "u > 0 \<Longrightarrow> nat_to_set u \<noteq> {}"
proof -
  assume "u > 0"
  then have "log2 u \<in> nat_to_set u" by (rule log2_lm5)
  thus ?thesis by auto
qed

lemma empty_is_zero: "nat_to_set u = {} \<Longrightarrow> u = 0"
proof (rule ccontr)
  assume A1: "nat_to_set u = {}"
  assume A2: "u \<noteq> 0" then have S1: "u > 0" by auto
  from S1 have "nat_to_set u \<noteq> {}" by (rule pos_imp_ne)
  with A1 show False by auto
qed

lemma log2_is_max: "u > 0 \<Longrightarrow> log2 u = Max (nat_to_set u)"
proof -
  assume A: "u > 0"
  then have S1: "log2 u \<in> nat_to_set u" by (rule log2_lm5)
  define max where "max = Max (nat_to_set u)"
  from A have ne: "nat_to_set u \<noteq> {}" by (rule pos_imp_ne)
  have finite: "finite (nat_to_set u)" by (rule nat_to_set_is_finite)
  from max_def finite ne have max_in: "max \<in> nat_to_set u" by simp
  from max_in have S2: "c_in max u = 1" by (simp add: x_in_u_eq)
  then have S3: "max \<le> log2 u" by (rule log2_lm4)
  from finite ne S1 max_def have S4: "log2 u \<le> max" by simp
  from S3 S4 max_def show ?thesis by auto
qed

lemma zero_is_empty: "nat_to_set 0 = {}"
proof -
  have S1: "{i. i<(0::nat)} = {}" by blast
  have S2: "nat_to_set 0 \<subseteq> {i. i<0}" by (rule nat_to_set_upper_bound2)
  from S1 S2 show ?thesis by auto
qed

lemma ne_imp_pos: "nat_to_set u \<noteq> {} \<Longrightarrow> u > 0"
proof (rule ccontr)
  assume A1: "nat_to_set u \<noteq> {}"
  assume "\<not> 0 < u" then have "u = 0" by auto
  then have "nat_to_set u = {}" by (simp add: zero_is_empty)
  with A1 show False by auto
qed

lemma div_mod_lm: "y < x \<Longrightarrow> ((u + (2::nat) ^ x) div (2::nat)^y) mod 2 = (u div (2::nat)^y) mod 2"
proof -
  assume y_lt_x: "y < x"
  let ?n = "(2::nat)^y"
  have n_pos: "0 < ?n" by auto
  let ?s = "x-y"
  from y_lt_x have s_pos: "0 < ?s" by auto
  from y_lt_x have S3: "x = y + ?s" by auto
  from S3 have "(2::nat)^x = (2::nat)^(y + ?s)" by auto
  moreover have "(2::nat)^(y +?s) = (2::nat)^y * 2^ ?s" by (rule power_add)
  ultimately have "(2::nat)^x = 2^y * 2^?s" by auto
  then have S4: "u + (2::nat)^x = u + (2::nat)^y * 2^?s" by auto
  from n_pos have S5: "(u + (2::nat)^y * 2^?s) div 2^y = 2^?s + (u div 2^y)" by simp
  from S4 S5 have S6: "(u + (2::nat)^x) div 2^y = 2^?s + (u div 2^y)" by auto
  from s_pos have S8: "?s = (?s - 1) + 1" by auto
  have "(2::nat) ^ ((?s - (1::nat)) + (1::nat)) = (2::nat) ^ (?s - (1::nat)) * 2^1" by (rule power_add)
  with S8 have S9: "(2::nat) ^ ?s = (2::nat) ^ (?s - (1::nat)) * 2" by auto
  then have S10: "2^?s + (u div 2^y) = (u div 2^y) + (2::nat) ^ (?s - (1::nat)) * 2" by auto
  have S11: "((u div 2^y) + (2::nat) ^ (?s - (1::nat)) * 2) mod 2 = (u div 2^y) mod 2" by (rule mod_mult_self1)
  from S6 S10 S11 show ?thesis by auto
qed

lemma add_power: "u < 2^x \<Longrightarrow> nat_to_set (u + 2^x) = nat_to_set u \<union> {x}"
proof -
  assume A: "u < 2^x"
  have log2_is_x: "log2 (u+2^x) = x"
  proof (unfold log2_def, rule Least_equality)
    from A show "u+2^x < 2^(x+1)" by auto
  next
    fix z
    assume A1: "u + 2^x < 2^(z+1)"
    show "x \<le> z"
    proof (rule ccontr)
      assume "\<not> x \<le> z"
      then have "z < x" by auto
      then have L1: "z+1 \<le> x" by auto
      have L2: "1 \<le> (2::nat)" by auto
      from L1 L2 have L3: "(2::nat)^(z+1) \<le> (2::nat)^x" by (rule power_increasing)
      with A1 show False by auto
    qed
  qed
  show ?thesis
  proof (rule subset_antisym)
    show "nat_to_set (u + 2 ^ x) \<subseteq> nat_to_set u \<union> {x}"
    proof fix y
      assume A1: "y \<in> nat_to_set (u + 2 ^ x)"
      show "y \<in> nat_to_set u \<union> {x}"
      proof
        assume "y \<notin> {x}" then have S1: "y \<noteq> x" by auto
        from A1 have "y \<le> log2 (u + 2 ^ x)" by (rule nat_to_set_lub)
        with log2_is_x have "y \<le> x" by auto
        with S1 have y_lt_x: "y < x" by auto
        from A1 have "c_in y (u + 2 ^ x) = 1" by (simp add: x_in_u_eq)
        then have S2: "((u + 2 ^ x) div 2^y) mod 2 = 1" by (unfold c_in_def)
        from y_lt_x have "((u + (2::nat) ^ x) div (2::nat)^y) mod 2 = (u div (2::nat)^y) mod 2" by (rule div_mod_lm)
        with S2 have "(u div 2^y) mod 2 = 1" by auto
        then have "c_in y u = 1" by (simp add: c_in_def)
        then show "y \<in> nat_to_set u" by (simp add: x_in_u_eq)
      qed
    qed
  next
  show "nat_to_set u \<union> {x} \<subseteq> nat_to_set (u + 2 ^ x)"
  proof fix y
    assume A1: "y \<in> nat_to_set u \<union> {x}"
    show "y \<in> nat_to_set (u + 2 ^ x)"
    proof cases
      assume "y \<in> {x}"
      then have "y=x" by auto
      then have "y = log2 (u + 2 ^ x)" by (simp add: log2_is_x)
      then show ?thesis by (simp add: log2_lm5)
    next
      assume y_notin: "y \<notin> {x}"
      then have y_ne_x: "y \<noteq> x" by auto
      from A1 y_notin have y_in: "y \<in> nat_to_set u" by auto
      have y_lt_x: "y < x"
      proof (rule ccontr)
        assume "\<not> y < x"
        with y_ne_x have y_gt_x: "x < y" by auto
        have "1 < (2::nat)" by auto
        from y_gt_x this have L1: "(2::nat)^x < 2^y" by (rule power_strict_increasing)
        from y_in have L2: "2^y \<le> u" by (rule nat_to_set_upper_bound)
        from L1 L2 have "(2::nat)^x < u" by arith
        with A show False by auto
      qed
      from y_in have "c_in y u = 1" by (simp add: x_in_u_eq)
      then have S2: "(u div 2^y) mod 2 = 1" by (unfold c_in_def)
      from y_lt_x have "((u + (2::nat) ^ x) div (2::nat)^y) mod 2 = (u div (2::nat)^y) mod 2" by (rule div_mod_lm)
      with S2 have "((u + (2::nat) ^ x)div 2^y) mod 2 = 1" by auto
      then have "c_in y (u + (2::nat) ^ x) = 1" by (simp add: c_in_def)
      then show "y \<in> nat_to_set (u + (2::nat) ^ x)" by (simp add: x_in_u_eq)
    qed
  qed
  qed
qed

theorem nat_to_set_inj: "nat_to_set u = nat_to_set v \<Longrightarrow> u = v"
proof -
  assume A: "nat_to_set u = nat_to_set v"
  let ?P = "\<lambda> (n::nat). (\<forall> (D::nat set). finite D \<and> card D \<le> n \<longrightarrow> (\<forall> u v. nat_to_set u = D \<and> nat_to_set v = D \<longrightarrow> u = v))"
  have P_at_0: "?P 0"
  proof fix D show "finite D \<and> card D \<le> 0 \<longrightarrow> (\<forall>u v. nat_to_set u = D \<and> nat_to_set v = D \<longrightarrow> u = v)"
    proof (rule impI)
      assume A1: "finite D \<and> card D \<le> 0"
      from A1 have S1: "finite D" by auto
      from A1 have S2: "card D = 0" by auto
      from S1 S2 have S3: "D = {}" by auto
      show "(\<forall>u v. nat_to_set u = D \<and> nat_to_set v = D \<longrightarrow> u = v)"
      proof (rule allI, rule allI) fix u v show "nat_to_set u = D \<and> nat_to_set v = D \<longrightarrow> u = v"
        proof
          assume A2: " nat_to_set u = D \<and> nat_to_set v = D"
          from A2 have L1: "nat_to_set u = D" by auto
          from A2 have L2: "nat_to_set v = D" by auto
          from L1 S3 have "nat_to_set u = {}" by auto
          then have u_z: "u = 0" by (rule empty_is_zero)
          from L2 S3 have "nat_to_set v = {}" by auto
          then have v_z: "v = 0" by (rule empty_is_zero)
          from u_z v_z show "u=v" by auto
        qed
      qed
    qed
  qed
  have P_at_Suc: "\<And> n. ?P n \<Longrightarrow> ?P (Suc n)"
  proof - fix n
    assume A_n: "?P n"
    show "?P (Suc n)"
    proof fix D show "finite D \<and> card D \<le> Suc n \<longrightarrow> (\<forall>u v. nat_to_set u = D \<and> nat_to_set v = D \<longrightarrow> u = v)"
    proof (rule impI)
      assume A1: "finite D \<and> card D \<le> Suc n"
      from A1 have S1: "finite D" by auto
      from A1 have S2: "card D \<le> Suc n" by auto
      show "(\<forall>u v. nat_to_set u = D \<and> nat_to_set v = D \<longrightarrow> u = v)"
      proof (rule allI, rule allI, rule impI)
        fix u v
        assume A2: " nat_to_set u = D \<and> nat_to_set v = D"
        from A2 have d_u_d: "nat_to_set u = D" by auto
        from A2 have d_v_d: "nat_to_set v = D" by auto
        show "u = v"
        proof (cases)
          assume A3: "D = {}"
          from A3 d_u_d have "nat_to_set u = {}" by auto
          then have u_z: "u = 0" by (rule empty_is_zero)
          from A3 d_v_d have "nat_to_set v = {}" by auto
          then have v_z: "v = 0" by (rule empty_is_zero)
          from u_z v_z show "u = v" by auto
        next
          assume A3: "D \<noteq> {}"
          from A3 d_u_d have "nat_to_set u \<noteq> {}" by auto
          then have u_pos: "u > 0" by (rule ne_imp_pos)
          from A3 d_v_d have "nat_to_set v \<noteq> {}" by auto
          then have v_pos: "v > 0" by (rule ne_imp_pos)
          define m where "m = Max D"
          from S1 m_def A3 have m_in: "m \<in> D" by auto
          from d_u_d m_def have m_u: "m = Max (nat_to_set u)" by auto
          from d_v_d m_def have m_v: "m = Max (nat_to_set v)" by auto
          from u_pos m_u log2_is_max have m_log_u: "m = log2 u" by auto
          from v_pos m_v log2_is_max have m_log_v: "m = log2 v" by auto
          define D1 where "D1 = D - {m}"
          define u1 where "u1 = u - 2^m"
          define v1 where "v1 = v - 2^m"
          have card_D1: "card D1 \<le> n"
          proof -
            from D1_def S1 m_in have "card D1 = (card D) - 1" by (simp add: card_Diff_singleton)
            with S2 show ?thesis by auto
          qed
          have u_u1: "u = u1 + 2^m"
          proof -
            from u_pos have L1: "2 ^ log2 u \<le> u" by (rule log2_le)
            with m_log_u have L2: "2 ^ m \<le> u" by auto
            with u1_def show ?thesis by auto
          qed
          have u1_d1: "nat_to_set u1 = D1"
          proof -
            from m_log_u log2_gt have "u < 2^(m+1)" by auto
            with u_u1 have u1_lt_2_m: "u1 < 2^m" by auto
            with u_u1 have L1: "nat_to_set u = nat_to_set u1 \<union> {m}" by (simp add: add_power)
            have m_notin: "m \<notin> nat_to_set u1"
            proof (rule ccontr)
              assume "\<not> m \<notin> nat_to_set u1" then have "m \<in> nat_to_set u1" by auto
              then have "2^m \<le> u1" by (rule nat_to_set_upper_bound)
              with u1_lt_2_m show False by auto
            qed
            from L1 m_notin have "nat_to_set u1 = nat_to_set u - {m}" by auto
            with d_u_d have "nat_to_set u1 = D - {m}" by auto
            with D1_def show ?thesis by auto
          qed
          have v_v1: "v = v1 + 2^m"
          proof -
            from v_pos have L1: "2 ^ log2 v \<le> v" by (rule log2_le)
            with m_log_v have L2: "2 ^ m \<le> v" by auto
            with v1_def show ?thesis by auto
          qed
          have v1_d1: "nat_to_set v1 = D1"
          proof -
            from m_log_v log2_gt have "v < 2^(m+1)" by auto
            with v_v1 have v1_lt_2_m: "v1 < 2^m" by auto
            with v_v1 have L1: "nat_to_set v = nat_to_set v1 \<union> {m}" by (simp add: add_power)
            have m_notin: "m \<notin> nat_to_set v1"
            proof (rule ccontr)
              assume "\<not> m \<notin> nat_to_set v1" then have "m \<in> nat_to_set v1" by auto
              then have "2^m \<le> v1" by (rule nat_to_set_upper_bound)
              with v1_lt_2_m show False by auto
            qed
            from L1 m_notin have "nat_to_set v1 = nat_to_set v - {m}" by auto
            with d_v_d have "nat_to_set v1 = D - {m}" by auto
            with D1_def show ?thesis by auto
          qed
          from S1 D1_def have P1: "finite D1" by auto
          with card_D1 have P2: "finite D1 \<and> card D1 \<le> n" by auto
          from A_n P2 have "(\<forall>u v. nat_to_set u = D1 \<and> nat_to_set v = D1 \<longrightarrow> u = v)" by auto
          with u1_d1 v1_d1 have "u1 = v1" by auto
          with u_u1 v_v1 show "u = v" by auto
        qed
      qed
    qed
  qed
qed
  from P_at_0 P_at_Suc have main: "\<And> n. ?P n" by (rule nat.induct)
  define D where "D = nat_to_set u"
  from D_def A have P1: "nat_to_set u = D" by auto
  from D_def A have P2: "nat_to_set v = D" by auto
  from D_def nat_to_set_is_finite have d_finite: "finite D" by auto
  define n where "n = card D"
  from n_def d_finite have card_le: "card D \<le> n" by auto
  from d_finite card_le have P3: "finite D \<and> card D \<le> n" by auto
  with main have P4: "\<forall>u v. nat_to_set u = D \<and> nat_to_set v = D \<longrightarrow> u = v" by auto
  with P1 P2 show "u = v" by auto
qed

definition
  set_to_nat :: "nat set => nat" where
  "set_to_nat = (\<lambda> D. sum (\<lambda> x. 2 ^ x) D)"

lemma two_power_sum: "sum (\<lambda> x. (2::nat) ^ x) {i. i< Suc m} = (2 ^ Suc m) - 1"
proof (induct m)
  show "sum (\<lambda> x. (2::nat) ^ x) {i. i< Suc 0} = (2 ^ Suc 0) - 1" by auto
next
  fix n
  assume A: "sum (\<lambda> x. (2::nat) ^ x) {i. i< Suc n} = (2 ^ Suc n) - 1"
  show "sum (\<lambda> x. (2::nat) ^ x) {i. i< Suc (Suc n)} = (2 ^ Suc (Suc n)) - 1"
  proof -
    let ?f = "\<lambda> x. (2::nat) ^ x"
    have S1: "{i. i< Suc (Suc n)} = {i. i \<le> Suc n}" by auto
    have S2: "{i. i \<le> Suc n} = {i. i < Suc n} \<union> { Suc n}" by auto
    from S1 S2 have S3: "{i. i< Suc (Suc n)} = {i. i < Suc n} \<union> { Suc n}" by auto
    have S4: "{i. i < Suc n} = (\<lambda> x. x) ` {i. i < Suc n}" by auto
    then have S5: "finite {i. i < Suc n}" by (rule nat_seg_image_imp_finite)
    have S6: "Suc n \<notin> {i. i < Suc n}" by auto
    from S5 S6 sum.insert have S7: "sum ?f ({i. i< Suc n} \<union> {Suc n}) = 2 ^ Suc n + sum ?f {i. i< Suc n}" by auto
    from S3 have "sum ?f {i. i< Suc (Suc n)} = sum ?f ({i. i< Suc n} \<union> {Suc n})" by auto
    also from S7 have "\<dots> = 2 ^ Suc n + sum ?f {i. i< Suc n}" by auto
    also from A have "\<dots> = 2 ^ Suc n + (((2::nat) ^ Suc n)-(1::nat))" by auto
    also have "\<dots> = (2 ^ Suc (Suc n)) - 1" by auto
    finally show ?thesis by auto
  qed
qed

lemma finite_interval: "finite {i. (i::nat)<m}"
proof -
  have "{i. i < m} = (\<lambda> x. x) ` {i. i < m}" by auto
  then show ?thesis by (rule nat_seg_image_imp_finite)
qed

lemma set_to_nat_at_empty: "set_to_nat {} = 0" by (unfold set_to_nat_def, rule sum.empty)

lemma set_to_nat_of_interval: "set_to_nat {i. (i::nat)<m} = 2 ^ m - 1"
proof (induct m)
  show "set_to_nat {i. i < 0} = 2 ^ 0 - 1"
  proof -
    have S1: "{i. (i::nat) < 0} = {}" by auto
    with set_to_nat_at_empty have "set_to_nat {i. i<0} = 0" by auto
    thus ?thesis by auto
  qed
next
  fix n show "set_to_nat {i. i < Suc n} = 2 ^ Suc n - 1" by (unfold set_to_nat_def, rule two_power_sum)
qed

lemma set_to_nat_mono: "\<lbrakk> finite B; A \<subseteq> B\<rbrakk> \<Longrightarrow> set_to_nat A \<le> set_to_nat B"
proof -
  assume b_finite: "finite B"
  assume a_le_b: "A \<subseteq> B"
  let ?f = "\<lambda> (x::nat). (2::nat) ^ x"
  have S1: "set_to_nat A = sum ?f A" by (simp add: set_to_nat_def)
  have S2: "set_to_nat B = sum ?f B" by (simp add: set_to_nat_def)
  have S3: "\<And> x. x  \<in> B - A \<Longrightarrow> 0 \<le> ?f x" by auto
  from b_finite a_le_b S3 have "sum ?f A \<le> sum ?f B" by (rule sum_mono2)
  with S1 S2 show ?thesis by auto
qed

theorem nat_to_set_srj: "finite (D::nat set) \<Longrightarrow> nat_to_set (set_to_nat D) = D"
proof -
  assume A: "finite D"
  let ?P = "\<lambda> (n::nat). (\<forall> (D::nat set). finite D \<and> card D = n \<longrightarrow> nat_to_set (set_to_nat D) = D)"
  have P_at_0: "?P 0"
  proof (rule allI)
    fix D
    show "finite D \<and> card D = 0 \<longrightarrow> nat_to_set (set_to_nat D) = D"
    proof
      assume A1: "finite D \<and> card D = 0"
      from A1 have S1: "finite D" by auto
      from A1 have S2: "card D = 0" by auto
      from S1 S2 have S3: "D = {}" by auto
      with set_to_nat_def have "set_to_nat D = sum (\<lambda> x. 2 ^ x) D" by simp
      with S3 sum.empty have "set_to_nat D = 0" by auto
      with zero_is_empty S3 show "nat_to_set (set_to_nat D) = D" by auto
    qed
  qed
  have P_at_Suc: "\<And> n. ?P n \<Longrightarrow> ?P (Suc n)"
  proof - fix n
    assume A_n: "?P n"
    show "?P (Suc n)"
    proof
      fix D show "finite D \<and> card D = Suc n \<longrightarrow> nat_to_set (set_to_nat D) = D"
      proof
        assume A1: "finite D \<and> card D = Suc n"
        from A1 have S1: "finite D" by auto
        from A1 have S2: "card D = Suc n" by auto
        define m where "m = Max D"
        from S2 have D_ne: "D \<noteq> {}" by auto
        with S1 m_def have m_in: "m \<in> D" by auto
        define D1 where "D1 = D - {m}"
        from S1 D1_def have d1_finite: "finite D1" by auto
        from D1_def m_in S1 have "card D1 = card D - 1" by (simp add: card_Diff_singleton)
        with S2 have card_d1: "card D1 = n" by auto
        from d1_finite card_d1 have "finite D1 \<and> card D1 = n" by auto
        with A_n have S3: "nat_to_set (set_to_nat D1) = D1" by auto
        define u where "u = set_to_nat D"
        define u1 where "u1 = set_to_nat D1"
        from S1 m_in have "sum (\<lambda> (x::nat). (2::nat) ^ x) D = 2 ^ m + sum (\<lambda> x. 2 ^ x) (D - {m})"
          by (rule sum.remove)
        with set_to_nat_def have "set_to_nat D = 2 ^ m + set_to_nat (D - {m})" by auto
        with u_def u1_def D1_def have u_u1: "u = u1 + 2 ^ m" by auto
        from S3 u1_def have d1_u1: "nat_to_set u1 = D1" by auto
        have u1_lt: "u1 < 2 ^ m"
        proof -
          have L1: "D1 \<subseteq> {i. i<m}"
          proof fix x
            assume A1: "x \<in> D1"
            show "x \<in> {i. i<m}"
            proof
              from A1 D1_def have L1_1: "x \<in> D" by auto
              from S1 D_ne L1_1 m_def have L1_2: "x \<le> m" by auto
              with A1 L1_1 D1_def have "x \<noteq> m" by auto
              with L1_2 show "x < m" by auto
            qed
          qed
          have L2: "finite {i. i<m}" by (rule finite_interval)
          from L2 L1 have "set_to_nat D1 \<le> set_to_nat {i. i<m}" by (rule set_to_nat_mono)
          with u1_def have "u1 \<le> set_to_nat {i. i<m}" by auto
          with set_to_nat_of_interval have L3: "u1 \<le> 2 ^ m - 1" by auto
          have "0 < (2::nat) ^ m" by auto
          then have "(2::nat) ^ m - 1 < (2::nat) ^ m" by auto
          with L3 show ?thesis by arith
        qed
        from u_def have "nat_to_set (set_to_nat D) = nat_to_set u" by auto
        also from u_u1 have "\<dots> = nat_to_set (u1 + 2 ^ m)" by auto
        also from u1_lt have "\<dots> = nat_to_set u1 \<union> {m}" by (rule add_power)
        also from d1_u1 have "\<dots> = D1 \<union> {m}" by auto
        also from D1_def m_in have "\<dots> = D" by auto
        finally show "nat_to_set (set_to_nat D) = D" by auto
      qed
    qed
  qed
  from P_at_0 P_at_Suc have main: "\<And> n. ?P n" by (rule nat.induct)
  from A main show ?thesis by auto
qed

theorem nat_to_set_srj1: "finite (D::nat set) \<Longrightarrow> \<exists> u. nat_to_set u = D"
proof -
  assume A: "finite D"
  show " \<exists> u. nat_to_set u = D"
  proof
    from A show "nat_to_set (set_to_nat D) = D" by (rule nat_to_set_srj)
  qed
qed

lemma sum_of_pr_is_pr: "g \<in> PrimRec1 \<Longrightarrow> (\<lambda> n. sum g {i. i<n}) \<in> PrimRec1"
proof -
  assume g_is_pr: "g \<in> PrimRec1"
  define f where "f n = sum g {i. i<n}" for n
  from f_def have f_at_0: "f 0 = 0" by auto
  define h where "h a b = g a + b" for a b
  from g_is_pr have h_is_pr: "h \<in> PrimRec2" unfolding h_def by prec
  have f_at_Suc: "\<forall> y. f (Suc y) = h y (f y)"
  proof
    fix y show "f (Suc y) = h y (f y)"
    proof -
      from f_def have S1: "f (Suc y) = sum g {i. i < Suc y}" by auto
      have S2: "{i. i < Suc y} = {i. i < y} \<union> {y}" by auto
      have S3: "finite {i. i < y}" by (rule finite_interval)
      have S4: "y \<notin> {i. i < y}" by auto
      from S1 S2 have "f (Suc y) = sum g ({i. (i::nat) < y} \<union> {y})" by auto
      also from S3 S4 sum.insert have "\<dots> = g y + sum g {i. i<y}" by auto
      also from f_def have "\<dots> = g y + f y" by auto
      also from h_def have "\<dots> = h y (f y)" by auto
      finally show ?thesis by auto
    qed
  qed
  from h_is_pr f_at_0 f_at_Suc have f_is_pr: "f \<in> PrimRec1" by (rule pr_rec1_scheme)
  with f_def [abs_def] show ?thesis by auto
qed

lemma sum_of_pr_is_pr2: "p \<in> PrimRec2 \<Longrightarrow> (\<lambda> n m. sum (\<lambda> x. p x m) {i. i<n}) \<in> PrimRec2"
proof -
  assume p_is_pr: "p \<in> PrimRec2"
  define f where "f n m = sum (\<lambda> x. p x m) {i. i<n}" for n m
  define g :: "nat \<Rightarrow> nat" where "g x = 0" for x
  have g_is_pr: "g \<in> PrimRec1" by (unfold g_def, rule const_is_pr [where ?n=0])
  have f_at_0: "\<forall> x. f 0 x = g x"
  proof
    fix x from f_def g_def show "f 0 x = g x" by auto
  qed
  define h where "h a b c = p a c + b" for a b c
  from p_is_pr have h_is_pr: "h \<in> PrimRec3" unfolding h_def by prec
  have f_at_Suc: "\<forall> x y. f (Suc y) x = h y (f y x) x"
  proof (rule allI, rule allI)
    fix x y show "f (Suc y) x = h y (f y x) x"
    proof -
      from f_def have S1: "f (Suc y) x = sum (\<lambda> z. p z x)  {i. i < Suc y}" by auto
      have S2: "{i. i < Suc y} = {i. i < y} \<union> {y}" by auto
      have S3: "finite {i. i < y}" by (rule finite_interval)
      have S4: "y \<notin> {i. i < y}" by auto
      define g1 where "g1 z = p z x" for z
      from S1 S2 g1_def have "f (Suc y) x = sum g1 ({i. (i::nat) < y} \<union> {y})" by auto
      also from S3 S4 sum.insert have "\<dots> = g1 y + sum g1 {i. i<y}" by auto
      also from f_def g1_def have "\<dots> = g1 y + f y x" by auto
      also from h_def g1_def  have "\<dots> = h y (f y x) x" by auto
      finally show ?thesis by auto
    qed
  qed
  from g_is_pr h_is_pr f_at_0 f_at_Suc have f_is_pr: "f \<in> PrimRec2" by (rule pr_rec_scheme)
  with f_def [abs_def] show ?thesis by auto
qed

lemma sum_is_pr: "g \<in> PrimRec1 \<Longrightarrow> (\<lambda> u. sum g (nat_to_set u)) \<in> PrimRec1"
proof -
  assume g_is_pr: "g \<in> PrimRec1"
  define g1 where "g1 x u = (if (c_in x u = 1) then (g x) else 0)" for x u
  have g1_is_pr: "g1 \<in> PrimRec2"
  proof (unfold g1_def, rule if_eq_is_pr2)
    show "c_in \<in> PrimRec2" by (rule c_in_is_pr)
  next
    show "(\<lambda>x y. 1) \<in> PrimRec2" by (rule const_is_pr_2 [where ?n=1])
  next
    from g_is_pr show "(\<lambda>x y. g x) \<in> PrimRec2" by prec
  next
    show "(\<lambda>x y. 0) \<in> PrimRec2" by (rule const_is_pr_2 [where ?n=0])
  qed
  define f where "f u = sum (\<lambda> x. g1 x u) {i. (i::nat) < u}" for u
  define f1 where "f1 u v = sum (\<lambda> x. g1 x v) {i. (i::nat) < u}"  for u v
  from g1_is_pr have "(\<lambda> (u::nat) v. sum (\<lambda> x. g1 x v) {i. (i::nat) < u}) \<in> PrimRec2"
    by (rule sum_of_pr_is_pr2)
  with f1_def [abs_def] have f1_is_pr: "f1 \<in> PrimRec2" by auto
  from f_def f1_def have f_f1: "f = (\<lambda> u. f1 u u)" by auto
  from f1_is_pr have "(\<lambda> u. f1 u u) \<in> PrimRec1" by prec
  with f_f1 have f_is_pr: "f \<in> PrimRec1" by auto
  have f_is_result: "f = (\<lambda> u. sum g (nat_to_set u))"
  proof
    fix u show "f u = sum g (nat_to_set u)"
    proof -
      define U where "U = {i. i < u}"
      define A where "A = {x \<in> U. c_in x u = 1}"
      define B where "B = {x \<in> U. c_in x u \<noteq> 1}"
      have U_finite: "finite U" by (unfold U_def, rule finite_interval)
      from A_def U_finite have A_finite: "finite A" by auto
      from B_def U_finite have B_finite: "finite B" by auto
      from U_def A_def B_def have U_A_B: "U = A \<union> B" by auto
      from U_def A_def B_def have A_B: "A \<inter> B = {}" by auto
      from B_def g1_def have B_z: "sum (\<lambda> x. g1 x u) B = 0" by auto
      have u_in_U: "nat_to_set u \<subseteq> U" by (unfold U_def, rule nat_to_set_upper_bound2)
      from u_in_U x_in_u_eq A_def have A_u: "A = nat_to_set u" by auto
      from A_u x_in_u_eq g1_def have A_res: "sum (\<lambda> x. g1 x u) A = sum g (nat_to_set u)" by auto
      from f_def have "f u = sum (\<lambda> x. g1 x u) {i. (i::nat) < u}" by auto
      also from U_def have "\<dots> = sum (\<lambda> x. g1 x u) U" by auto
      also from U_A_B have "\<dots> = sum (\<lambda> x. g1 x u) (A \<union> B)" by auto
      also from A_finite B_finite A_B have "\<dots> = sum (\<lambda> x. g1 x u) A + sum (\<lambda> x. g1 x u) B" by (rule sum.union_disjoint)
      also from B_z have "\<dots> = sum (\<lambda> x. g1 x u) A" by auto
      also from A_res have "\<dots> = sum g (nat_to_set u)" by auto
      finally show ?thesis by auto
    qed
  qed
  with f_is_pr show ?thesis by auto
qed

definition
  c_card :: "nat \<Rightarrow> nat" where
  "c_card = (\<lambda> u. card (nat_to_set u))"

theorem c_card_is_pr: "c_card \<in> PrimRec1"
proof -
  define g :: "nat \<Rightarrow> nat" where "g x = 1" for x
  have g_is_pr: "g \<in> PrimRec1" by (unfold g_def, rule const_is_pr)
  have "c_card = (\<lambda> u. sum g (nat_to_set u))"
  proof
    fix u show "c_card u = sum g (nat_to_set u)" by (unfold c_card_def, unfold g_def, rule card_eq_sum)
  qed
  moreover from g_is_pr have "(\<lambda> u. sum g (nat_to_set u)) \<in> PrimRec1" by (rule sum_is_pr)
  ultimately show ?thesis by auto
qed

definition
  c_insert :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "c_insert = (\<lambda> x u. if c_in x u = 1 then u else u + 2^x)"

lemma c_insert_is_pr: "c_insert \<in> PrimRec2"
proof (unfold c_insert_def, rule if_eq_is_pr2)
  show "c_in \<in> PrimRec2" by (rule c_in_is_pr)
next
  show "(\<lambda>x y. 1) \<in> PrimRec2" by (rule const_is_pr_2)
next
  show "(\<lambda>x y. y) \<in> PrimRec2" by (rule pr_id2_2)
next
  from power_is_pr show "(\<lambda>x y. y + 2 ^ x) \<in> PrimRec2" by prec
qed

lemma insert_lemma: "x \<notin> nat_to_set u \<Longrightarrow> set_to_nat (nat_to_set u \<union> {x}) = u + 2 ^ x"
proof -
  assume A: "x \<notin> nat_to_set u"
  define D where "D = nat_to_set u"
  from A D_def have S1: "x \<notin> D" by auto
  have "finite (nat_to_set u)" by (rule nat_to_set_is_finite)
  with D_def have D_finite: "finite D" by auto
  let ?f = "\<lambda> (x::nat). (2::nat)^x"
  from set_to_nat_def have "set_to_nat (D \<union> {x}) = sum ?f (D \<union> {x})" by auto
  also from D_finite S1 have "\<dots> = ?f x + sum ?f D" by simp
  also from set_to_nat_def have "\<dots> = 2 ^ x + set_to_nat D" by auto
  finally have "set_to_nat (D \<union> {x}) = set_to_nat D + 2 ^ x" by auto
  with D_def show ?thesis by auto
qed

lemma c_insert_df: "c_insert = (\<lambda> x u. set_to_nat ((nat_to_set u) \<union> {x}))"
proof (rule ext, rule ext)
  fix x u show "c_insert x u = set_to_nat (nat_to_set u \<union> {x})"
  proof (cases)
    assume A: "x \<in> nat_to_set u"
    then have "nat_to_set u \<union> {x} = nat_to_set u" by auto
    then have S1: "set_to_nat (nat_to_set u \<union> {x}) = u" by auto
    from A have "c_in x u = 1" by (simp add: x_in_u_eq)
    then have "c_insert x u = u" by (unfold c_insert_def, simp)
    with S1 show ?thesis by auto
  next
    assume A: "x \<notin> nat_to_set u"
    then have S1: "c_in x u \<noteq> 1" by (simp add: x_in_u_eq)
    then have S2: "c_insert x u = u + 2 ^ x" by (unfold c_insert_def, simp)
    from A have "set_to_nat (nat_to_set u \<union> {x}) = u + 2 ^ x" by (rule insert_lemma)
    with S2 show ?thesis by auto
  qed
qed

definition
  c_remove :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "c_remove = (\<lambda> x u. if c_in x u = 0 then u else u - 2^x)"

lemma c_remove_is_pr: "c_remove \<in> PrimRec2"
proof (unfold c_remove_def, rule if_eq_is_pr2)
  show "c_in \<in> PrimRec2" by (rule c_in_is_pr)
next
  show "(\<lambda>x y. 0) \<in> PrimRec2" by (rule const_is_pr_2)
next
  show "(\<lambda>x y. y) \<in> PrimRec2" by (rule pr_id2_2)
next
  from power_is_pr show "(\<lambda>x y. y - 2 ^ x) \<in> PrimRec2" by prec
qed

lemma remove_lemma: "x \<in> nat_to_set u \<Longrightarrow> set_to_nat (nat_to_set u - {x}) = u - 2 ^ x"
proof -
  assume A: "x \<in> nat_to_set u"
  define D where "D = nat_to_set u - {x}"
  from A D_def have S1: "x \<notin> D" by auto
  have "finite (nat_to_set u)" by (rule nat_to_set_is_finite)
  with D_def have D_finite: "finite D" by auto
  let ?f = "\<lambda> (x::nat). (2::nat)^x"
  from set_to_nat_def have "set_to_nat (D \<union> {x}) = sum ?f (D \<union> {x})" by auto
  also from D_finite S1 have "\<dots> = ?f x + sum ?f D" by simp
  also from set_to_nat_def have "\<dots> = 2 ^ x + set_to_nat D" by auto
  finally have S2: "set_to_nat (D \<union> {x}) = set_to_nat D + 2 ^ x" by auto
  from A D_def have "D \<union> {x} = nat_to_set u" by auto
  with S2 have S3: "u = set_to_nat D + 2 ^ x" by auto
  from A have S4: "2 ^ x \<le> u" by (rule nat_to_set_upper_bound)
  with S3 D_def show ?thesis by auto
qed

lemma c_remove_df: "c_remove = (\<lambda> x u. set_to_nat ((nat_to_set u) - {x}))"
proof (rule ext, rule ext)
  fix x u show "c_remove x u = set_to_nat (nat_to_set u - {x})"
  proof (cases)
    assume A: "x \<in> nat_to_set u"
    then have S1: "c_in x u = 1" by (simp add: x_in_u_eq)
    then have S2: "c_remove x u = u - 2^x" by (simp add: c_remove_def)
    from A have "set_to_nat (nat_to_set u - {x}) = u - 2 ^ x" by (rule remove_lemma)
    with S2 show ?thesis by auto
  next
    assume A: "x \<notin> nat_to_set u"
    then have S1: "c_in x u \<noteq> 1" by (simp add: x_in_u_eq)
    then have S2: "c_remove x u = u" by (simp add: c_remove_def c_in_def)
    from A have "nat_to_set u - {x} = nat_to_set u" by auto
    with S2 show ?thesis by auto
  qed
qed

definition
  c_union :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "c_union = (\<lambda> u v. set_to_nat (nat_to_set u \<union> nat_to_set v))"

theorem c_union_is_pr: "c_union \<in> PrimRec2"
proof -
  define f where "f y x = set_to_nat ((nat_to_set (c_fst x)) \<union> {z \<in> nat_to_set (c_snd x). z < y})"
    for y x
  have f_is_pr: "f \<in> PrimRec2"
  proof -
    define g where "g = c_fst"
    from c_fst_is_pr g_def have g_is_pr: "g \<in> PrimRec1" by auto
    define h where "h a b c = (if c_in a (c_snd c) = 1 then c_insert a b else b)" for a b c
    from c_in_is_pr c_insert_is_pr have h_is_pr: "h \<in> PrimRec3" unfolding h_def by prec
    have f_at_0: "\<forall> x. f 0 x = g x"
    proof
      fix x show "f 0 x = g x" by (unfold f_def, unfold g_def, simp)
    qed
    have f_at_Suc: "\<forall> x y. f (Suc y) x = h y (f y x) x"
    proof (rule allI, rule allI)
      fix x y show "f (Suc y) x = h y (f y x) x"
      proof (cases)
        assume A: "c_in y (c_snd x) = 1"
        then have S1: "y \<in> (nat_to_set (c_snd x))" by (simp add: x_in_u_eq)
        from A h_def have S2: "h y (f y x) x = c_insert y (f y x)" by auto
        from S1 have S3: "{z \<in> nat_to_set (c_snd x). z < Suc y} = {z \<in> nat_to_set (c_snd x). z < y} \<union> {y}" by auto
        from nat_to_set_is_finite have S4: "finite ((nat_to_set (c_fst x)) \<union> {z \<in> nat_to_set (c_snd x). z < y})" by auto
        with nat_to_set_srj f_def have S5: "nat_to_set (f y x) = (nat_to_set (c_fst x)) \<union> {z \<in> nat_to_set (c_snd x). z < y}" by auto
        from f_def have S6: "f (Suc y) x = set_to_nat ((nat_to_set (c_fst x)) \<union> {z \<in> nat_to_set (c_snd x). z < Suc y})" by simp
        also from S3 have "\<dots> = set_to_nat (((nat_to_set (c_fst x)) \<union> {z \<in> nat_to_set (c_snd x). z < y}) \<union> {y})" by auto
        also from S5 have "\<dots> = set_to_nat (nat_to_set (f y x) \<union> {y})" by auto
        also have "\<dots> = c_insert y (f y x)" by (simp add: c_insert_df)
        finally show ?thesis by (simp add: S2)
      next
        assume A: "\<not> c_in y (c_snd x) = 1"
        then have S1: "y \<notin> (nat_to_set (c_snd x))" by (simp add: x_in_u_eq)
        from A h_def have S2: "h y (f y x) x = f y x" by auto
        have S3: "{z \<in> nat_to_set (c_snd x). z < Suc y} = {z \<in> nat_to_set (c_snd x). z < y}"
        proof -
          have "{z \<in> nat_to_set (c_snd x). z < Suc y} = {z \<in> nat_to_set (c_snd x). z < y} \<union> {z \<in> nat_to_set (c_snd x). z = y}"
            by auto
          with S1 show ?thesis by auto
        qed
        from nat_to_set_is_finite have S4: "finite ((nat_to_set (c_fst x)) \<union> {z \<in> nat_to_set (c_snd x). z < y})" by auto
        with nat_to_set_srj f_def have S5: "nat_to_set (f y x) = (nat_to_set (c_fst x)) \<union> {z \<in> nat_to_set (c_snd x). z < y}" by auto
        from f_def have S6: "f (Suc y) x = set_to_nat ((nat_to_set (c_fst x)) \<union> {z \<in> nat_to_set (c_snd x). z < Suc y})" by simp
        also from S3 have "\<dots> = set_to_nat (((nat_to_set (c_fst x)) \<union> {z \<in> nat_to_set (c_snd x). z < y}))" by auto
        also from S5 have "\<dots> = set_to_nat (nat_to_set (f y x))" by auto
        also have "\<dots> = f y x" by simp
        finally show ?thesis by (simp add: S2)
      qed
    qed
    from g_is_pr h_is_pr f_at_0 f_at_Suc show ?thesis by (rule pr_rec_scheme)
  qed
  define union where "union u v = f v (c_pair u v)" for u v
  from f_is_pr have union_is_pr: "union \<in> PrimRec2" unfolding union_def by prec
  have "\<And> u v. union u v = set_to_nat (nat_to_set u \<union> nat_to_set v)"
  proof -
    fix u v show "union u v = set_to_nat (nat_to_set u \<union> nat_to_set v)"
    proof -
      from nat_to_set_upper_bound1 have "{z \<in> nat_to_set v. z < v} = nat_to_set v" by auto
      with union_def f_def show ?thesis by auto
    qed
  qed
  then have "union = (\<lambda> u v. set_to_nat (nat_to_set u \<union> nat_to_set v))" by (simp add: ext)
  with c_union_def have "c_union = union" by simp
  with union_is_pr show ?thesis by simp
qed

definition
  c_diff :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "c_diff = (\<lambda> u v. set_to_nat (nat_to_set u - nat_to_set v))"

theorem c_diff_is_pr: "c_diff \<in> PrimRec2"
proof -
  define f where "f y x = set_to_nat ((nat_to_set (c_fst x)) - {z \<in> nat_to_set (c_snd x). z < y})"
    for y x
  have f_is_pr: "f \<in> PrimRec2"
  proof -
    define g where "g = c_fst"
    from c_fst_is_pr g_def have g_is_pr: "g \<in> PrimRec1" by auto
    define h where "h a b c = (if c_in a (c_snd c) = 1 then c_remove a b else b)" for a b c
    from c_in_is_pr c_remove_is_pr have h_is_pr: "h \<in> PrimRec3" unfolding h_def by prec
    have f_at_0: "\<forall> x. f 0 x = g x"
    proof
      fix x show "f 0 x = g x" by (unfold f_def, unfold g_def, simp)
    qed
    have f_at_Suc: "\<forall> x y. f (Suc y) x = h y (f y x) x"
    proof (rule allI, rule allI)
      fix x y show "f (Suc y) x = h y (f y x) x"
      proof (cases)
        assume A: "c_in y (c_snd x) = 1"
        then have S1: "y \<in> (nat_to_set (c_snd x))" by (simp add: x_in_u_eq)
        from A h_def have S2: "h y (f y x) x = c_remove y (f y x)" by auto
        have "(nat_to_set (c_fst x)) - ({z \<in> nat_to_set (c_snd x). z < y} \<union> {y}) =
              ((nat_to_set (c_fst x)) - ({z \<in> nat_to_set (c_snd x). z < y}) - {y})" by auto
        then have lm1: "set_to_nat (nat_to_set (c_fst x) - ({z \<in> nat_to_set (c_snd x). z < y} \<union> {y})) =
                        set_to_nat (nat_to_set (c_fst x) - {z \<in> nat_to_set (c_snd x). z < y} - {y})" by auto
        from S1 have S3: "{z \<in> nat_to_set (c_snd x). z < Suc y} = {z \<in> nat_to_set (c_snd x). z < y} \<union> {y}" by auto
        from nat_to_set_is_finite have S4: "finite ((nat_to_set (c_fst x)) - {z \<in> nat_to_set (c_snd x). z < y})" by auto
        with nat_to_set_srj f_def have S5: "nat_to_set (f y x) = (nat_to_set (c_fst x)) - {z \<in> nat_to_set (c_snd x). z < y}" by auto
        from f_def have S6: "f (Suc y) x = set_to_nat ((nat_to_set (c_fst x)) - {z \<in> nat_to_set (c_snd x). z < Suc y})" by simp
        also from S3 have "\<dots> = set_to_nat ((nat_to_set (c_fst x)) - ({z \<in> nat_to_set (c_snd x). z < y} \<union> {y}))" by auto
        also have "\<dots> = set_to_nat (((nat_to_set (c_fst x)) - ({z \<in> nat_to_set (c_snd x). z < y}) - {y}))" by (rule lm1)
        also from S5 have "\<dots> = set_to_nat (nat_to_set (f y x) - {y})" by auto
        also have "\<dots> = c_remove y (f y x)" by (simp add: c_remove_df)
        finally show ?thesis by (simp add: S2)
      next
        assume A: "\<not> c_in y (c_snd x) = 1"
        then have S1: "y \<notin> (nat_to_set (c_snd x))" by (simp add: x_in_u_eq)
        from A h_def have S2: "h y (f y x) x = f y x" by auto
        have S3: "{z \<in> nat_to_set (c_snd x). z < Suc y} = {z \<in> nat_to_set (c_snd x). z < y}"
        proof -
          have "{z \<in> nat_to_set (c_snd x). z < Suc y} = {z \<in> nat_to_set (c_snd x). z < y} \<union> {z \<in> nat_to_set (c_snd x). z = y}"
            by auto
          with S1 show ?thesis by auto
        qed
        from nat_to_set_is_finite have S4: "finite ((nat_to_set (c_fst x)) - {z \<in> nat_to_set (c_snd x). z < y})" by auto
        with nat_to_set_srj f_def have S5: "nat_to_set (f y x) = (nat_to_set (c_fst x)) - {z \<in> nat_to_set (c_snd x). z < y}" by auto
        from f_def have S6: "f (Suc y) x = set_to_nat ((nat_to_set (c_fst x)) - {z \<in> nat_to_set (c_snd x). z < Suc y})" by simp
        also from S3 have "\<dots> = set_to_nat (((nat_to_set (c_fst x)) - {z \<in> nat_to_set (c_snd x). z < y}))" by auto
        also from S5 have "\<dots> = set_to_nat (nat_to_set (f y x))" by auto
        also have "\<dots> = f y x" by simp
        finally show ?thesis by (simp add: S2)
      qed
    qed
    from g_is_pr h_is_pr f_at_0 f_at_Suc show ?thesis by (rule pr_rec_scheme)
  qed
  define diff where "diff u v = f v (c_pair u v)" for u v
  from f_is_pr have diff_is_pr: "diff \<in> PrimRec2" unfolding diff_def by prec
  have "\<And> u v. diff u v = set_to_nat (nat_to_set u - nat_to_set v)"
  proof -
    fix u v show "diff u v = set_to_nat (nat_to_set u - nat_to_set v)"
    proof -
      from nat_to_set_upper_bound1 have "{z \<in> nat_to_set v. z < v} = nat_to_set v" by auto
      with diff_def f_def show ?thesis by auto
    qed
  qed
  then have "diff = (\<lambda> u v. set_to_nat (nat_to_set u - nat_to_set v))" by (simp add: ext)
  with c_diff_def have "c_diff = diff" by simp
  with diff_is_pr show ?thesis by simp
qed

definition
  c_intersect :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "c_intersect = (\<lambda> u v. set_to_nat (nat_to_set u \<inter> nat_to_set v))"

theorem c_intersect_is_pr: "c_intersect \<in> PrimRec2"
proof -
  define f where "f u v = c_diff (c_union u v) (c_union (c_diff u v) (c_diff v u))" for u v
  from c_diff_is_pr c_union_is_pr have f_is_pr: "f \<in> PrimRec2" unfolding f_def by prec
  have "\<And> u v. f u v = c_intersect u v"
  proof -
    fix u v show "f u v = c_intersect u v"
    proof -
      let ?A = "nat_to_set u"
      let ?B = "nat_to_set v"
      have A_fin: "finite ?A" by (rule nat_to_set_is_finite)
      have B_fin: "finite ?B" by (rule nat_to_set_is_finite)
      have S1: "c_union u v = set_to_nat (?A \<union> ?B)" by (simp add: c_union_def)
      have S2: "c_diff u v = set_to_nat (?A - ?B)" by (simp add: c_diff_def)
      have S3: "c_diff v u = set_to_nat (?B - ?A)" by (simp add: c_diff_def)
      from S2 A_fin B_fin have S4: "nat_to_set (c_diff u v) = ?A - ?B" by  (simp add: nat_to_set_srj)
      from S3 A_fin B_fin have S5: "nat_to_set (c_diff v u) = ?B - ?A" by  (simp add: nat_to_set_srj)
      from S4 S5 have S6: "c_union (c_diff u v) (c_diff v u) = set_to_nat ((?A - ?B) \<union> (?B - ?A))" by (simp add: c_union_def)
      from S1 A_fin B_fin have S7: "nat_to_set (c_union u v) = ?A \<union> ?B" by  (simp add: nat_to_set_srj)
      from S6 A_fin B_fin have S8: "nat_to_set (c_union (c_diff u v) (c_diff v u)) = (?A - ?B) \<union> (?B - ?A)" by  (simp add: nat_to_set_srj)
      from S7 S8 have S9: "f u v = set_to_nat ((?A \<union> ?B) - ((?A - ?B) \<union> (?B - ?A)))" by (simp add: c_diff_def f_def)
      have S10: "?A \<inter> ?B = (?A \<union> ?B) - ((?A - ?B) \<union> (?B - ?A))" by auto
      with S9 have S11: "f u v = set_to_nat (?A \<inter> ?B)" by auto
      have "c_intersect u v = set_to_nat (?A \<inter> ?B)" by (simp add: c_intersect_def)
      with S11 show ?thesis by auto
    qed
  qed
  then have "f = c_intersect" by (simp add: ext)
  with f_is_pr show ?thesis by auto
qed

end


subsubsection \<open>State unique equations\<close>

theory State_Unique_Equations imports "../Register_Machine/MultipleStepState"
                                      Equation_Setup "../Diophantine/Register_Machine_Sums"
                                      "../Diophantine/Binary_And"

begin

context rm_eq_fixes
begin

  text \<open>Equations not in the book: \<close>
  definition state_mask :: "bool" where
      "state_mask \<equiv> \<forall>k\<le>m. s k \<preceq> e"

  definition state_bound :: "bool" where
    "state_bound \<equiv> \<forall>k<m. s k < b ^ q"
(* This means s k,q = 0 for all k < m. *)
(* Reminder: s m = b^q \<^bold>— s m,t = 1 at t = q and nowhere else*)

  definition state_unique_equations :: "bool" where
    "state_unique_equations \<equiv> state_mask \<and> state_bound"

end

context register_machine
begin

lemma state_mask_dioph:
  fixes e :: polynomial
  fixes s :: "polynomial list"
  assumes "length s = Suc m"
  defines "DR \<equiv> LARY (\<lambda>ll. rm_eq_fixes.state_mask p (ll!0!0) (nth (ll!1))) [[e], s]"
  shows "is_dioph_rel DR"
proof -
  define mask where "mask \<equiv> (\<lambda>l. (s!l [\<preceq>] e))"
  define DS where "DS \<equiv> [\<forall><Suc m] mask"

  have "eval DS a = eval DR a" for a
  proof -
    have "eval DS a = (\<forall>k\<le>m. peval (s ! k) a \<preceq> peval e a)"
      unfolding DS_def mask_def by (simp add: less_Suc_eq_le defs)

    also have "... = (\<forall>k\<le>m. map (\<lambda>P. peval P a) s ! k \<preceq> peval e a)"
      using nth_map[of _ s "(\<lambda>P. peval P a)"] \<open>length s = Suc m\<close> by auto

    finally show ?thesis
      unfolding DR_def using rm_eq_fixes_def local.register_machine_axioms
                             rm_eq_fixes.state_mask_def by (simp add: defs)
  qed

  moreover have "is_dioph_rel DS"
  proof -
    have "list_all (is_dioph_rel \<circ> mask) [0..<Suc m]"
      unfolding mask_def list_all_def by (auto simp: dioph)
    thus ?thesis unfolding DS_def mask_def by (auto simp: dioph)
  qed

  ultimately show ?thesis
    by (auto simp: is_dioph_rel_def)
qed

lemma state_bound_dioph:
  fixes b q :: polynomial
  fixes s :: "polynomial list"
  assumes "length s = Suc m"
  defines "DR \<equiv> LARY (\<lambda>ll. rm_eq_fixes.state_bound p (ll!0!0) (ll!0!1) (nth (ll!1))) [[b, q], s]"
  shows "is_dioph_rel DR"
proof -
  let ?N = "m"
  define b' q' s' where pushed_def: "b' = push_param b ?N"
                                    "q' = push_param q ?N"
                                    "s' = map (\<lambda>x. push_param x ?N) s"

  define bound where
    "bound \<equiv> \<lambda>l. s'!l [<] (Param l) [\<and>] [Param l = b' ^ q']"

  define DS where "DS \<equiv> [\<exists>m] [\<forall><m] bound"

  have "eval DS a = eval DR a" for a
  proof -

    have s'_unfold: "peval (s' ! k) (push_list a ks) = peval (s ! k) a"
      if "length ks = m" and "k < length ks" for k ks
      unfolding pushed_def
      using push_push_map_i[of ks n k s] that \<open>length s = Suc m\<close> list_eval_def
      by (metis less_SucI nth_map push_push)

    have b'_unfold: "peval b' (push_list a ks) = peval b a"
     and q'_unfold: "peval q' (push_list a ks) = peval q a"
      if "length ks = m" and "k < length ks" for k ks
      unfolding pushed_def
      using push_push_simp that \<open>length s = Suc m\<close> list_eval_def by metis+

    have "eval DS a = (\<exists>ks. m = length ks \<and>
          (\<forall>k<m. peval (s' ! k) (push_list a ks) < push_list a ks k \<and>
                 push_list a ks k = peval b' (push_list a ks) ^ peval q' (push_list a ks)))"
      unfolding DS_def bound_def by (simp add: defs)

    also have "... = (\<exists>ks. m = length ks \<and>
          (\<forall>k<m. peval (s ! k) a < peval b a ^ peval q a \<and>
                 push_list a ks k = peval b a ^ peval q a))"
      using s'_unfold b'_unfold q'_unfold by metis

    also have "... = (\<forall>k<m. peval (s ! k) a < peval b a ^ peval q a)"
      apply auto apply (rule exI[of _ "map (\<lambda>k. peval b a ^ peval q a) [0..<m]"])
      unfolding push_list_def by auto

    also have "... = (\<forall>l<m. map (\<lambda>P. peval P a) s ! l < peval b a ^ peval q a)"
      using nth_map[of _ s "\<lambda>P. peval P a"] \<open>length s = Suc m\<close> by force

    finally show ?thesis unfolding DR_def
      using rm_eq_fixes_def local.register_machine_axioms rm_eq_fixes.state_bound_def
      by (simp add: defs)

  qed

  moreover have "is_dioph_rel DS"
  proof -
    have "list_all (is_dioph_rel \<circ> bound) [0..<Suc m]"
      unfolding bound_def list_all_def by (auto simp:dioph)
    thus ?thesis unfolding DS_def bound_def by (auto simp: dioph)
  qed

  ultimately show ?thesis
    by (auto simp: is_dioph_rel_def)
qed

lemma state_unique_equations_dioph:
  fixes b q e :: polynomial
  fixes s :: "polynomial list"
  assumes "length s = Suc m"
  defines "DR \<equiv> LARY
                (\<lambda>ll. rm_eq_fixes.state_unique_equations p (ll!0!0) (ll!0!1) (ll!0!2) (nth (ll!1)))
                [[b, e, q], s]"
  shows "is_dioph_rel DR"
proof -

  define DS where "DS \<equiv> LARY (\<lambda>ll. rm_eq_fixes.state_mask p (ll!0!0) (nth (ll!1))) [[e], s]
                    [\<and>] LARY (\<lambda>ll. rm_eq_fixes.state_bound p (ll!0!0) (ll!0!1) (nth (ll!1)))
                              [[b, q], s]"

  have "eval DS a = eval DR a" for a
    unfolding DR_def DS_def using rm_eq_fixes.state_unique_equations_def rm_eq_fixes_def
    local.register_machine_axioms
    by (auto simp: defs)

  moreover have "is_dioph_rel DS"
    unfolding DS_def using state_bound_dioph state_mask_dioph assms dioph by auto

  ultimately show ?thesis using is_dioph_rel_def by auto
qed

end

end


theory Dutch_National_Flag_Monad_Definitions
imports
  Main
  "../State_Monad_HL"
  "HOL-Library.Multiset"
begin

section\<open>Description of the DNFP-algortihm\<close>
text\<open>The Dutch national flag problem is the problem of sorting an array into three different regions: A red-interval (0 in this version), A white-interval (1) and A Blue-interval (2)\<close>

text\<open>The algorithm uses 3 variables to keep track of the three ranges:
\begin{itemize}
  \item @{text Low}: the red range is all indexes before @{text low}
  \item @{text I}: the index that is currently being checked, and the white range is between @{text low} up to @{text i}.
  \item @{text High}: the blue range everything from @{text high} and up.
\end{itemize}

More information about the algorithm can be found: \url{https://en.wikipedia.org/wiki/Dutch_national_flag_problem}

These three ranges have been used as invariants for the algorithm, and all definitions should preserve these.
The relation between the variables has also been described as an invariant.

The main proof of the program is to show the array is sorted in the final state. This can be shown given an array only containing the values of {0,1,2}. The array should also initially satisfy the invariants should be sorted after the termination of the dnfp-function.
\<close>

text\<open>The DNFP-algorithm has been split up in multiple definitions (non-recursive) based on the criteria that a definition should be as simple as possible.
  A definition shouldn't contain more than a single conditional statement.
  The simplest definition has been used inside other definitions (see for example, the definition @{text inc_lowbound} that are used inside loop-update-action).
Each of the definitions has been proved individually based on a pre-condition and post-condition.\<close>

text\<open>The pre- and post-conditions are placed in a hierarchy where the conditions from the nested definitions inherit (and strengthen) the conditions from the outer definitions/functions.
    This structure/hierarchy of the pre- a post-conditions makes it possible to use a lot of the already established lemmas of the simple definitions inside the compound definitions.
    To benefit from this, it is essential to first do the proofs of the simple methods before proving the more complicated ones.\<close>

text\<open>A thing to note about the use of the lemmas inside the compound methods is that can't be done if too much rewrite is done - because it makes it impossible for Isabelle to see the relationship between to post-conditions\<close>

text\<open>Some of the pre- and post-conditions take more than one environment as an argument. This is because the post-condition contains some checks about the relation between the variables in the initial and final state (for example, the variable @{text i} is greater in the final state compared to the initial state).
    In this case, it is needed to capture the initial state (as an additional parameter of both the pre- and post-condition) to use it in the post-condition\<close>
section\<open>Proof structure\<close>

text\<open>The proofs are done using the rules defined in the State-Monad-HL. These rules are based on the book
"Verification of Sequential and Concurrent Programs" and are used to capture changes to the environment.\<close>

text\<open>The proof is built around rewriting an initial state into a final state.
  The rewriting is done using the rules that capture the meaning of the program\<close>

text\<open>The proofs have all the same structure of a pre-condition that gets turned into a post-condition using the rewrite-rules.
    The strategy for doing this rewriting is, in most cases, as follows:
\begin{enumerate}
  \item Unfold the definitions in the lemma formula (pre- and post-conditions)
  \item Simp to extract the definition of the method
  \begin{itemize}
    \item Get is first - apply the get-rule.
    \item An all quantifier is first - apply the allI-rule to turn it into an Isabelle Universal Quantifier.
    \item The final state is a conjunction - use the conj-rule-right to prove the goals separately
    \item Put is first and gets followed by something - use the seq-rule to split it up. The seq rule shall contain what can be concluded from the put.
    \item Put followed by nothing (Usually the case after application of a  seq-rule) - use the simp to discharge the goal. If it doesn't prove the goal, use Sledgehammer, or rewrite the seq-rule.
  \end{itemize}
\end{enumerate}

  The strategy above shall just be repeated until all sub-goals have been proven, and the proof is established. It seems very complicated, but it is, in fact, a very mechanical process.
  In some of the compound methods, the already established lemmas can be used, which means a different strategy should be taken with a lot less rewriting.
\<close>

section\<open>Definitions of the monad environment\<close>
type_synonym 'a array = "'a list"

record env =
  high :: "nat"
  low  :: "nat"
  i    :: "nat"
  xs   :: "nat array"

subsection\<open>Monad update functions\<close>
text\<open>Each of the definitions takes an environment and a value of one of the variables. They update the value of the variable and outputs a new environment.\<close>
definition high_Env:: "env \<Rightarrow> nat \<Rightarrow> env" where "high_Env s v = s \<lparr> high := v \<rparr>"
definition low_Env:: "env \<Rightarrow> nat \<Rightarrow> env" where "low_Env s v = s \<lparr> low := v \<rparr>"
definition i_Env:: "env \<Rightarrow> nat \<Rightarrow> env" where "i_Env s v = s \<lparr> i := v \<rparr>"
definition xs_Env:: "env \<Rightarrow> nat array  \<Rightarrow> env" where "xs_Env s v = s \<lparr> xs := v \<rparr>"

subsection\<open>Theorems about how the update functions changes the environment\<close>
theorem put_high_rule: "spec (\<lambda>x. p () (x \<lparr> high := v \<rparr>)) (put high_Env v) p"
  by (simp add: spec_def put_def get_state_def put_state_def high_Env_def)

theorem put_low_rule: "spec (\<lambda>x. p () (x \<lparr> low := v \<rparr>)) (put low_Env v) p"
  by (simp add: spec_def put_def get_state_def put_state_def low_Env_def)

theorem put_i_rule: "spec (\<lambda>x. p () (x \<lparr> i := v \<rparr>)) (put i_Env v) p"
  by (simp add: spec_def put_def get_state_def put_state_def i_Env_def)

theorem put_xs_rule: "spec (\<lambda>x. p () (x \<lparr> xs := v \<rparr>)) (put xs_Env v) p"
  by (simp add: spec_def put_def get_state_def put_state_def xs_Env_def)

section\<open>Definitions of the methods inside DNFP\<close>
text\<open>This section contains the basic definition of the dnfp-algorithm\<close>

definition swap:: "'a array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a array" where
"swap l x y \<equiv> (if x < length l \<and> y < length l then l[x := l!y, y := l!x] else l)"

text\<open>The @{text inc_lowbound} method swaps elements at positions @{text i} and @{text low}.
    It afterwards increases both @{text i} and @{text low}\<close>
definition inc_lowbound where
"inc_lowbound \<equiv> do{
                  (l, s, j) \<leftarrow> get (\<lambda>e. (low e, xs e, i e));
                  put xs_Env (swap s j l);
                  j \<leftarrow> get i;
                  put i_Env (Suc j);
                  l \<leftarrow> get low;
                  put low_Env (Suc l)
                }"

text\<open>The @{text dec_highbound} method first decrements @{text high}.
    Secondly, it swaps elements at the new position @{text high} with the value at position @{text i}\<close>
definition dec_highbound where
"dec_highbound \<equiv> do{
                    h \<leftarrow> get high;
                    put high_Env (h - 1);
                    (s, j, h) \<leftarrow> get (\<lambda>e. (xs e, i e, high e));
                    put xs_Env (swap s j h)
                }"

text\<open>The @{text inc_index} method increases the variable @{text i}.\<close>
definition inc_index where
"inc_index \<equiv> do{
                  j \<leftarrow> get i;
                  put i_Env (Suc j)
                }"

text\<open>The @{text loop_update_action} method performs a check of the value at position @{text i} and performs one of three actions.\<close>
definition loop_update_action where
"loop_update_action \<equiv>
  do{
    (s, j) \<leftarrow> get (\<lambda>e. (xs e, i e));
    (if s!j < 1 then do {
      inc_lowbound
    } else (if s!j > 1 then do
    {
      dec_highbound
    }
   else do {
      inc_index
   }))
  }"

section\<open>Definitions of the invariants\<close>
text\<open>The invariants are taken from \url{https://en.wikipedia.org/wiki/Dutch_national_flag_problem} and more information about them can be seen in the general description of the algorithm.\<close>
text\<open>An insight here is that quantifiers give the best proof-support of list/ranges compared to other list-functions.\<close>
definition low_invariant_is_0_Env where
"low_invariant_is_0_Env e \<equiv> (\<forall>x. x < (low e) \<longrightarrow> (xs e)!x = 0)"

definition invariant_low_to_j_is_1_Env where
"invariant_low_to_j_is_1_Env e \<equiv> (\<forall>x. (x \<ge> (low e) \<and> x < (i e)) \<longrightarrow> (xs e)!x = 1)"

definition high_invariant_is_2_Env where
"high_invariant_is_2_Env e\<equiv> (\<forall>x. x \<ge> (high e) \<and> x < length (xs e) \<longrightarrow> (xs e)!x = 2)"

section\<open>General DNFP conditions\<close>
text\<open>This is the general invariant on the relationship between the variables in the environment.\<close>
definition dnfp_variables_invariants:: "env \<Rightarrow> bool" where
"dnfp_variables_invariants e \<equiv> high e \<ge> i e
                      \<and> i e \<ge> low e
                      \<and> length (xs e) \<ge> high e
                      \<and> set (xs e) \<subseteq> {0,1,2}"

text\<open>This post-condition states that the variables @{text i}, @{text low}, and the difference between @{text high} and @{text i} will never increase.
    The variable @{text high} will never increase. And the multiset and length of the array will never be changed.\<close>
definition dnfp_post where
"dnfp_post e e' \<equiv> length (xs e) = length (xs e')
                  \<and> high e \<ge> high e'
                  \<and> low e \<le> low e'
                  \<and> i e \<le> i e'
                  \<and> high e - i e \<ge> high e' - i e'
                  \<and> mset (xs e) = mset (xs e')"

subsection\<open>DNFP invariants\<close>
text\<open>These definitions add the invariant of the relationship with the different invariants on the ranges\<close>
definition dnfp_inv1:: "env \<Rightarrow> bool" where
"dnfp_inv1  e \<equiv> dnfp_variables_invariants e
                \<and> low_invariant_is_0_Env e"

definition dnfp_inv2:: "env \<Rightarrow> bool" where
"dnfp_inv2 e \<equiv> dnfp_variables_invariants e
                \<and> invariant_low_to_j_is_1_Env e"

definition dnfp_inv3:: "env \<Rightarrow> bool" where
"dnfp_inv3 e \<equiv> dnfp_variables_invariants e
                \<and> high_invariant_is_2_Env e"

definition dnfp_inv :: "env \<Rightarrow> bool" where
"dnfp_inv e \<equiv> ((dnfp_inv3 e) \<and> (dnfp_inv2 e) \<and> (dnfp_inv1 e))"

subsubsection\<open>Other DNFP spec definitions\<close>
text\<open>This is the final state of the algorithm. The main thing is that @{text i}, @{text high} is equal, and the invariants of the ranges\<close>
definition dnfp_post_final_spec where
"dnfp_post_final_spec e \<equiv> dnfp_inv e \<and> i e = high e"

definition dnfp_mon_spec where
"dnfp_mon_spec e \<equiv> dnfp_variables_invariants e
                    \<and> dnfp_inv e"

definition dnfp_mon_pre::"nat \<Rightarrow> env \<Rightarrow> bool"  where
"dnfp_mon_pre n e \<equiv> dnfp_variables_invariants e \<and> n = high e - i e"

definition i_high_equal::"nat \<Rightarrow> env \<Rightarrow> bool"  where
 "i_high_equal n e \<equiv> high e = i e"

definition dnfp_mon_spec_aux:: "nat \<Rightarrow> env \<Rightarrow> bool" where
"dnfp_mon_spec_aux n e \<equiv> n = high e - i e \<and> dnfp_mon_spec e"

text\<open>This is the main post-condition of the whole theory - the array gets sorted\<close>
definition array_sorted where
"array_sorted e \<equiv> sorted(xs e)"

subsection\<open>Loop update action definitions\<close>
text\<open>These definitions extend the basic definitions of dnfp. An extra assumption extends the preconditions. The assumption can be inferred from the conditions-statement inside the function\<close>
text\<open>The post-condition is also for each of the definitions a little stronger compared to the more general\<close>

definition loop_update_action_pre:: "env \<Rightarrow> bool" where
"loop_update_action_pre e \<equiv> dnfp_variables_invariants e \<and> high e > i e"

text\<open>This is an example of a pre-condition that takes an extra @{text env} as a parameter. This is used to capture the initial state so it can be used in the post-condition.\<close>
definition loop_update_action_pre_aux:: "env \<Rightarrow> env \<Rightarrow> bool" where
"loop_update_action_pre_aux e s \<equiv> s = e
                              \<and> loop_update_action_pre e"

definition loop_update_action_post where
"loop_update_action_post e e' \<equiv> dnfp_post e e'
                                \<and> high e - i e = Suc(high e' - i e')"

subsubsection\<open>Loop update action - Invariants\<close>
definition loop_update_action_inv1:: "env \<Rightarrow> bool" where
"loop_update_action_inv1 e \<equiv> dnfp_inv1 e \<and> loop_update_action_pre e"

definition loop_update_action_inv2:: "env \<Rightarrow> bool" where
"loop_update_action_inv2 e \<equiv> dnfp_inv2 e \<and> loop_update_action_pre e"

definition loop_update_action_inv3:: "env \<Rightarrow> bool" where
"loop_update_action_inv3 e \<equiv> dnfp_inv3 e \<and> loop_update_action_pre e"

definition loop_update_action_inv :: "env \<Rightarrow> bool" where
"loop_update_action_inv s \<equiv> (dnfp_inv s \<and> loop_update_action_pre s)"

section\<open>Definitions of the methods from inside the conditional-statement inside Loop update action\<close>
text\<open>These definitions rely on the definitions on loop update action (@{text loop_update_action_pre}), but in the precondition they have an extra assumption that gets inferred from the conditions-statement inside loop-update-action\<close>
text\<open>The post-condition does also make the post-condition a little stronger compared to the more general @{text loop_update_action_post}\<close>

subsection\<open>Inc Lowbound definitions\<close>
text\<open>This definitions is just the same as the ones for loop update action, but they are added with the information that can be infered from the conditional-statement. \<close>
definition inc_lowbound_pre:: "env \<Rightarrow> env \<Rightarrow> bool" where
"inc_lowbound_pre e s \<equiv> s = e
                        \<and> loop_update_action_pre s
                        \<and> (xs s)!(i s) < 1"

definition inc_lowbound_post:: "env \<Rightarrow> env \<Rightarrow> bool" where
"inc_lowbound_post e e'\<equiv> high e = high e'
                          \<and> low e < low e'
                          \<and> loop_update_action_post e e'
                          \<and> i e < i e'"

subsubsection\<open>Inc Index invariants\<close>
text\<open>These invariants is the invariant from the loop-update-action along with the assumption that can be infered from the conditional-statement.\<close>
definition inc_lowbound_inv1:: "env \<Rightarrow> bool" where
"inc_lowbound_inv1 e \<equiv> loop_update_action_inv1 e \<and> xs e ! i e < 1"

definition inc_lowbound_inv2:: "env \<Rightarrow> bool" where
"inc_lowbound_inv2 e \<equiv> loop_update_action_inv2 e \<and> xs e ! i e < 1"

definition inc_lowbound_inv3:: "env \<Rightarrow> bool" where
"inc_lowbound_inv3 e \<equiv> loop_update_action_inv3 e \<and> xs e ! i e < 1"

definition inc_lowbound_inv_pre :: "env \<Rightarrow> bool" where
"inc_lowbound_inv_pre s \<equiv> (loop_update_action_inv s \<and> xs s ! i s < 1)"

subsection\<open>Dec Highbound definitions\<close>
text\<open>This definitions is just the same as the ones for loop update action, but they are added with the information that can be infered from the conditional-statement. \<close>
definition dec_highbound_pre where
"dec_highbound_pre e s\<equiv> e = s
                        \<and> loop_update_action_pre e
                        \<and> (xs e)!(i e) > 1"

definition dec_highbound_post where
"dec_highbound_post e e' \<equiv> length (xs e') > high e'
                              \<and> high e > high e'
                              \<and> low e = low e'
                              \<and> i e = i e'
                              \<and> (xs e')!(high e') = 2
                              \<and> loop_update_action_post e e'"

subsubsection\<open>Dec Highbound invariants\<close>
text\<open>These invariants is the invariant from the loop-update-action along with the assumption that can be infered from the conditional-statement.\<close>
definition dec_highbound_inv1:: "env \<Rightarrow> bool" where
"dec_highbound_inv1 e \<equiv> loop_update_action_inv1 e \<and> xs e ! i e > 1"

definition dec_highbound_inv2:: "env \<Rightarrow> bool" where
"dec_highbound_inv2 e \<equiv> loop_update_action_inv2 e \<and> xs e ! i e > 1"

definition dec_highbound_inv3:: "env \<Rightarrow> bool" where
"dec_highbound_inv3 e \<equiv> loop_update_action_inv3 e \<and> xs e ! i e > 1"

definition dec_highbound_inv :: "env \<Rightarrow> bool" where
"dec_highbound_inv s \<equiv> (loop_update_action_inv s \<and> xs s ! i s > 1 )"

subsection\<open>Inc index definitions\<close>
text\<open>This definitions is just the same as the ones for loop update action, but they are added with the information that can be infered from the conditional-statement. \<close>
definition inc_index_pre:: "env \<Rightarrow> env \<Rightarrow> bool" where
"inc_index_pre e s \<equiv> e = s
                      \<and> loop_update_action_pre e
                      \<and> \<not>(xs e)!(i e) > 1
                      \<and> \<not>(xs e)!(i e) < 1"

definition inc_index_post:: "env \<Rightarrow> env \<Rightarrow> bool" where
"inc_index_post e e' \<equiv> high e = high e'
                      \<and> low e = low e'
                      \<and> i e < i e'
                      \<and> loop_update_action_post e e'"

subsubsection\<open>Inc index invariants\<close>
text\<open>These invariants is the invariant from the loop-update-action along with the assumption that can be infered from the conditional-statement.\<close>
definition inc_index_inv1:: "env \<Rightarrow> bool" where
"inc_index_inv1 e \<equiv> loop_update_action_inv1 e \<and> \<not>(xs e)!(i e) > 1 \<and> \<not>(xs e)!(i e) < 1"

definition inc_index_inv2:: "env \<Rightarrow> bool" where
"inc_index_inv2 e \<equiv> loop_update_action_inv2 e \<and> \<not>(xs e)!(i e) > 1 \<and> \<not>(xs e)!(i e) < 1"

definition inc_index_inv3:: "env \<Rightarrow> bool" where
"inc_index_inv3 e \<equiv> loop_update_action_inv3 e \<and> \<not>(xs e)!(i e) > 1 \<and> \<not>(xs e)!(i e) < 1"

definition inc_index_inv:: "env \<Rightarrow> bool" where
"inc_index_inv e \<equiv> loop_update_action_inv e \<and> \<not>(xs e)!(i e) > 1 \<and> \<not>(xs e)!(i e) < 1"

end


(*
  File: Ordinal.thy
  Author: Bohua Zhan

  Basics of ordinal theory.
*)

theory Ordinal
  imports Wfrec
begin

section \<open>Membership relation is well-founded\<close>

definition mem_rel :: "i \<Rightarrow> i" where [rewrite]:
  "mem_rel(A) = Order(A, \<lambda>x y. x = y \<or> x \<in> y)"

lemma mem_rel_is_rel [typing]: "mem_rel(A) \<in> raworder_space(A)" by auto2
lemma mem_rel_eval [rewrite]:
  "R = mem_rel(A) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> x \<le>\<^sub>R y \<longleftrightarrow> (x = y \<or> x \<in> y)" by auto2
lemma mem_rel_less_eval [rewrite]:
  "R = mem_rel(A) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> x <\<^sub>R y \<longleftrightarrow> x \<in> y"
@proof
  @case "x \<in> y" @with @have "x \<noteq> y" @end
@qed
setup {* del_prfstep_thm @{thm mem_rel_def} *}

lemma wf_mem_rel [forward]: "wf(mem_rel(A))"
@proof
  @have "\<forall>B. B \<subseteq> A \<longrightarrow> B \<noteq> \<emptyset> \<longrightarrow> (\<exists>x\<in>B. ord_minimal(mem_rel(A),B,x))" @with
    @obtain "x\<in>B" where "x \<inter> B = \<emptyset>" @end
@qed

lemma refl_mem_rel [forward]: "refl_order(mem_rel(A))" by auto2

section \<open>Definition of ordinals\<close>

definition trans_set :: "i \<Rightarrow> o" where [rewrite]:
  "trans_set(i) \<longleftrightarrow> (\<forall>x\<in>i. x \<subseteq> i)"

definition ord :: "i \<Rightarrow> o" where [rewrite]:
  "ord(i) \<longleftrightarrow> (trans_set(i) \<and> (\<forall>x\<in>i. trans_set(x)))"

lemma ordI [backward]: "trans_set(i) \<and> (\<forall>j\<in>i. trans_set(j)) \<Longrightarrow> ord(i)" by auto2

lemma ord_mem_is_ord [forward]: "ord(i) \<Longrightarrow> j \<in> i \<Longrightarrow> ord(j)" by auto2
lemma ord_is_trans_set [forward]: "ord(i) \<Longrightarrow> trans_set(i)" by auto2
setup {* del_prfstep_thm @{thm ord_def} *}

lemma trans_mem_rel [forward]: "ord(i) \<Longrightarrow> trans(mem_rel(i))" by auto2

(* succ is an ordinal *)
lemma ord_succ_is_ord [forward]: "ord(i) \<Longrightarrow> ord(succ(i))" by auto2

(* Union is an ordinal. *)
lemma union_ord: "\<forall>x\<in>S. ord(x) \<Longrightarrow> ord(\<Union>S)" by auto2
lemma union_ordP: "\<forall>a\<in>I. ord(X(a)) \<Longrightarrow> ord(\<Union>a\<in>I. X(a))" by auto2

section \<open>Induction on ordinals\<close>

lemma ord_induct' [strong_induct]:
  "ord(k) \<and> i \<in> k \<Longrightarrow> \<forall>x\<in>k. (\<forall>y\<in>x. P(y)) \<longrightarrow> P(x) \<Longrightarrow> P(i)"
@proof @strong_induct "wf(mem_rel(k)) \<and> i \<in>. mem_rel(k)" @qed

lemma ord_induct [script_induct]:
  "ord(i) \<Longrightarrow> \<forall>x. ord(x) \<longrightarrow> (\<forall>y\<in>x. P(y)) \<longrightarrow> P(x) \<Longrightarrow> P(i)"
@proof @strong_induct "ord(succ(i)) \<and> i \<in> succ(i)" @qed

lemma ord_double_induct [script_induct]:
  "ord(i) \<and> ord(j) \<Longrightarrow>
   \<forall>x y. ord(x) \<longrightarrow> ord(y) \<longrightarrow> (\<forall>x'\<in>x. P(x',y)) \<longrightarrow> (\<forall>y'\<in>y. P(x,y')) \<longrightarrow> P(x,y) \<Longrightarrow> P(i,j)"
@proof
  @induct "ord(i)" "\<forall>j. ord(j) \<longrightarrow> P(i,j)" @with
    @subgoal "P(i',j')"
      @induct "ord(j')" "P(i',j')"
    @endgoal
  @end
@qed

(* Ordinals are linearly ordered *)
lemma ord_linear [resolve]:
  "ord(i) \<Longrightarrow> ord(j) \<Longrightarrow> i \<in> j \<or> i = j \<or> j \<in> i"
@proof
  @induct "ord(i) \<and> ord(j)" "i \<in> j \<or> i = j \<or> j \<in> i"
@qed

section \<open>Limit ordinals\<close>

definition limit_ord :: "i \<Rightarrow> o" where [rewrite]:
  "limit_ord(i) \<longleftrightarrow> (ord(i) \<and> \<emptyset> \<in> i \<and> (\<forall>y. y \<in> i \<longrightarrow> succ(y) \<in> i))"

lemma limit_ordD [forward]:
  "limit_ord(i) \<Longrightarrow> ord(i)"
  "limit_ord(i) \<Longrightarrow> \<emptyset> \<in> i" by auto2+

lemma limit_ordD2 [backward]:
  "limit_ord(i) \<Longrightarrow> y \<in> i \<Longrightarrow> succ(y) \<in> i" by auto2

lemma limit_ord_not_succ [resolve]:
  "\<not>limit_ord(succ(a))" by auto2
setup {* del_prfstep_thm_eqforward @{thm limit_ord_def} *}

end


theory T40
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


section \<open> Ordinary Differential Equation Systems \<close>

theory utp_hyprog_ode
  imports utp_hyprog_prelim
begin

subsection \<open> Relational ODEs \<close>

text \<open> An ODE consists of equations @{term \<F>'} and a boundary condition @{term B}. It states that
  there exists a solution function @{term \<F>} and non-zero duration @{term l}, such that for
  every @{term \<tau>} in the interval $[0, l]$ @{term \<F>'} is the derivative of @{term \<F>}, @{term B}
  holds on at each instant, and the before and after value of variable $x$ is equal to
  @{term "\<F>(0)"} and @{term "\<F>(l)"}, respectively. \<close>

abbreviation solves ::
  "(real \<Rightarrow> 'a::executable_euclidean_space) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a, 's) hybs_scheme upred \<Rightarrow> 's \<Rightarrow> real \<Rightarrow> bool" where
  "solves F F' B s l \<equiv>  (\<forall>x. 0 \<le> x \<and> x \<le> l \<longrightarrow> (F has_vector_derivative F' (F x)) (at x) \<and> (\<lbrakk>B\<rbrakk>\<^sub>e (\<lparr>cvec\<^sub>v = F x, \<dots> = s\<rparr>)))"

definition solves\<^sub>u :: "(real \<Rightarrow> 'c::executable_euclidean_space) \<Rightarrow> 'c usubst \<Rightarrow> ('c, 's) hypred \<Rightarrow>  real \<Rightarrow> _" where
[upred_defs]:
"solves\<^sub>u \<F> \<F>' B l \<equiv> (\<^bold>\<forall> \<tau> \<in> {0..\<guillemotleft>l\<guillemotright>}\<^sub>u \<bullet> \<guillemotleft>(\<F> has_vector_derivative (\<lambda> _. \<lbrakk>\<F>'\<rbrakk>\<^sub>e) \<tau> (\<F> \<tau>)) (at \<tau>)
                      \<guillemotright> \<and> \<lceil>B\<lbrakk>\<guillemotleft>\<F>(\<tau>)\<guillemotright>/&cvec\<rbrakk>\<rceil>\<^sub><)"

definition ode :: "'c::executable_euclidean_space usubst \<Rightarrow> ('c, 's) hypred \<Rightarrow> ('c, 's) hyrel" where
[upred_defs]: "ode \<F>' B = cvec:[\<^bold>\<exists> (\<F>, l) \<bullet> \<guillemotleft>l\<guillemotright> \<ge>\<^sub>u 0 \<and> solves\<^sub>u \<F> \<F>' B l \<and> $cvec =\<^sub>u \<guillemotleft>\<F>(0)\<guillemotright> \<and> $cvec\<acute> =\<^sub>u \<guillemotleft>\<F>(l)\<guillemotright>]"

lemma ode_alt_def: "ode \<F>' B = ((\<^bold>\<exists> (\<F>, l) \<bullet> \<guillemotleft>l\<guillemotright> \<ge>\<^sub>u 0 \<and> solves\<^sub>u \<F> \<F>' B l \<and> $cvec =\<^sub>u \<guillemotleft>\<F>(0)\<guillemotright> \<and> $cvec\<acute> =\<^sub>u \<guillemotleft>\<F>(l)\<guillemotright>) \<and> U($\<^bold>d\<acute> = $\<^bold>d))"
  by (rel_auto)

text \<open> A framed ODE allows us to explicitly specify only certain continuous variables using a
  suitable lens that selects those variables we are interested in. The remainder are held constant
  by assigning them deriative 0. \<close>

definition fode ::
  "('a::executable_euclidean_space \<Longrightarrow> 'b::executable_euclidean_space) \<Rightarrow> 'b usubst \<Rightarrow> 'b usubst" where
[upred_defs]: "fode x F = F \<circ>\<^sub>s [&\<^bold>v \<mapsto>\<^sub>s 0]"

subsection \<open> ODE Parser \<close>

text \<open> We set up a parser and pretty printer so that an ODE relation can be written using the
  familiar $\dot{x} = f(x)$ style syntax. \<close>

nonterminal sode and sodes

syntax
  "_ode"        :: "id \<Rightarrow> logic \<Rightarrow> sode" ("der'(_') = _")
  "_ode"        :: "id \<Rightarrow> logic \<Rightarrow> sode" ("_\<^sup>\<bullet> = _")
  "_ode_last"   :: "sode \<Rightarrow> sodes" ("_")
  "_ode_cons"   :: "sode \<Rightarrow> sodes \<Rightarrow> sodes" ("_,/ _")
  "_sys_ode"    :: "sodes \<Rightarrow> logic \<Rightarrow> logic" ("\<langle>_ | _\<rangle>")
  "_sys_ode_s"  :: "sodes \<Rightarrow> logic" ("\<langle>_\<rangle>")
  "_ode_lens"   :: "sodes \<Rightarrow> logic"
  "_ode_tuple"  :: "sodes \<Rightarrow> logic"
  "_ode_expr"   :: "sodes \<Rightarrow> logic"

translations
  "_ode_lens (_ode_cons (_ode x f) fs)" => "x +\<^sub>L (_ode_lens fs)"
  "_ode_lens (_ode_last (_ode x f))" => "x"
  "_ode_tuple (_ode_cons (_ode x f) fs)" => "(x, (_ode_tuple fs))"
  "_ode_tuple (_ode_last (_ode x f))" => "x"
  "_ode_expr (_ode_cons (_ode x f) fs)" => "(f, (_ode_expr fs))"
  "_ode_expr (_ode_last (_ode x f))" => "f"
  "_sys_ode fs B" => "CONST ode (CONST fode (_ode_lens fs /\<^sub>L CONST cvec) (_abs (_ode_tuple fs) (_ode_expr fs))) B"
  "_sys_ode_s fs" == "_sys_ode fs true"
  "_sys_ode (_ode y f) B" <= "CONST ode (CONST fode x (_abs y f)) B"
  "_ode_cons (_ode x f) (_ode y g)" <= "_ode (_pattern x y) (f, g)"

(*
term "\<langle>der(h) = v, der(v) = -9.81 | (&h \<ge>\<^sub>u 0)\<rangle>"
term "\<langle>x\<^sup>\<bullet> = f(x)\<rangle>"
*)

subsection \<open> ODE laws \<close>

lemma solves_le: "\<lbrakk> solves F F' B s l; l' \<le> l \<rbrakk> \<Longrightarrow> solves F F' B s l'"
  by (meson atLeastatMost_subset_iff has_vector_derivative_within_subset order_refl order_trans)

lemma ode_post: "ode F' B ;; ?[B] = ode F' B"
  by (rel_auto', metis (no_types), metis hybs.select_convs(1) order_refl)

lemma ode_mono:
  "`(C \<Rightarrow> B)` \<Longrightarrow> ode F' B \<sqsubseteq> ode F' C"
  by (rel_blast)

lemma frame_nmods_indep [closure]: "\<lbrakk> vwb_lens b; a \<bowtie> b \<rbrakk> \<Longrightarrow> a:[P] nmods b"
  by (rel_auto, metis lens_indep.lens_put_comm vwb_lens_wb wb_lens.get_put)

text \<open> ODE evolutions do not modify discrete variables \<close>

lemma ode_nmods_discrete: "ode F' B nmods \<^bold>d"
  by (simp add: ode_def closure)

text \<open> If a continuous variable has a zero derivative then it is not modified. \<close>

lemma ode_nmods_constant_cvar:
  assumes "cont_lens x" "\<langle>F'\<rangle>\<^sub>s x = 0"
  shows "ode F' B nmods \<^bold>c:x"
proof (rel_simp', auto)
  fix m f t
  assume a: "0 \<le> t" "\<forall>x. 0 \<le> x \<and> x \<le> t \<longrightarrow> (f has_vector_derivative \<lbrakk>F'\<rbrakk>\<^sub>e (f x)) (at x) \<and> \<lbrakk>B\<rbrakk>\<^sub>e \<lparr>cvec\<^sub>v = f x, \<dots> = m\<rparr>"
  from assms(2) have "\<forall>t. get\<^bsub>x\<^esub> (\<lbrakk>F'\<rbrakk>\<^sub>e t) = 0"
    by (rel_simp)
  hence b: "\<forall>y. 0 \<le> y \<and> y \<le> t \<longrightarrow> ((get\<^bsub>x\<^esub> \<circ> f) has_vector_derivative 0) (at y)"
    by (metis (no_types, lifting) a(2) assms(1) bounded_linear_imp_has_derivative cont_lens_bounded_linear vector_derivative_diff_chain_within)
  have "\<exists> c. \<forall>y. 0 \<le> y \<and> y \<le> t \<longrightarrow> get\<^bsub>x\<^esub> (f y) = c"
    using b has_vector_derivative_at_within
    by (rule_tac has_vector_derivative_zero_constant[of "{0..t}" "(get\<^bsub>x\<^esub> \<circ> f)", simplified]; blast)
  hence "get\<^bsub>x\<^esub> (f t) = get\<^bsub>x\<^esub> (f 0)"
    using a(1) by blast
  thus "f t = put\<^bsub>x\<^esub> (f t) (get\<^bsub>x\<^esub> (f 0))"
    using assms(1) cont_lens_vwb vwb_lens.put_eq by force
qed

lemma ode_nuses_constant_cvar:
  fixes x :: "'b::real_normed_vector \<Longrightarrow> 'c::executable_euclidean_space"
  assumes "cont_lens x" "\<langle>F'\<rangle>\<^sub>s x = 0" "x \<sharp> F'" "\<^bold>c:x \<sharp> B"
  shows "ode F' B nuses \<^bold>c:x"
using assms proof (rule_tac nuses_nmods_intro, simp_all add: ode_nmods_constant_cvar)
  from assms show "\<forall>v. \<^bold>c:x := \<guillemotleft>v\<guillemotright> ;; ode F' B ;; \<^bold>c:x := \<guillemotleft>v\<guillemotright> = ode F' B ;; \<^bold>c:x := \<guillemotleft>v\<guillemotright>"
    apply (rel_auto')
     apply (rename_tac v s d F l)
     apply (rule_tac x="\<lparr>cvec\<^sub>v = put\<^bsub>x\<^esub> (F l) (get\<^bsub>x\<^esub> s), \<dots> = d\<rparr>" in exI)
     apply (simp)
     apply (rule_tac x="(\<lambda> t. put\<^bsub>x\<^esub> (F t) (get\<^bsub>x\<^esub> s))" in exI)
     apply (rule_tac x="l" in exI)
     apply (simp)
     apply (auto)[1]
     apply (rename_tac v s d F l t)
       apply (simp add: has_vector_derivative_def)
       apply (rule_tac f'="\<lambda> n. put\<^bsub>x\<^esub> (n *\<^sub>R \<lbrakk>F'\<rbrakk>\<^sub>e (F t)) 0" in has_derivative_eq_rhs)
        apply (rule_tac g="(\<lambda>a. put\<^bsub>x\<^esub> a (get\<^bsub>x\<^esub> s))" and g'="(\<lambda>a. put\<^bsub>x\<^esub> a 0)" in has_derivative_compose)
         apply blast
        apply (rule cont_lens.has_derivative_put'[OF assms(1)])
    using bounded_linear_ident apply blast
        apply (rule has_derivative_const)
    apply (metis (no_types, opaque_lifting) cont_lens_axioms_def cont_lens_def linear_simps(5) scale_zero_right vwb_lens_wb wb_lens.get_put)
    apply (metis hybs.select_convs(1) hybs.update_convs(1))
    apply (metis cont_lens_vwb vwb_lens.put_eq)
    apply (rename_tac v d F l)
    apply (rule_tac x="\<lparr>cvec\<^sub>v = put\<^bsub>x\<^esub> (F l) v, \<dots> = d\<rparr>" in exI)
    apply (simp)
    apply (rule_tac x="(\<lambda> t. put\<^bsub>x\<^esub> (F t) v)" in exI)
    apply (rule_tac x="l" in exI)
    apply (auto)
    apply (rename_tac v d F l t)
     apply (simp add: has_vector_derivative_def)
     apply (rule_tac f'="\<lambda> n. put\<^bsub>x\<^esub> (n *\<^sub>R \<lbrakk>F'\<rbrakk>\<^sub>e (F t)) 0" in has_derivative_eq_rhs)
      apply (rule_tac g="(\<lambda>a. put\<^bsub>x\<^esub> a v)" and g'="(\<lambda>a. put\<^bsub>x\<^esub> a 0)" in has_derivative_compose)
       apply (blast)
        apply (rule cont_lens.has_derivative_put'[OF assms(1)])
        using bounded_linear_ident apply blast
        apply (rule has_derivative_const)
    apply (metis (no_types, opaque_lifting) cont_lens_axioms_def cont_lens_def linear_simps(5) scale_zero_right vwb_lens_wb wb_lens.source_stability wb_lens_def weak_lens.put_get)
    apply (metis hybs.select_convs(1) hybs.update_convs(1))
    done
qed

lemma ode_nuses_constant_cvar_eucl:
  assumes "\<langle>F'\<rangle>\<^sub>s (vec_lens i) = 0" "\<pi>[i] \<sharp> F'" "\<^bold>c:\<pi>[i] \<sharp> B"
  shows "ode F' B nuses \<^bold>c:\<pi>[i]"
  by (rule ode_nuses_constant_cvar, simp_all add: assms)

lemma disc_nmods_invar:
  "\<lbrakk> \<^bold>c \<sharp> b; P nmods \<^bold>d \<rbrakk> \<Longrightarrow> \<^bold>{b\<^bold>}P\<^bold>{b\<^bold>}"
  apply (rel_simp')
  by (metis hybs.simps(3))

lemma cont_nmods_invar:
  "\<lbrakk> \<^bold>d \<sharp> b; P nmods \<^bold>c \<rbrakk> \<Longrightarrow> \<^bold>{b\<^bold>}P\<^bold>{b\<^bold>}"
  apply (rel_simp')
  by (metis hybs.simps(4))

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_NMSortTDSorts
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun take :: "int => 'a list => 'a list" where
  "take x y =
   (if x <= 0 then nil2 else
      (case y of
         nil2 => nil2
         | cons2 z xs => cons2 z (take (x - 1) xs)))"

fun ordered :: "int list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((y <= y2) & (ordered (cons2 y2 xs)))"

(*fun did not finish the proof*)
function nmsorttdhalf1 :: "int => int" where
  "nmsorttdhalf1 x =
   (if (x = 1) then 0 else
      (if (x = 0) then 0 else 1 + (nmsorttdhalf1 (x - 2))))"
  by pat_completeness auto

fun lmerge :: "int list => int list => int list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if z <= x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 y l) = 1 + (length l)"

fun drop :: "int => 'a list => 'a list" where
  "drop x y =
   (if x <= 0 then y else
      (case y of
         nil2 => nil2
         | cons2 z xs1 => drop (x - 1) xs1))"

(*fun did not finish the proof*)
function nmsorttd :: "int list => int list" where
  "nmsorttd (nil2) = nil2"
| "nmsorttd (cons2 y (nil2)) = cons2 y (nil2)"
| "nmsorttd (cons2 y (cons2 x2 x3)) =
     (let k :: int = nmsorttdhalf1 (length (cons2 y (cons2 x2 x3)))
     in lmerge
          (nmsorttd (take k (cons2 y (cons2 x2 x3))))
          (nmsorttd (drop k (cons2 y (cons2 x2 x3)))))"
  by pat_completeness auto

theorem property0 :
  "ordered (nmsorttd xs)"
  oops

end


theory T50
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=10,timeout=86400]
oops
end


theory T42
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory T51
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end