(*  Title:      perfect/Perfect_Sensors.thy
    Author:     Sven Linker

Instantiation of the sensor function to model "perfect sensors". That is,
each car can perceive both the physical size as well as the concrete
braking distance of all other cars.
*)

section \<open>Perfect Sensors\<close>
text\<open>
This section contains an instantiations of the sensor function for
"perfect sensors". That is, each car can perceive both the physical
size as well as the braking distance of each other car.
\<close>

theory Perfect_Sensors
  imports  "../Length"
begin

definition perfect::"cars \<Rightarrow> traffic \<Rightarrow> cars \<Rightarrow> real"
  where "perfect e ts c \<equiv> traffic.physical_size ts c + traffic.braking_distance ts c "

locale perfect_sensors = traffic+view
begin

interpretation perfect_sensors : sensors "perfect :: cars \<Rightarrow> traffic \<Rightarrow> cars \<Rightarrow> real"
proof unfold_locales
  fix e ts c
  show " 0 < perfect e ts c"
    by (metis less_add_same_cancel2 less_trans perfect_def traffic.psGeZero traffic.sdGeZero)
qed

notation perfect_sensors.space ("space")
notation perfect_sensors.len ("len")

text\<open>
With this sensor definition, we can show that the perceived length of a car
is independent of the spatial transitions between traffic snapshots. The
length may only change during evolutions, in particular if the car changes its dynamical
behaviour.
\<close>

lemma create_reservation_length_stable:
  "(ts\<^bold>\<midarrow>r(d)\<^bold>\<rightarrow>ts') \<longrightarrow> len v ts c = len v ts' c"
proof
  assume assm:"(ts\<^bold>\<midarrow>r(d)\<^bold>\<rightarrow>ts')"
  hence eq:"space ts v c = space ts' v c"
    using traffic.create_reservation_def perfect_sensors.space_def perfect_def
    by (simp)
  show "len v ( ts) c = len v ( ts') c"
  proof (cases "left ((space ts v) c) > right (ext v)")
    assume outside_right:"left ((space ts v) c) > right (ext v)"
    hence outside_right':"left ((space ts' v) c) > right (ext v)" using eq by simp
    from outside_right and outside_right' show ?thesis
      by (simp add: perfect_sensors.len_def eq)
  next
    assume inside_right:"\<not> left ((space ts v) c) > right (ext v)"
    hence inside_right':"\<not> left ((space ts' v) c) > right (ext v)" using eq by simp
    show "len v ( ts) c = len v ( ts') c"
    proof (cases " left (ext v) > right ((space ts v) c) ")
      assume outside_left:" left (ext v) > right ((space ts v) c) "
      hence outside_left':" left (ext v) > right ((space ts' v) c) "using eq by simp
      from outside_left and outside_left' show ?thesis
        by (simp add: perfect_sensors.len_def eq)
    next
      assume inside_left:"\<not> left (ext v) > right ((space ts v) c) "
      hence inside_left':"\<not> left (ext v) > right ((space ts' v) c) " using eq by simp
      from inside_left inside_right inside_left' inside_right' eq
      show ?thesis by (simp add: perfect_sensors.len_def)
    qed
  qed
qed

lemma create_claim_length_stable:
  "(ts\<^bold>\<midarrow>c(d,n)\<^bold>\<rightarrow>ts') \<longrightarrow> len v ts c = len v ts' c"
proof
  assume assm:"(ts\<^bold>\<midarrow>c(d,n)\<^bold>\<rightarrow>ts')"
  hence eq:"space ts v c = space ts' v c"
    using traffic.create_claim_def perfect_sensors.space_def perfect_def
    by (simp)
  show "len v ( ts) c = len v ( ts') c"
  proof (cases "left ((space ts v) c) > right (ext v)")
    assume outside_right:"left ((space ts v) c) > right (ext v)"
    hence outside_right':"left ((space ts' v) c) > right (ext v)" using eq by simp
    from outside_right and outside_right' show ?thesis
      by (simp add: perfect_sensors.len_def eq)
  next
    assume inside_right:"\<not> left ((space ts v) c) > right (ext v)"
    hence inside_right':"\<not> left ((space ts' v) c) > right (ext v)" using eq by simp
    show "len v ( ts) c = len v ( ts') c"
    proof (cases " left (ext v) > right ((space ts v) c) ")
      assume outside_left:" left (ext v) > right ((space ts v) c) "
      hence outside_left':" left (ext v) > right ((space ts' v) c) "using eq by simp
      from outside_left and outside_left' show ?thesis
        by (simp add: perfect_sensors.len_def eq)
    next
      assume inside_left:"\<not> left (ext v) > right ((space ts v) c) "
      hence inside_left':"\<not> left (ext v) > right ((space ts' v) c) " using eq by simp
      from inside_left inside_right inside_left' inside_right' eq
      show ?thesis by (simp add: perfect_sensors.len_def)
    qed
  qed
qed

lemma withdraw_reservation_length_stable:
  "(ts\<^bold>\<midarrow>wdr(d,n)\<^bold>\<rightarrow>ts') \<longrightarrow> len v ts c = len v ts' c"
proof
  assume assm:"(ts\<^bold>\<midarrow>wdr(d,n)\<^bold>\<rightarrow>ts')"
  hence eq:"space ts v c = space ts' v c"
    using traffic.withdraw_reservation_def perfect_sensors.space_def perfect_def
    by (simp)
  show "len v ( ts) c = len v ( ts') c"
  proof (cases "left ((space ts v) c) > right (ext v)")
    assume outside_right:"left ((space ts v) c) > right (ext v)"
    hence outside_right':"left ((space ts' v) c) > right (ext v)" using eq by simp
    from outside_right and outside_right' show ?thesis
      by (simp add: perfect_sensors.len_def eq)
  next
    assume inside_right:"\<not> left ((space ts v) c) > right (ext v)"
    hence inside_right':"\<not> left ((space ts' v) c) > right (ext v)" using eq by simp
    show "len v ( ts) c = len v ( ts') c"
    proof (cases " left (ext v) > right ((space ts v) c) ")
      assume outside_left:" left (ext v) > right ((space ts v) c) "
      hence outside_left':" left (ext v) > right ((space ts' v) c) "using eq by simp
      from outside_left and outside_left' show ?thesis
        by (simp add: perfect_sensors.len_def eq)
    next
      assume inside_left:"\<not> left (ext v) > right ((space ts v) c) "
      hence inside_left':"\<not> left (ext v) > right ((space ts' v) c) " using eq by simp
      from inside_left inside_right inside_left' inside_right' eq
      show ?thesis by (simp add: perfect_sensors.len_def)
    qed
  qed
qed

lemma withdraw_claim_length_stable:
  "(ts\<^bold>\<midarrow>wdc(d)\<^bold>\<rightarrow>ts') \<longrightarrow> len v ts c = len v ts' c"
proof
  assume assm:"(ts\<^bold>\<midarrow>wdc(d)\<^bold>\<rightarrow>ts')"
  hence eq:"space ts v c = space ts' v c"
    using traffic.withdraw_claim_def perfect_sensors.space_def perfect_def
    by (simp)
  show "len v ( ts) c = len v ( ts') c"
  proof (cases "left ((space ts v) c) > right (ext v)")
    assume outside_right:"left ((space ts v) c) > right (ext v)"
    hence outside_right':"left ((space ts' v) c) > right (ext v)" using eq by simp
    from outside_right and outside_right' show ?thesis
      by (simp add: perfect_sensors.len_def eq)
  next
    assume inside_right:"\<not> left ((space ts v) c) > right (ext v)"
    hence inside_right':"\<not> left ((space ts' v) c) > right (ext v)" using eq by simp
    show "len v ( ts) c = len v ( ts') c"
    proof (cases " left (ext v) > right ((space ts v) c) ")
      assume outside_left:" left (ext v) > right ((space ts v) c) "
      hence outside_left':" left (ext v) > right ((space ts' v) c) "using eq by simp
      from outside_left and outside_left' show ?thesis
        by (simp add: perfect_sensors.len_def eq)
    next
      assume inside_left:"\<not> left (ext v) > right ((space ts v) c) "
      hence inside_left':"\<not> left (ext v) > right ((space ts' v) c) " using eq by simp
      from inside_left inside_right inside_left' inside_right' eq
      show ?thesis by (simp add: perfect_sensors.len_def)
    qed
  qed
qed

text\<open>
The following lemma shows that the perceived length is independent from
the owner of the view. That is, as long as two views consist of the same
extension, the perceived length of each car is the same in both views.
\<close>

lemma all_own_ext_eq_len_eq:
  "ext v = ext v'  \<longrightarrow> len v ts c = len v' ts c"
proof
  assume assm:"ext v = ext v'"
  hence sp:"space ts v c = space ts v' c"
    by (simp add: perfect_def  perfect_sensors.space_def)
  have left_eq:"left (ext v) = left (ext v')" using assm by simp
  have right_eq:"right (ext v) = right (ext v')" using assm by simp
  show "len v ( ts) c = len v' ( ts) c"
  proof (cases "left ((space ts v) c) > right (ext v)")
    assume outside_right:"left ((space ts v) c) > right (ext v)"
    hence outside_right':"left ((space ts v) c) > right (ext v')"
      using right_eq by simp
    from outside_right and outside_right' show ?thesis
      by (simp add: perfect_sensors.len_def right_eq assm sp)
  next
    assume inside_right:"\<not> left ((space ts v) c) > right (ext v)"
    hence inside_right':"\<not> left ((space ts v) c) > right (ext v')"
      using right_eq by simp
    show "len v ( ts) c = len v' ( ts) c"
    proof (cases " left (ext v) > right ((space ts v) c) ")
      assume outside_left:" left (ext v) > right ((space ts v) c) "
      hence outside_left':" left (ext v') > right ((space ts v) c) "
        using left_eq by simp
      from outside_left and outside_left' show ?thesis
        using perfect_sensors.len_def left_eq sp right_eq
        by auto
    next
      assume inside_left:"\<not> left (ext v) > right ((space ts v) c) "
      hence inside_left':"\<not> left (ext v') > right ((space ts v) c) "
        using left_eq by simp
      from inside_left inside_right inside_left' inside_right' left_eq right_eq
      show ?thesis by (simp add:perfect_sensors.len_def sp)
    qed
  qed
qed

text\<open>
Finally, switching the perspective of a view does not change the
perceived length.
\<close>

lemma switch_length_stable:"(v=d>v') \<longrightarrow> len v ts c = len v' ts c"
  using all_own_ext_eq_len_eq view.switch_def  by metis

end
end


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

header {* Finite sets *}

theory PRecFinSet
imports PRecFun
begin

text {*
  We introduce a particular mapping @{text "nat_to_set"} from natural
  numbers to finite sets of natural numbers and a particular mapping
  @{text "set_to_nat"} from finite sets of natural numbers to natural
  numbers.  See \cite{Rogers} and \cite{Soare} for more information.
*}

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 (induct x) auto

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 S1 S2 show ?thesis by auto
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
    def y_def: y \<equiv> "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
  def y_def: y \<equiv> "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 mod_div_equality2)
  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)
  def max_def: max \<equiv> "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)
          def m_def: m \<equiv> "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
          def D1_def: D1 \<equiv> "D - {m}"
          def u1_def: u1 \<equiv> "u - 2^m"
          def v1_def: v1 \<equiv> "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)
  def D_def: D \<equiv> "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
  def n_def: n \<equiv> "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. setsum (\<lambda> x. 2 ^ x) D)"

lemma two_power_sum: "setsum (\<lambda> x. (2::nat) ^ x) {i. i< Suc m} = (2 ^ Suc m) - 1"
proof (induct m)
  show "setsum (\<lambda> x. (2::nat) ^ x) {i. i< Suc 0} = (2 ^ Suc 0) - 1" by auto
next
  fix n
  assume A: "setsum (\<lambda> x. (2::nat) ^ x) {i. i< Suc n} = (2 ^ Suc n) - 1"
  show "setsum (\<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 setsum.insert have S7: "setsum ?f ({i. i< Suc n} \<union> {Suc n}) = 2 ^ Suc n + setsum ?f {i. i< Suc n}" by auto
    from S3 have "setsum ?f {i. i< Suc (Suc n)} = setsum ?f ({i. i< Suc n} \<union> {Suc n})" by auto
    also from S7 have "\<dots> = 2 ^ Suc n + setsum ?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 setsum.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 = setsum ?f A" by (simp add: set_to_nat_def)
  have S2: "set_to_nat B = setsum ?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 "setsum ?f A \<le> setsum ?f B" by (rule setsum_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 = setsum (\<lambda> x. 2 ^ x) D" by simp
      with S3 setsum.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
        def m_def: m \<equiv> "Max D"
        from S2 have D_ne: "D \<noteq> {}" by auto
        with S1 m_def have m_in: "m \<in> D" by auto
        def D1_def: D1 \<equiv> "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
        def u_def: u \<equiv> "set_to_nat D"
        def u1_def: u1 \<equiv> "set_to_nat D1"
        from S1 m_in have "setsum (\<lambda> (x::nat). (2::nat) ^ x) D = 2 ^ m + setsum (\<lambda> x. 2 ^ x) (D - {m})" by (rule setsum.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. setsum g {i. i<n}) \<in> PrimRec1"
proof -
  assume g_is_pr: "g \<in> PrimRec1"
  def f_def: f \<equiv> "\<lambda> n. setsum g {i. i<n}"
  from f_def have f_at_0: "f 0 = 0" by auto
  def h_def: h \<equiv> "\<lambda> a (b::nat). (g 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) = setsum 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) = setsum g ({i. (i::nat) < y} \<union> {y})" by auto
      also from S3 S4 setsum.insert have "\<dots> = g y + setsum 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 show ?thesis by auto
qed

lemma sum_of_pr_is_pr2: "p \<in> PrimRec2 \<Longrightarrow> (\<lambda> n m. setsum (\<lambda> x. p x m) {i. i<n}) \<in> PrimRec2"
proof -
  assume p_is_pr: "p \<in> PrimRec2"
  def f_def: f \<equiv> "\<lambda> n m. setsum (\<lambda> x. p x m) {i. i<n}"
  def g_def: g \<equiv> "\<lambda> (x::nat). (0::nat)"
  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
  def h_def: h \<equiv> "\<lambda> a (b::nat) c. (p a c) + b"
  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 = setsum (\<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
      def g1_def: g1 \<equiv> "(\<lambda> z. p z x)"
      from S1 S2 g1_def have "f (Suc y) x = setsum g1 ({i. (i::nat) < y} \<union> {y})" by auto
      also from S3 S4 setsum.insert have "\<dots> = g1 y + setsum 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 show ?thesis by auto
qed

lemma setsum_is_pr: "g \<in> PrimRec1 \<Longrightarrow> (\<lambda> u. setsum g (nat_to_set u)) \<in> PrimRec1"
proof -
  assume g_is_pr: "g \<in> PrimRec1"
  def g1_def: g1 \<equiv> "\<lambda> x u. if (c_in x u = 1) then (g x) else 0"
  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
  def f_def: f \<equiv> "\<lambda> (u::nat). setsum (\<lambda> x. g1 x u) {i. (i::nat) < u}"
  def f1_def: f1 \<equiv> "\<lambda> (u::nat) v. setsum (\<lambda> x. g1 x v) {i. (i::nat) < u}"
  from g1_is_pr have "(\<lambda> (u::nat) v. setsum (\<lambda> x. g1 x v) {i. (i::nat) < u}) \<in> PrimRec2" by (rule sum_of_pr_is_pr2)
  with f1_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. setsum g (nat_to_set u))"
  proof
    fix u show "f u = setsum g (nat_to_set u)"
    proof -
      def U_def: U \<equiv> "{i. i < u}"
      def A_def: A \<equiv> "{x \<in> U. c_in x u = 1}"
      def B_def: B \<equiv> "{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: "setsum (\<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: "setsum (\<lambda> x. g1 x u) A = setsum g (nat_to_set u)" by auto
      from f_def have "f u = setsum (\<lambda> x. g1 x u) {i. (i::nat) < u}" by auto
      also from U_def have "\<dots> = setsum (\<lambda> x. g1 x u) U" by auto
      also from U_A_B have "\<dots> = setsum (\<lambda> x. g1 x u) (A \<union> B)" by auto
      also from A_finite B_finite A_B have "\<dots> = setsum (\<lambda> x. g1 x u) A + setsum (\<lambda> x. g1 x u) B" by (rule setsum.union_disjoint)
      also from B_z have "\<dots> = setsum (\<lambda> x. g1 x u) A" by auto
      also from A_res have "\<dots> = setsum 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 -
  def g_def: g \<equiv> "\<lambda> (x::nat). (1::nat)"
  have g_is_pr: "g \<in> PrimRec1" by (unfold g_def, rule const_is_pr)
  have "c_card = (\<lambda> u. setsum g (nat_to_set u))"
  proof
    fix u show "c_card u = setsum g (nat_to_set u)" by (unfold c_card_def, unfold g_def, rule card_eq_setsum)
  qed
  moreover from g_is_pr have "(\<lambda> u. setsum g (nat_to_set u)) \<in> PrimRec1" by (rule setsum_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"
  def D_def: D \<equiv> "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}) = setsum ?f (D \<union> {x})" by auto
  also from D_finite S1 have "\<dots> = ?f x + setsum ?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"
  def D_def: D \<equiv> "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}) = setsum ?f (D \<union> {x})" by auto
  also from D_finite S1 have "\<dots> = ?f x + setsum ?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 -
  def f_def: f \<equiv> "\<lambda> y x. set_to_nat ((nat_to_set (c_fst x)) \<union> {z \<in> nat_to_set (c_snd x). z < y})"
  have f_is_pr: "f \<in> PrimRec2"
  proof -
    def g_def: g \<equiv> "c_fst"
    from c_fst_is_pr g_def have g_is_pr: "g \<in> PrimRec1" by auto
    def h_def: h \<equiv> "\<lambda> a b c. if c_in a (c_snd c) = 1 then c_insert a b else b"
    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
  def union_def: union \<equiv> "\<lambda> u v. f v (c_pair 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 -
  def f_def: f \<equiv> "\<lambda> y x. set_to_nat ((nat_to_set (c_fst x)) - {z \<in> nat_to_set (c_snd x). z < y})"
  have f_is_pr: "f \<in> PrimRec2"
  proof -
    def g_def: g \<equiv> "c_fst"
    from c_fst_is_pr g_def have g_is_pr: "g \<in> PrimRec1" by auto
    def h_def: h \<equiv> "\<lambda> a b c. if c_in a (c_snd c) = 1 then c_remove a b else b"
    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
  def diff_def: diff \<equiv> "\<lambda> u v. f v (c_pair 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 -
  def f_def: f \<equiv> "\<lambda> u v. c_diff (c_union u v) (c_union (c_diff u v) (c_diff v u))"
  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


(* exercise 3.12 *)
theory ASMReg0
  imports
    AExp "~~/src/HOL/Library/Code_Target_Nat"
begin

section "Register Machine and Compilation"
subsection "Register Machine"

  (* A register identifier is a natural number. I.e. the registers are numbered 0, 1, ...  *)
type_synonym reg = nat

datatype instr =
  LDI0 val | (* register 0 is the target *)
  LD0 vname | (* register 0 is the target *)
  MV0 reg | (* register 0 is the source *)
  ADD0 reg (* register 0 is the target, and an operand *)

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> (reg \<Rightarrow> int)" where
  "exec1 (LDI0 val) _ registers = (registers (0 := val))" |
  "exec1 (LD0 vname) state registers = registers (0 := state vname)" |
  "exec1 (MV0 reg) _ registers = registers (reg := registers 0)" |
  "exec1 (ADD0 reg\<^sub>o\<^sub>p) _ registers = registers (0 := registers 0 + registers reg\<^sub>o\<^sub>p)"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> (reg \<Rightarrow> int)" where
  "exec [] _ registers = registers" |
  "exec (i#is) state registers = exec is state (exec1 i state registers)"

lemma exec_append:"exec (l1 @ l2) s rs = exec l2 s (exec l1 s rs)"
  (* rs MUST be arbitrary. This strengthens the induction hypothesis: the register
    file in the IH may be different than the register file in the thesis.
    This is necessary, because the inductive step adds another instruction, which will cause the
    register file to change when executed. That is, the register file in the inductive step will be
    different than the register file in the IH, because of the inductive step. *)
  apply(induction l1 arbitrary: rs)
   by(simp_all)

subsection "Compilation"

  (* The compiler takes an arithmetic expression a and produces a list of
instructions whose execution places the value of a into register 0.
The registers > r should be used in a stack-like fashion for intermediate results, the ones < r
should be left alone. *)
fun compile :: "aexp \<Rightarrow> reg \<Rightarrow> instr list" where
  "compile (N n) _ = [LDI0 n]" |
  "compile (V v) _ = [LD0 v]" |
  "compile (Plus e\<^sub>1 e\<^sub>2) r = (
    if r > 0
    then compile e\<^sub>1 r @ [MV0 r] @ compile e\<^sub>2 (r + 1) @ [ADD0 r]
    else compile e\<^sub>1 1 @ [MV0 1] @ compile e\<^sub>2 2 @ [ADD0 1])"

value "compile (Plus (N 9) (N 10)) 0"
value "exec (compile (Plus (N 9) (N 10)) 1) <> <> 1"

lemma lesser_registers_unchanged:
  "reg\<^sub>q\<^sub>u\<^sub>e\<^sub>r\<^sub>y < reg\<^sub>d\<^sub>e\<^sub>s\<^sub>t \<Longrightarrow>
   reg\<^sub>q\<^sub>u\<^sub>e\<^sub>r\<^sub>y \<noteq> 0 \<Longrightarrow>
    (exec (compile exp reg\<^sub>d\<^sub>e\<^sub>s\<^sub>t) st rs) reg\<^sub>q\<^sub>u\<^sub>e\<^sub>r\<^sub>y = rs reg\<^sub>q\<^sub>u\<^sub>e\<^sub>r\<^sub>y"
  (* arbitrary reg\<^sub>d\<^sub>e\<^sub>s\<^sub>t is required because it changes when compiling ADD
    arbitrary rs is required because it changes when executing *)
  apply(induction exp arbitrary: rs reg\<^sub>d\<^sub>e\<^sub>s\<^sub>t)
    apply(simp_all)
  using exec_append by simp

theorem compile_is_correct: "exec (compile expr reg_dest) state rs 0 = aval expr state"
  (* reg_dest is arbitrary because it changes during compile ADD
    rs is arbitrary because it changes during exec*)
  apply(induction expr arbitrary: reg_dest rs)
    apply(simp_all)
  using exec_append lesser_registers_unchanged by simp

end


section \<open> Contiguous Functions \<close>

(*<*)
theory Contiguous_Functions
  imports
  HOL.Real_Vector_Spaces
  "Optics.Lenses"
  "Z_Toolkit.Map_Extra"
  "Z_Toolkit.List_Extra"
  "Z_Toolkit.Trace_Algebra"
  Derivative_extra
  "HOL-Analysis.Topology_Euclidean_Space"
begin
(*>*)

text \<open> In this section we will define a type to represent contiguous functions with
  a real domain, which will be used to represent trajectories, together with suitable algebraic
  operators. We then specialise this to piecewise continuous and convergent functions, and show
  closure of the algebraic operators. The properties we use here will be crucial in our hybrid
  relational calculus. Our model and the associated algebra is based partly on the work of
  Hayes~\cite{Hayes2006,Hayes2010} who introduces a theory of timed traces to give semantics
  to real-time programs, and also H\"{o}fner~\cite{Hofner2009} who gives and algebraic foundation for verifying
  hybrid systems, including operators on continuous trajectories that underlie hybrid automata.
  A timed trace is essentially a function from real numbers to a continuous state space; in the
  following we will further elaborate this.
\<close>

subsection \<open> Preliminaries \<close>

text \<open> We first define two functions that a shift a partial function to the left and the right by
  a value $n$, respectively, by a suitable minus or addition on the input. These functions will
  allow us to define concatenation of two timed traces. \<close>

abbreviation rshift :: "('a::ring \<rightharpoonup> 'b) \<Rightarrow> 'a \<Rightarrow> ('a \<rightharpoonup> 'b)" (infixr "\<ggreater>" 66) where
"rshift f n \<equiv> (\<lambda> x. f (x - n))"

abbreviation lshift :: "'a \<Rightarrow> ('a::ring \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b)" (infixl "\<lless>" 65) where
"lshift n f \<equiv> (\<lambda> x. f (x + n))"

text \<open> We can then show the following two results that give the domain of left and right shifted
  functions. \<close>

lemma dom_shift_plus: "dom (n \<lless> f) = {x - n | x. x \<in> dom f}"
  by (auto simp add: dom_def, force)

lemma dom_shift_minus: "dom (f \<ggreater> n) = (+) n ` dom f"
  by (simp add: dom_def image_Collect, force)

lemma shift_minus_cong: "f \<ggreater> n = g \<ggreater> n \<Longrightarrow> f = g"
  apply (auto simp add: fun_eq_iff)
  apply (drule_tac x="x + n" in spec)
  apply (simp)
done

lemma dom_shift_map_add: "(f ++ g) \<ggreater> n = (f \<ggreater> n) ++ (g \<ggreater> n)"
  by (simp add: map_add_def)

lemma atLeastLessThan_union_disj [simp]: "\<lbrakk> 0 \<le> i; i \<le> j \<rbrakk> \<Longrightarrow> {0..<i::real} \<union> {i..<j} = {0..<j}"
  by (auto)

definition Sup' :: "real set \<Rightarrow> real" where
"Sup' A = (if (A = {}) then 0 else Sup A)"

text \<open> We also define the @{term Sup} operator that gives the supremum of a set of positive real numbers.
  Specifically, if the set is empty then it is 0, otherwise it is the built-in supremum for
  real numbers. We can then prove some properties about such suprema. \<close>

lemma Sup'_empty [simp]: "Sup' {} = 0"
  by (simp add: Sup'_def)

lemma Sup'_interval [simp]: "Sup' {0..<m} = (if (m > 0) then m else 0)"
  by (simp add: Sup'_def)

lemma Sup'_interval': "Sup' {t. 0 \<le> t \<and> t < l} = (if (l > 0) then l else 0)"
  by (metis (no_types, lifting) Sup'_interval atLeastLessThan_iff equalityI mem_Collect_eq subsetI)

text \<open> The first property tells us that the supremum of an empty set is zero, and the second
  tells us that the supremum of a right open interval is the limit of the interval. \<close>

subsection \<open> Contiguous Functions \<close>

typedef 'a cgf =
  "{f :: real \<rightharpoonup> 'a. (\<exists> i. i \<ge> 0 \<and> dom(f) = {0..<i})}"
proof
  have "\<exists>i::real\<ge>0. {} = {0..<i}"
    by (rule_tac x="0" in exI, auto)
  thus "Map.empty \<in> {f. \<exists>i\<ge>0::real. dom f = {0..<i}}"
    by (auto)
qed

(*<*)
setup_lifting type_definition_cgf
(*>*)

text \<open> We begin our definition of contiguous functions by defining the core type, @{typ "'a cgf"}
  using the Isabelle \textbf{typedef} command. Such a definition creates a new type from a subset
  of an existing type, assuming the subset is non-empty. A contiguous function is a partial function
  from real numbers to some range type @{typ "'a"}, such that there is a non-negative @{term i} that gives
  the "end point" of the contiguous function. Specifically, the domain is the right-open interval
  @{term "{0..<i}"}, which in pure mathematics is usually written as [0,i). \<close>

lift_definition cgf_apply :: "'a cgf \<Rightarrow> real \<Rightarrow> 'a" ("\<langle>_\<rangle>\<^sub>C") is "\<lambda> f x. the (f x)" .
lift_definition cgf_dom :: "'a cgf \<Rightarrow> real set" ("dom\<^sub>C") is dom .
lift_definition cgf_end :: "'a cgf \<Rightarrow> real" ("end\<^sub>C") is "\<lambda> f. Sup'(dom(f))" .
lift_definition cgf_map :: "(real \<times> 'a \<Rightarrow> 'b) \<Rightarrow> 'a cgf \<Rightarrow> 'b cgf" ("map\<^sub>C")
  is "\<lambda> f g x. if (x \<in> dom(g)) then Some (f (x, the(g(x)))) else None"
  by (auto simp add: dom_if)

abbreviation "map'\<^sub>C f \<equiv> cgf_map (\<lambda> (i, x). f x)"

lift_definition cgf_restrict :: "'a cgf \<Rightarrow> real \<Rightarrow> 'a cgf" (infix "\<restriction>\<^sub>C" 85)
is "\<lambda> f i. f |` {0..<i}"
  by (auto simp add: min_def, blast, metis atLeastLessThan_empty_iff2 less_eq_real_def less_irrefl)

lift_definition cgf_force :: "'a cgf \<Rightarrow> real \<Rightarrow> 'a cgf" (infix "!\<^sub>C" 85)
is "\<lambda> f i x. if (0 \<le> x \<and> x < i) then Some(the(f(x))) else None"
  apply (rename_tac f n)
  apply (case_tac "n \<ge> 0")
  apply (auto simp add: dom_if)
done

lemma cgf_end_alt_def:
  "end\<^sub>C(f) = Inf ({0..} - dom\<^sub>C(f))"
  by (transfer, auto, metis Diff_iff atLeastLessThan_iff atLeast_iff cInf_eq_minimum le_less_linear not_less_iff_gr_or_eq)

text \<open> We also create functions that allow various manipulations on contiguous functions by
  lifting functions on the underlying partial function type. Function @{term cgf_apply}, also
  written as @{term "\<langle>f\<rangle>\<^sub>C"}, allows the application of a contiguous function to an input real number.
  When the input is outside of the domain, and arbitrary value is returned. @{term cgf_dom}
  (@{term "dom\<^sub>C(f)"}) gives the domain of function, and @{term [source] cgf_end} (@{term "end\<^sub>C(f)"}) returns
  the end point. Term (@{term "map\<^sub>C f g"}) applies a function to every element
  in the range, like a typical map function. Finally, @{term [source] cgf_restrict} (@{term "f \<restriction>\<^sub>C i"}) restricts
  the domain of a contiguous function to the interval [0,i), and @{term cgf_force} (@{term "f !\<^sub>C i"}) has
  a similar effect but forces the function to be extended if necessary. If the function is required
  to extend then the range will be filled with arbitrary values. \<close>

instantiation cgf :: (type) zero
begin
  lift_definition zero_cgf :: "'a cgf" is Map.empty by (auto)
instance ..
end

abbreviation (input) cgf_empty :: "'a cgf" ("[]\<^sub>C") where "[]\<^sub>C \<equiv> 0"

text \<open> We will now define the algebraic operators of timed traces, with which we will be able to
  instantiate our theory of generalised reactive designs with, and thence produce timed reactive designs. We do
  this by instantiating various type classes towards showing that contiguous functions form a
  cancellative monoid, which is the underlying trace algebra. The zero element is the empty
  contiguous function, obtained by lifting the empty partial function
  and demonstrating (as before) that this satisfies the invariant of a contiguous function. We
  also give the zero element the syntax @{term [source] "[]\<^sub>C"}. \<close>

instantiation cgf :: (type) plus
begin

lift_definition plus_cgf :: "'a cgf \<Rightarrow> 'a cgf \<Rightarrow> 'a cgf"
is "\<lambda> f g. (g \<ggreater> Sup'(dom(f))) ++ f"
proof -
  fix f g :: "real \<rightharpoonup> 'a"
  assume "\<exists>i\<ge>0. dom f = {0..<i}" "\<exists>j\<ge>0. dom g = {0..<j}"
  then obtain i j where ij: "i \<ge> 0" "j \<ge> 0" "dom f = {0..<i}" "dom g = {0..<j}"
    by auto
  let ?k = "i + j"
  from ij have "?k \<ge> 0"
    by auto
  moreover from ij have "dom ((g \<ggreater> Sup' (dom f)) ++ f) = {0..<?k}"
    by (auto simp add: dom_shift_minus)
  ultimately show "\<exists>i\<ge>0. dom ((g \<ggreater> Sup' (dom f)) ++ f) = {0..<i}"
    by force
qed
instance ..

end

abbreviation (input) cgf_cat :: "'a cgf \<Rightarrow> 'a cgf \<Rightarrow> 'a cgf" (infixl "@\<^sub>C" 85)
where "xs @\<^sub>C ys \<equiv> xs + ys"

text \<open> We next define the concatenation operator, which in our algebra is a plus operator. The
  concatentation of functions, @{term [source] "f @\<^sub>C g"}, takes @{term g}, shifts it to the right by
  the length of @{term f}, and finally unions this with @{term f} using the partial function
  operator @{term "(++)"}. It is necessary to show that this definition is closed under contiguous functions,
  i.e. we must demonstrate an $k$ such that the domain of @{term [source] "f @\<^sub>C g"} is $[0..k)$, which we do
  using an Isar proof. Since we're concatentating two functions of length $i$ and $j$, respectively,
  then their combined length will be $i + j$, which our proof confirms. \<close>

lemma cgf_cat_left_unit [simp]: "[]\<^sub>C @\<^sub>C t = t"
  by (transfer, simp)

lemma cgf_cat_right_unit [simp]: "t @\<^sub>C []\<^sub>C = t"
  by (transfer, auto)

text \<open> We can then show that the concatenation operator has @{term "[]\<^sub>C"} as its left and right
  zeros. \<close>

lemma cgf_eqI: "\<lbrakk> end\<^sub>C f = end\<^sub>C g; \<And> t. \<lbrakk> 0 \<le> t; t <end\<^sub>C g \<rbrakk> \<Longrightarrow> \<langle>f\<rangle>\<^sub>C t = \<langle>g\<rangle>\<^sub>C t \<rbrakk> \<Longrightarrow> f = g"
  apply (transfer)
  apply (auto)
  apply (rename_tac f g i j)
  apply (case_tac "i = 0")
  apply (simp_all)
  using less_eq_real_def apply auto[1]
  apply (case_tac "j = 0")
  apply (auto)
  apply (rule map_eqI)
  apply (auto)
done

text \<open> Lemma @{thm [source] cgf_eqI} is an extensionality principle for contiguous functions. If two
  $f$ and $g$ have the same end points, and they agree on every value before these end points
  then the two functions are the same. \<close>

lemma cgf_end_ge_0 [simp]: "end\<^sub>C(f) \<ge> 0"
  by (transfer, auto simp add: less_eq_real_def)

lemma cgf_end_empty [simp]: "end\<^sub>C([]\<^sub>C) = 0"
  by (transfer, simp)

lemma cgf_end_0_iff: "end\<^sub>C(f) = 0 \<longleftrightarrow> f = []\<^sub>C"
  by (transfer, force simp add: antisym_conv2)

lemma cgf_end_cat: "end\<^sub>C(f @\<^sub>C g) = end\<^sub>C(f)+end\<^sub>C(g)"
  by (transfer, auto simp add: dom_shift_minus)

text \<open> Next we demonstrate some properties about the @{term end\<^sub>C} function. It always returns
  a positive value (@{thm [source] cgf_end_ge_0}), the end of the empty function is 0 (@{thm [source] cgf_end_empty}),
  if a function has 0 as its end then it is equal to @{term "[]\<^sub>C"} (@{thm [source] cgf_end_0_iff}), and the
  end of a concatenation is the sum of the two ends (@{thm [source] cgf_end_cat}). \<close>

lemma cgf_cat_ext_first:
  assumes "x < end\<^sub>C f"
  shows "\<langle>f @\<^sub>C g\<rangle>\<^sub>C x = \<langle>f\<rangle>\<^sub>C x"
proof (cases "f = []\<^sub>C")
  case True with assms show ?thesis
    by (transfer, auto, metis atLeastLessThan_iff domIff less_le_not_le)
next
  case False with assms show ?thesis
    by (transfer, auto simp add: map_add_def option.case_eq_if)
       (metis atLeastLessThan_iff domIff less_iff_diff_less_0 not_less)
qed

lemma cgf_cat_ext_last: "x \<ge> end\<^sub>C f \<Longrightarrow> \<langle>f @\<^sub>C g\<rangle>\<^sub>C x = \<langle>g\<rangle>\<^sub>C (x - end\<^sub>C f)"
  by (transfer, auto simp add: map_add_dom_app_simps(3))

text \<open> Lemmas @{thm [source] cgf_cat_ext_first} and @{thm [source] cgf_cat_ext_last} show the effect of applying
  an input $x$ to an appended trace. If $x$ is less than the end of the first trace, then this
  is equivalent to applying it to the first trace. Otherwise, if $x$ is greater than or equal
  to the end of the first, then the result is to apply to the second, but with the input shifted. \<close>

lemma cgf_zero_sum_left:
  "f @\<^sub>C g = []\<^sub>C \<Longrightarrow> f = []\<^sub>C"
  by (metis cgf_cat_right_unit cgf_end_0_iff cgf_end_cat cgf_end_ge_0
            dual_order.antisym le_add_same_cancel2)

text \<open> The next lemma tells us that if two functions concatenate to become the empty function then the
  first must be empty. Now by the fact that @{term "[]\<^sub>C"} is a left unit we can also show that
  the second must also be empty. \<close>

lemma cgf_cat_left_imp_eq:
  assumes "f @\<^sub>C g = f @\<^sub>C h"
  shows "g = h"
using assms proof (transfer)
  fix f g h :: "real \<rightharpoonup> 'a"
  assume a:
    "\<exists>i\<ge>0. dom f = {0..<i}" "\<exists>i\<ge>0. dom g = {0..<i}" "\<exists>i\<ge>0. dom h = {0..<i}"
    "(g \<ggreater> Sup' (dom f)) ++ f = (h \<ggreater> Sup' (dom f)) ++ f"
  then obtain i j k where ijk:
    "i \<ge> 0" "j \<ge> 0" "k \<ge> 0" "dom f = {0..<i}" "dom g = {0..<j}" "dom h = {0..<k}"
    by auto
  show "g = h"
  proof (cases "i > 0")
    case False with ijk a(4) show ?thesis
      by (auto)
  next
    case True
    with ijk have "dom(g \<ggreater> i) \<inter> {0..<i} = {}"
      by (auto simp add: dom_shift_minus)
    moreover from True ijk have "dom(h \<ggreater> i) \<inter> {0..<i} = {}"
      by (auto simp add: dom_shift_minus)
    ultimately show ?thesis using True ijk a(4)
      by (auto dest!: map_plus_eq_left shift_minus_cong simp add: restrict_map_neg_disj dom_shift_minus)
  qed
qed

text \<open> Lemma @{thm [source] cgf_cat_left_imp_eq} shows that concatenation is cancellative in its first argument.
  Intuitively this means that a trace can be uniquely decomposed into its constituent parts and
  is one of the key properties of the trace algebra of generalised reactive processes. \<close>

lemma cgf_cat_right_imp_eq:
  assumes "f @\<^sub>C h = g @\<^sub>C h"
  shows "f = g"
proof -
  have ends: "end\<^sub>C(f) = end\<^sub>C(g)"
    by (metis add.commute add_left_cancel assms cgf_end_cat)
  show ?thesis
  proof (cases "f = []\<^sub>C")
    case True
    hence "g = []\<^sub>C"
      using cgf_end_0_iff ends by auto
    with True show ?thesis ..
  next
    case False
    with assms ends show ?thesis
    proof (transfer)
      fix f g h :: "real \<rightharpoonup> 'a"
      assume a: "\<exists>i\<ge>0. dom f = {0..<i}" "\<exists>i\<ge>0. dom g = {0..<i}" "\<exists>i\<ge>0. dom h = {0..<i}"
             "(h \<ggreater> Sup' (dom f)) ++ f = (h \<ggreater> Sup' (dom g)) ++ g"
             "(Sup' (dom f)) = (Sup' (dom g))"
             "f \<noteq> Map.empty"
      hence "dom f = dom g"
        by (metis Sup'_interval atLeastLessThan_empty not_le)
      with a obtain i j where "dom f = {0..<i}" "dom g = {0..<i}" "dom h = {0..<j}"
        by (auto)
      moreover with a have "i > 0"
        by (auto)
      ultimately show "f = g" using a(4)
        by (simp, metis (mono_tags, lifting) map_eqI map_le_def map_le_map_add)
    qed
  qed
qed

text \<open> Similarly, we show that concatenation is cancellative in its second argument. \<close>

lemma cgf_cat_assoc: "(f @\<^sub>C g) @\<^sub>C h = f @\<^sub>C (g @\<^sub>C h)"
proof (rule cgf_eqI, simp_all add: cgf_end_cat add.assoc)
  fix x
  assume x: "x < end\<^sub>C f + (end\<^sub>C g + end\<^sub>C h)"
  show "\<langle>f @\<^sub>C g @\<^sub>C h\<rangle>\<^sub>C x = \<langle>f @\<^sub>C (g @\<^sub>C h)\<rangle>\<^sub>C x"
  proof (cases "x < end\<^sub>C f")
    case True thus ?thesis
      by (metis (mono_tags, opaque_lifting) add.right_neutral add_less_cancel_left
                cgf_cat_ext_first cgf_end_cat cgf_end_ge_0 le_less_trans not_le)
  next
    case False
    hence x_gef: "x \<ge> end\<^sub>C f"
      by auto
    thus ?thesis
    proof (cases "x < end\<^sub>C f+end\<^sub>C g")
      case True thus ?thesis
        by (simp add: add_less_imp_less_left cgf_cat_ext_first cgf_cat_ext_last cgf_end_cat x_gef)
    next
      case False
      hence x_gefg: "x \<ge> end\<^sub>C f+end\<^sub>C g"
        by auto
      thus ?thesis
        by (simp add: cgf_cat_ext_last cgf_end_cat cancel_ab_semigroup_add_class.diff_diff_add
                      add_le_imp_le_diff x_gef)
    qed
  qed
qed

text \<open> Another key property is associativity of concatenation, which is demonstrated above. We prove
  this by extensionality, and split the proof into values of the index $x$ that fall within the
  three concatenated sections of the contiguous function. This allows us to show, below, that
  contiguous functions form a monoid. \<close>

instance cgf :: (type) monoid_add
  by (intro_classes, simp_all add: cgf_cat_assoc)

instantiation cgf :: (type) ord
begin
  lift_definition less_eq_cgf :: "'a cgf \<Rightarrow> 'a cgf \<Rightarrow> bool" is
  "(\<subseteq>\<^sub>m)" .
  definition less_cgf :: "'a cgf \<Rightarrow> 'a cgf \<Rightarrow> bool" where
  "less_cgf x y = (x \<le> y \<and> \<not> y \<le> x)"
instance ..
end

text \<open> We can also construct a suitably order relation on contiguous functions by lifting of the
  corresponding order on partial functions, @{term "(\<subseteq>\<^sub>m)"}, which corresponds to the subset
  operator when considering the function as a relation. \<close>

abbreviation (input) cgf_prefix :: "'a cgf \<Rightarrow> 'a cgf \<Rightarrow> bool" (infix "\<subseteq>\<^sub>C" 50)
where "f \<subseteq>\<^sub>C g \<equiv> f \<le> g"

text \<open> We give the alternative notation of @{term "f \<subseteq>\<^sub>C g"} to the function order to highlight
  its role as a subset-like operator. \<close>

lemma monoid_le_ttrace:
  "(f :: 'a cgf) \<le>\<^sub>m g \<longleftrightarrow> f \<le> g"
  apply (simp add: monoid_le_def, transfer, auto)
  apply (rename_tac g f i j)
  apply (rule_tac x="j \<lless> (g |` {j..<i})" in exI)
  apply (auto simp add: dom_shift_plus)
  apply (rule_tac x="i-j" in exI)
  apply (auto)
  using map_le_implies_dom_le apply fastforce
  apply (metis add.commute add_increasing cancel_ab_semigroup_add_class.add_diff_cancel_left'
               less_diff_eq less_eq_real_def)
  apply (subgoal_tac "f = g |` {0..<j}")
  apply (simp)
  apply (subst map_add_split, auto)
  apply (simp add: map_le_via_restrict)
done

lemma cgf_prefix_iff: "f \<le> g \<longleftrightarrow> (\<exists> h. g = f @\<^sub>C h)"
  apply (transfer, auto)
   apply (rename_tac f g i j)
   apply (rule_tac x="i \<lless> (g |` {i..<j})" in exI)
   apply (auto simp add: dom_shift_plus)
   apply (rule_tac x="j-i" in exI)
   apply (auto)
  using map_le_implies_dom_le apply fastforce
   apply (metis (no_types, opaque_lifting) Groups.add_ac(2) add.right_neutral add_diff_cancel_right' add_mono_thms_linordered_field(1) diff_add_cancel diff_left_mono dual_order.trans le_less_linear order.asym)
  apply (case_tac "i < j")
   apply (auto)
   apply (metis atLeastLessThan_union_disj less_eq_real_def map_add_split map_le_iff_map_add_commute map_le_via_restrict)
  apply (metis (full_types) dual_order.trans ivl_subset less_eq_real_def map_le_implies_dom_le map_le_refl map_le_via_restrict)
done

lemma cgf_sub_cat_cases: "f \<subseteq>\<^sub>C g @\<^sub>C h \<Longrightarrow> f \<subseteq>\<^sub>C g \<or> g \<subseteq>\<^sub>C f"
  apply (transfer, auto)
  apply (rename_tac f g h i j k)
  apply (case_tac "0 < j")
  apply (auto)
  apply (case_tac "i \<le> j")
  apply (auto simp add: map_le_def)
done

lemma cgf_sum_eq_sum_conv:
  "a @\<^sub>C b = c @\<^sub>C d \<Longrightarrow> \<exists>e. a = c @\<^sub>C e \<and> e @\<^sub>C b = d \<or> a @\<^sub>C e = c \<and> b = e @\<^sub>C d"
  by (metis cgf_cat_assoc cgf_cat_left_imp_eq cgf_prefix_iff cgf_sub_cat_cases)

instantiation cgf :: (type) trace_split
begin
  definition minus_cgf :: "'a cgf \<Rightarrow> 'a cgf \<Rightarrow> 'a cgf" where
  "minus_cgf x y = x -\<^sub>m y"
instance
  apply (intro_classes)
  using cgf_cat_left_imp_eq apply blast
  using cgf_zero_sum_left apply blast
  apply (simp add: monoid_le_ttrace)
  apply (simp add: less_cgf_def)
   apply (simp add: minus_cgf_def)
  apply (simp add: cgf_sum_eq_sum_conv)
done
end

text \<open> Thus we can show that our operators form a trace algebra. In order to show this we
  also have to construct the subtraction operator which we obtain from the derived monoidal subtraction, $x -_m y$. \<close>

lemma cgf_sub_end:
  assumes "f \<le> g"
  shows "end\<^sub>C f \<le> end\<^sub>C g"
proof -
  obtain f' where "g = f + f'"
    by (meson assms monoid_le_def monoid_le_ttrace)
  thus ?thesis
    by (simp add: cgf_end_cat)
qed

lemma cgf_dom_empty [simp]: "dom\<^sub>C([]\<^sub>C) = {}"
  by (transfer, simp)

lemma cgf_dom: "dom\<^sub>C(f) = {0..<end\<^sub>C f}"
  apply (cases "f = []\<^sub>C")
  apply (auto)
  apply (transfer, auto)
  apply (transfer, auto)
  using less_eq_real_def apply auto[1]
  apply (transfer, auto)
  using less_eq_real_def apply auto
done

text \<open> We now show a few more properties about the domain of a contiguous function, namely that
  the @{term "map\<^sub>C"} function is domain preserving, that the domain of an empty function is empty,
  and that the domain of a function is the set [0..end(f)). \<close>

lemma cgf_prefix_dom:
  "f \<subseteq>\<^sub>C g \<Longrightarrow> dom\<^sub>C(f) \<subseteq> dom\<^sub>C(g)"
  by (simp add: cgf_dom cgf_sub_end)

text \<open> If function $f$ is a subfunction of $g$ then $f$ can be no longer than $g$. Similarly,
  the domeain of the $f$ would be a subset of the domain of $g$. \<close>

lemma cgf_restrict_le: "t \<restriction>\<^sub>C n \<le> t"
  by (transfer, auto simp add: map_le_def)

lemma cgf_end_restrict [simp]: "\<lbrakk> 0 \<le> n; n \<le> end\<^sub>C f \<rbrakk> \<Longrightarrow> end\<^sub>C (f \<restriction>\<^sub>C n) = n"
  by (transfer, auto)

lemma cgf_restrict_less: "\<lbrakk> 0 \<le> n ; n < end\<^sub>C(t) \<rbrakk> \<Longrightarrow> t \<restriction>\<^sub>C n < t"
  by (metis cgf_end_restrict cgf_restrict_le dual_order.strict_iff_order)

text \<open> Restriction yields a function which is guaranteed to be no longer than the original,
  and is strictly less than the original provided that $n$ is positive and is less than the original
  length. \<close>

lemma cgf_left_mono_iff: "f @\<^sub>C g \<le> f @\<^sub>C h \<longleftrightarrow> g \<le> h"
  using add_le_imp_le_left add_left_mono by blast

text \<open> The next two facts are simply derived from the trace algebra: the alternative definition
  of prefix, and that concatenation is monotone in its second argument. \<close>

lemma cgf_end_map [simp]: "end\<^sub>C (map\<^sub>C f g) = end\<^sub>C g"
  by (transfer, auto simp add: dom_if)

lemma cgf_restrict_empty [simp]: "[]\<^sub>C \<restriction>\<^sub>C n = []\<^sub>C"
  by (transfer, simp)

text \<open> We also show some properties about the restriction operator: restricting an empty
  function has no effect, and the end of a restricted function yields the request end value,
  provided that the function is no shorter than this value. \<close>

lemma cgf_end_force [simp]: "n \<ge> 0 \<Longrightarrow> end\<^sub>C (f !\<^sub>C n) = n"
  apply (transfer, auto simp add: dom_if)
  apply (rename_tac n f i)
  apply (subgoal_tac "{x. 0 \<le> x \<and> x < n} = {0..<n}")
  apply (auto)
done

text \<open> Conversley, forcing a function to be a particular length will always yield a function of
  that length. \<close>

lemma cgf_map_indep:
  "end\<^sub>C f = end\<^sub>C g \<Longrightarrow> map\<^sub>C (\<lambda>(i, x). \<langle>g\<rangle>\<^sub>C i) f = g"
  apply (transfer, auto, rule ext, auto)
  apply (metis (mono_tags) atLeastLessThan_iff domD not_le option.sel)
  apply fastforce
  apply (metis atLeastLessThan_iff domIff less_eq_real_def)
done

text \<open> The above property shows that mapping a function to take the values of another function
  of the same length will yield exactly the latter contiguous function. \<close>

lemma cgf_restrict_map [simp]: "(map\<^sub>C f g) \<restriction>\<^sub>C n = map\<^sub>C f (g \<restriction>\<^sub>C n)"
  apply (transfer, auto simp add: restrict_map_def, rule ext, auto simp add: domD)
  apply (metis atLeastLessThan_iff domI option.distinct(1))
done

text \<open> Restriction also distributes through contiguous function maps. \<close>

lemma cgf_restrict_restrict [simp]: "(g \<restriction>\<^sub>C m) \<restriction>\<^sub>C n = g \<restriction>\<^sub>C (min m n)"
  apply (auto simp add: min_def)
  apply (transfer, auto)
  apply (transfer, auto simp add: min_def)
done

text \<open> Restricting a function twice yields a restriction with the minimum value of the two restrictions. \<close>

lemma cgf_map_empty [simp]:
  "map\<^sub>C f []\<^sub>C = []\<^sub>C"
  by (transfer, simp)

text \<open> Mapping over an empty function yields an empty function. \<close>

lemma cgf_map_apply [simp]:
  assumes "0 \<le> x" "x < end\<^sub>C(g)"
  shows "\<langle>map\<^sub>C f g\<rangle>\<^sub>C x = f (x, \<langle>g\<rangle>\<^sub>C x)"
proof -
  have "x \<in> dom\<^sub>C(g)"
    using assms cgf_dom by fastforce
  thus ?thesis
    by (transfer, auto simp add: dom_if)
qed

text \<open> Application of a value $x$ to a contiguous function mapped through $g$ is equivalent to
  applying the function to the given value and function value at that point. \<close>

lemma cgf_map_map: "map\<^sub>C f (map\<^sub>C g h) = map\<^sub>C (\<lambda> (i, x). f (i, g (i, x))) h"
  by (transfer, auto simp add: dom_if)

definition cgf_lens :: "('a cgf \<Longrightarrow> '\<alpha>) \<Rightarrow> ('b \<Longrightarrow> 'a) \<Rightarrow> ('b cgf \<Longrightarrow> '\<alpha>)" where
[lens_defs]: "cgf_lens X Y =
  \<lparr> lens_get = \<lambda> s. map'\<^sub>C get\<^bsub>Y\<^esub> (get\<^bsub>X\<^esub> s)
  , lens_put = \<lambda> s v. put\<^bsub>X\<^esub> s (map\<^sub>C (\<lambda> (i, x). put\<^bsub>Y\<^esub> x (\<langle>v\<rangle>\<^sub>C i)) (get\<^bsub>X\<^esub> s !\<^sub>C (end\<^sub>C v))) \<rparr>"

lemma cgf_weak_lens: "\<lbrakk> weak_lens X; weak_lens Y \<rbrakk> \<Longrightarrow> weak_lens (cgf_lens X Y)"
  by (unfold_locales, auto simp add: cgf_lens_def cgf_map_map cgf_map_indep)

text \<open> Finally we show a few properties about subtraction that are also derived from the trace
  algebra. \<close>

lemma cgf_cat_minus_prefix:
  "f \<le> g \<Longrightarrow> g = f @\<^sub>C (g - f)"
  by (simp add: diff_add_cancel_left')

lemma cgf_apply_minus [simp]: "\<lbrakk> 0 \<le> x; f \<le> g \<rbrakk> \<Longrightarrow> \<langle>g - f\<rangle>\<^sub>C x = \<langle>g\<rangle>\<^sub>C (x + end\<^sub>C(f))"
  by (metis add_diff_cancel cgf_cat_ext_last cgf_cat_minus_prefix le_add_same_cancel2)

lemma cgf_end_minus: "g \<le> f \<Longrightarrow> end\<^sub>C(f-g) = end\<^sub>C(f)-end\<^sub>C(g)"
  by (auto simp add: cgf_prefix_iff cgf_end_cat)

lemma list_concat_minus_list_concat: "(f @\<^sub>C g) - (f @\<^sub>C h) = g - h"
  using trace_class.add_diff_cancel_left' by blast

text \<open> The following function constructs a contiguous function from a given end point and total
  function. \<close>

lift_definition cgf_mk :: "real \<Rightarrow> (real \<Rightarrow> 'a) \<Rightarrow> 'a cgf" ("mk\<^sub>C") is
"\<lambda> l f. [t \<mapsto> f t | t. 0 \<le> t \<and> t < l]"
  apply (auto simp add: graph_map_dom)
  apply (rename_tac l f)
  apply (case_tac "l < 0")
  apply (rule_tac x="0" in exI)
  apply (simp)
  apply (rule_tac x="l" in exI)
  apply (auto simp add: image_iff)
done

lemma cgf_mk_apply [simp]: "\<lbrakk> 0 \<le> x; x < l \<rbrakk> \<Longrightarrow> \<langle>mk\<^sub>C l f\<rangle>\<^sub>C x = f x"
  by (transfer, simp)

lemma cgf_mk_end [simp]:
  "0 \<le> l \<Longrightarrow> end\<^sub>C(mk\<^sub>C l f) = l"
  by (transfer, simp add: Sup'_interval')

lemma cgf_mk_le_0 [simp]: "l \<le> 0 \<Longrightarrow> mk\<^sub>C l f = []\<^sub>C"
  by (transfer, auto)

(*<*)
end
(*>*)