theory Paxos
imports Main LTL
begin

record 'v Propose =
  valPropose :: 'v

record Prepare =
  balPrepare :: nat

record 'v Promise =
  rndPromise :: nat
  vrndPromise :: "nat option"
  vvalPromise :: "'v option"

record 'v Accept =
  iAccept :: nat
  vAccept :: 'v

record 'v Learn =
  iLearn :: nat
  vLearn :: 'v

datatype 'v Message
  = Propose "'v Propose"
  | Prepare Prepare
  | Promise "'v Promise"
  | Accept "'v Accept"
  | Learn "'v Learn"

record 'v Proposer =
  crndProposer :: nat
  cvalProposer :: 'v
  PProposer :: "(nat option \<times> 'v option) set"

record 'v Acceptor =
  rndAcceptor :: "nat option"
  vrndAcceptor :: "nat option"
  vvalAcceptor :: "'v option"

record 'v Learner =
  VLearner :: "(nat \<times> 'v) list"

record 'v Paxos =
  msgs :: "'v Message set"
  proposer :: "'v Proposer"
  acceptors :: "'v Acceptor list"
  learner :: "'v Learner"
  chosen :: "'v option"
  proposed :: "'v set"

locale Paxos =
  fixes P :: "('v, 'p) Paxos_scheme" (structure)
  and pickNextRound
  and pick

  assumes proposer_propose: "\<exists>val.
  \<Turnstile>
    Latom (Propose \<lparr> valPropose = val \<rparr> \<in> msgs P) \<union>t
    Latom (
      let crnd_next = pickNextRound (crndProposer (proposer P)) in
      Prepare \<lparr> balPrepare = crnd_next \<rparr> \<in> msgs P \<and>
      val \<in> proposed P \<and>
      proposer P = \<lparr> crndProposer = crnd_next, cvalProposer = val, PProposer = {} \<rparr>
    )
  "
  and proposer_promise: "\<exists>rnd vrnd vval.
  \<Turnstile>
    Latom (
      Promise \<lparr> rndPromise = rnd, vrndPromise = vrnd, vvalPromise = vval \<rparr> \<in> msgs P \<and>
      crndProposer (proposer P) = rnd
    ) \<union>t
    Latom (
      (vrnd,vval) \<in> PProposer (proposer P)
    )
  "
  and proposer_accept: "\<exists>ps.
  \<Turnstile>
    Latom (
      PProposer (proposer P) = ps \<and>
      card (PProposer (proposer P)) \<ge> size (acceptors P) - size (acceptors P) div 2
    ) \<union>t
    Latom (
      let j = Max (these {vrnd. (vrnd,vval) \<in> ps}) in
      if j \<ge> 0 then cvalProposer (proposer P) = pick (snd ` {xy. xy \<in> ps \<and> fst xy = Some j}) else True \<and>
      Accept \<lparr> iAccept = crndProposer (proposer P), vAccept = cvalProposer (proposer P) \<rparr> \<in> msgs P
    )
  "

  assumes acceptor_prepare: "\<exists>prnd acc.
  \<Turnstile>
    Latom (
      Prepare \<lparr> balPrepare = prnd \<rparr> \<in> msgs P \<and>
      map_option (\<lambda>rnd. prnd > rnd) (rndAcceptor (acceptors P ! acc)) = Some(True)
    ) \<union>t
    Latom (
      let acceptor = acceptors P ! acc in
      Promise \<lparr> rndPromise = prnd, vrndPromise = vrndAcceptor acceptor, vvalPromise = vvalAcceptor acceptor \<rparr> \<in> msgs P \<and>
      rndAcceptor (acceptors P ! acc) = Some(prnd)
    )
  "
  and acceptor_accept: "\<exists>i v acc.
  \<Turnstile>
    Latom (
      Accept \<lparr> iAccept = i, vAccept = v \<rparr> \<in> msgs P \<and>
      map_option (\<lambda>rnd. i \<ge> rnd) (rndAcceptor (acceptors P ! acc)) = Some(True)
    ) \<union>t
    Latom (
      acceptors P ! acc = \<lparr> rndAcceptor = Some i, vrndAcceptor = Some i, vvalAcceptor = Some v \<rparr> \<and>
      Learn \<lparr> iLearn = i, vLearn = v \<rparr> \<in> msgs P
    )
  "

  assumes learner_learn: "\<exists>i v vs.
  \<Turnstile>
    Latom (
      Learn \<lparr> iLearn = i, vLearn = v \<rparr> \<in> msgs P \<and>
      VLearner (learner P) = vs
    ) \<union>t
    Latom (
      VLearner (learner P) = (i,v) # vs
    )
  "
  and learner_choose: "\<exists>i v.
  \<Turnstile>
    Latom (
      size (find (\<lambda>pair. pair = (i,v)) (VLearner (learner P))) \<ge> size (acceptors P) - size (acceptors P) div 2
    ) \<union>t
    Latom (
      chosen P = Some(v)
    )
  "

theorem CS1: "\<Turnstile> \<box> (\<not>t Latom (Option.is_none (chosen P)) \<rightarrow>t Latom (the (chosen P) \<in> proposed P))"
  sorry

theorem CS2: "\<not> (\<exists>v1 v2. v1 \<noteq> v2 \<and> \<Turnstile> Latom (chosen P = Some(v1)) \<union>t Latom (chosen P = Some(v2)))"
  sorry

theorem CS3: "\<exists>i. \<Turnstile> \<box> (\<not>t Latom (Option.is_none (chosen P)) \<rightarrow>t Latom (Learn \<lparr> iLearn = i, vLearn = the (chosen P) \<rparr> \<in> msgs P))"
  sorry

end


theory MoreTesting
  imports Main

begin
  lemma functional_increasing:
    fixes f :: "nat \<Rightarrow> nat"
    assumes asm: "\<forall>n. f(f n) < f(n + 1)"
    shows "n \<le> m \<Longrightarrow> f n \<le> f m"
  sorry

  lemma functional_leq:
    fixes f :: "nat \<Rightarrow> nat"
    assumes asm: "\<forall>n. f(f n) < f(n + 1)"
    shows "n \<le> f n"
  proof(induct "n")
    case 0
    show ?case by auto
  next
    case (Suc n)
    fix n
    show "n \<le> f n \<Longrightarrow> Suc n \<le> f (Suc n)"
    proof-
      assume IH: "n \<le> f n"
      hence "f n \<le> f(f n)" using functional_increasing [of "f" "n" "f n"] asm by auto
      hence ineq1: "n \<le> f(f n)" using IH by auto
      have ineq2: "f(f n) < f(n + 1)" using asm by auto
      hence "n < f(n + 1)" using ineq1 ineq2 by auto
      thus "Suc n \<le> f(Suc n)" by auto
    qed
  qed
end


theory BDD_intersect
  imports Main BDD_basic BDD_select
begin

fun intersect :: "BDD \<Rightarrow> BDD \<Rightarrow> BDD" where
  "intersect Nothing _ = Nothing" |
  "intersect Top b = b" |
  "intersect (Select _ _ _) Nothing = Nothing" |
  "intersect (Select va ta ea) Top = (Select va ta ea)" |
  "intersect (Select va ta ea) (Select vb tb eb) =
     (if va > vb then
        select va (intersect ta (Select vb tb eb)) (intersect ea (Select vb tb eb))
      else if va = vb then
        select va (intersect ta tb) (intersect ea eb)
      else
        select vb (intersect (Select va ta ea) tb) (intersect (Select va ta ea) eb))"

lemma intersect_simp_Nothing: "intersect a Nothing = Nothing"
  apply (induction a)
  by auto

lemma intersect_simp_Top: "intersect a Top = a"
  apply (induction a)
  by auto

theorem ordered_intersect: "ordered n a \<Longrightarrow> ordered n b \<Longrightarrow> ordered n (intersect a b)"
  apply (induction a b arbitrary: n rule: intersect.induct)
  apply simp_all
  apply auto
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) ordered.simps ordered_select)
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject ordered.simps ordered_select)
  by (metis BDD.distinct(6) BDD.inject BDD.simps(5) antisym_conv3 ordered.simps ordered_select)

theorem dup_free_intersect: "norm n a \<Longrightarrow> norm n b \<Longrightarrow> norm n (intersect a b)"
  apply (induction a b arbitrary: n rule: intersect.induct)
  apply simp
  apply simp
  apply simp
  apply simp
  (* Even a simp here really gets stuck for a long time. *)
  apply (case_tac "vb < va")
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) intersect.simps(5) norm.simps norm_select)
  apply (case_tac "vb = va")
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) intersect.simps(5) norm.simps norm_select)
  by (metis BDD.inject BDD.simps(5) BDD.simps(7) antisym_conv3 intersect.simps(5) norm.simps norm_select)

theorem intersect_correct: "contains (intersect a b) f = (contains a f \<and> contains b f)"
  apply (induction a b arbitrary: f rule: intersect.induct)
  apply fastforce
  apply fastforce
  apply fastforce
  apply fastforce
  by (smt (z3) BDD_select.select_def contains_p.simps(3) contains_p_correct intersect.simps(5))

end


(*<*)
theory Code_Double
  imports IEEE_Floating_Point.IEEE_Properties
    IEEE_Floating_Point.Conversion_IEEE_Float
    "HOL-Library.Code_Target_Int"
    Containers.Collection_Eq
    Containers.Collection_Order
begin
(*>*)

section \<open>Code adaptation for IEEE double-precision floats\<close>

subsection \<open>copysign\<close>

lift_definition copysign :: "('e, 'f) float \<Rightarrow> ('e, 'f) float \<Rightarrow> ('e, 'f) float" is
  "\<lambda>(_, e::'e word, f::'f word) (s::1 word, _, _). (s, e, f)" .

subsection \<open>Additional lemmas about generic floats\<close>

lemma is_nan_some_nan[simp]: "is_nan (some_nan :: ('e, 'f) float)"
  unfolding some_nan_def
  by (rule someI[where x="Abs_float (0, max_word :: 'e word, 1)"])
    (auto simp add: is_nan_def exponent_def fraction_def emax_def Abs_float_inverse[simplified])

lemma not_is_nan_0[simp]: "\<not> is_nan 0"
  unfolding is_nan_def by (simp add: zero_simps)

lemma not_is_nan_1[simp]: "\<not> is_nan 1"
  unfolding is_nan_def by transfer simp

lemma is_nan_plus: "is_nan x \<or> is_nan y \<Longrightarrow> is_nan (x + y)"
  unfolding plus_float_def fadd_def by auto

lemma is_nan_minus: "is_nan x \<or> is_nan y \<Longrightarrow> is_nan (x - y)"
  unfolding minus_float_def fsub_def by auto

lemma is_nan_times: "is_nan x \<or> is_nan y \<Longrightarrow> is_nan (x * y)"
  unfolding times_float_def fmul_def by auto

lemma is_nan_divide: "is_nan x \<or> is_nan y \<Longrightarrow> is_nan (x / y)"
  unfolding divide_float_def fdiv_def by auto

lemma is_nan_float_sqrt: "is_nan x \<Longrightarrow> is_nan (float_sqrt x)"
  unfolding float_sqrt_def fsqrt_def by simp

lemma nan_fcompare: "is_nan x \<or> is_nan y \<Longrightarrow> fcompare x y = Und"
  unfolding fcompare_def by simp

lemma nan_not_less: "is_nan x \<or> is_nan y \<Longrightarrow> \<not> x < y"
  unfolding less_float_def flt_def fcompare_def by simp

lemma nan_not_zero: "is_nan x \<Longrightarrow> \<not> is_zero x"
  unfolding is_nan_def is_zero_def by simp

lemma nan_not_infinity: "is_nan x \<Longrightarrow> \<not> is_infinity x"
  unfolding is_nan_def is_infinity_def by simp

lemma zero_not_infinity: "is_zero x \<Longrightarrow> \<not> is_infinity x"
  unfolding is_zero_def is_infinity_def by simp

lemma zero_not_nan: "is_zero x \<Longrightarrow> \<not> is_nan x"
  unfolding is_zero_def is_nan_def by simp

lemma minus_one_power_one_word: "(-1 :: real) ^ unat (x :: 1 word) = (if unat x = 0 then 1 else -1)"
proof -
  have "unat x = 0 \<or> unat x = 1"
    using le_SucE[OF unat_one_word_le] by auto
  then show ?thesis by auto
qed

definition valofn :: "('e, 'f) float \<Rightarrow> real" where
  "valofn x = (2^exponent x / 2^bias TYPE(('e, 'f) float)) *
      (1 + real (fraction x) / 2^LENGTH('f))"

definition valofd :: "('e, 'f) float \<Rightarrow> real" where
  "valofd x = (2 / 2^bias TYPE(('e, 'f) float)) * (real (fraction x) / 2^LENGTH('f))"

lemma valof_alt: "valof x = (if exponent x = 0 then
    if sign x = 0 then valofd x else - valofd x
  else if sign x = 0 then valofn x else - valofn x)"
  unfolding valofn_def valofd_def
  by transfer (auto simp: minus_one_power_one_word unat_eq_0 field_simps)

lemma fraction_less_2p: "fraction (x :: ('e, 'f) float) < 2^LENGTH('f)"
  by transfer auto

lemma valofn_ge_0: "0 \<le> valofn x"
  unfolding valofn_def by simp

lemma valofn_ge_2p: "2^exponent (x :: ('e, 'f) float) / 2^bias TYPE(('e, 'f) float) \<le> valofn x"
  unfolding valofn_def by (simp add: field_simps)

lemma valofn_less_2p:
  fixes x :: "('e, 'f) float"
  assumes "exponent x < e"
  shows "valofn x < 2^e / 2^bias TYPE(('e, 'f) float)"
proof -
  have "1 + real (fraction x) / 2^LENGTH('f) < 2"
    by (simp add: fraction_less_2p)
  then have "valofn x < (2^exponent x / 2^bias TYPE(('e, 'f) float)) * 2"
    unfolding valofn_def by (simp add: field_simps)
  also have "... \<le> 2^e / 2^bias TYPE(('e, 'f) float)"
    using assms by (auto simp: less_eq_Suc_le field_simps elim: order_trans[rotated, OF exp_less])
  finally show ?thesis .
qed

lemma valofd_ge_0: "0 \<le> valofd x"
  unfolding valofd_def by simp

lemma valofd_less_2p: "valofd (x :: ('e, 'f) float) < 2 / 2^bias TYPE(('e, 'f) float)"
  unfolding valofd_def
  by (simp add: fraction_less_2p field_simps)

lemma valofn_le_imp_exponent_le:
  fixes x y :: "('e, 'f) float"
  assumes "valofn x \<le> valofn y"
  shows "exponent x \<le> exponent y"
proof (rule ccontr)
  assume "\<not> exponent x \<le> exponent y"
  then have "valofn y < 2^exponent x / 2^bias TYPE(('e, 'f) float)"
    using valofn_less_2p[of y] by auto
  also have "... \<le> valofn x" by (rule valofn_ge_2p)
  finally show False using assms by simp
qed

lemma valofn_eq:
  fixes x y :: "('e, 'f) float"
  assumes "valofn x = valofn y"
  shows "exponent x = exponent y" "fraction x = fraction y"
proof -
  from assms show "exponent x = exponent y"
    by (auto intro!: antisym valofn_le_imp_exponent_le)
  with assms show "fraction x = fraction y"
    unfolding valofn_def by (simp add: field_simps)
qed

lemma valofd_eq:
  fixes x y :: "('e, 'f) float"
  assumes "valofd x = valofd y"
  shows "fraction x = fraction y"
  using assms unfolding valofd_def by (simp add: field_simps)

lemma is_zero_valof_conv: "is_zero x \<longleftrightarrow> valof x = 0"
  unfolding is_zero_def valof_alt
  using valofn_ge_2p[of x] by (auto simp: valofd_def field_simps dest: order.antisym)

lemma valofd_neq_valofn:
  fixes x y :: "('e, 'f) float"
  assumes "exponent y \<noteq> 0"
  shows "valofd x \<noteq> valofn y" "valofn y \<noteq> valofd x"
proof -
  have "valofd x < 2 / 2^bias TYPE(('e, 'f) float)" by (rule valofd_less_2p)
  also have "... \<le> 2 ^ IEEE.exponent y / 2 ^ bias TYPE(('e, 'f) IEEE.float)"
    using assms by (simp add: self_le_power field_simps)
  also have "... \<le> valofn y" by (rule valofn_ge_2p)
  finally show "valofd x \<noteq> valofn y" "valofn y \<noteq> valofd x" by simp_all
qed

lemma sign_gt_0_conv: "0 < sign x \<longleftrightarrow> sign x = 1"
  by (cases x rule: sign_cases) simp_all

lemma valof_eq:
  assumes "\<not> is_zero x \<or> \<not> is_zero y"
  shows "valof x = valof y \<longleftrightarrow> x = y"
proof
  assume *: "valof x = valof y"
  with assms have "valof y \<noteq> 0" by (simp add: is_zero_valof_conv)
  with * show "x = y"
    unfolding valof_alt
    using valofd_ge_0[of x] valofd_ge_0[of y] valofn_ge_0[of x] valofn_ge_0[of y]
    by (auto simp: valofd_neq_valofn sign_gt_0_conv split: if_splits
        intro!: float_eqI elim: valofn_eq valofd_eq)
qed simp

lemma zero_fcompare: "is_zero x \<Longrightarrow> is_zero y \<Longrightarrow> fcompare x y = ccode.Eq"
  unfolding fcompare_def by (simp add: zero_not_infinity zero_not_nan is_zero_valof_conv)

subsection \<open>Doubles with a unified NaN value\<close>

quotient_type double = "(11, 52) float" / "\<lambda>x y. is_nan x \<and> is_nan y \<or> x = y"
  by (auto intro!: equivpI reflpI sympI transpI)

instantiation double :: "{zero, one, plus, minus, uminus, times, ord}"
begin

lift_definition zero_double :: "double" is "0" .
lift_definition one_double :: "double" is "1" .

lift_definition plus_double :: "double \<Rightarrow> double \<Rightarrow> double" is plus
  by (auto simp: is_nan_plus)

lift_definition minus_double :: "double \<Rightarrow> double \<Rightarrow> double" is minus
  by (auto simp: is_nan_minus)

lift_definition uminus_double :: "double \<Rightarrow> double" is uminus
  by auto

lift_definition times_double :: "double \<Rightarrow> double \<Rightarrow> double" is times
  by (auto simp: is_nan_times)

lift_definition less_eq_double :: "double \<Rightarrow> double \<Rightarrow> bool" is "(\<le>)"
  by (auto simp: nan_not_le)

lift_definition less_double :: "double \<Rightarrow> double \<Rightarrow> bool" is "(<)"
  by (auto simp: nan_not_less)

instance ..

end

instantiation double :: inverse
begin

lift_definition divide_double :: "double \<Rightarrow> double \<Rightarrow> double" is divide
  by (auto simp: is_nan_divide)

definition inverse_double :: "double \<Rightarrow> double" where
  "inverse_double x = 1 div x"

instance ..

end

lift_definition sqrt_double :: "double \<Rightarrow> double" is float_sqrt
  by (auto simp: is_nan_float_sqrt)

no_notation plus_infinity ("\<infinity>")

lift_definition infinity :: "double" is plus_infinity .

lift_definition nan :: "double" is some_nan .

lift_definition is_zero :: "double \<Rightarrow> bool" is IEEE.is_zero
  by (auto simp: nan_not_zero)

lift_definition is_infinite :: "double \<Rightarrow> bool" is IEEE.is_infinity
  by (auto simp: nan_not_infinity)

lift_definition is_nan :: "double \<Rightarrow> bool" is IEEE.is_nan
  by auto

lemma is_nan_conv: "is_nan x \<longleftrightarrow> x = nan"
  by transfer auto

lift_definition copysign_double :: "double \<Rightarrow> double \<Rightarrow> double" is
  "\<lambda>x y. if IEEE.is_nan y then some_nan else copysign x y"
  by auto

text \<open>Note: @{const copysign_double} deviates from the IEEE standard in cases where
  the second argument is a NaN.\<close>

lift_definition fcompare_double :: "double \<Rightarrow> double \<Rightarrow> ccode" is fcompare
  by (auto simp: nan_fcompare)

lemma nan_fcompare_double: "is_nan x \<or> is_nan y \<Longrightarrow> fcompare_double x y = Und"
  by transfer (rule nan_fcompare)

consts compare_double :: "double \<Rightarrow> double \<Rightarrow> integer"

specification (compare_double)
  compare_double_less: "compare_double x y < 0 \<longleftrightarrow> is_nan x \<and> \<not> is_nan y \<or> fcompare_double x y = ccode.Lt"
  compare_double_eq: "compare_double x y = 0 \<longleftrightarrow> is_nan x \<and> is_nan y \<or> fcompare_double x y = ccode.Eq"
  compare_double_greater: "compare_double x y > 0 \<longleftrightarrow> \<not> is_nan x \<and> is_nan y \<or> fcompare_double x y = ccode.Gt"
  by (rule exI[where x="\<lambda>x y. if is_nan x then if is_nan y then 0 else -1
    else if is_nan y then 1 else (case fcompare_double x y of ccode.Eq \<Rightarrow> 0 | ccode.Lt \<Rightarrow> -1 | ccode.Gt \<Rightarrow> 1)"],
        transfer, auto simp: fcompare_def)

lemmas compare_double_simps = compare_double_less compare_double_eq compare_double_greater

lemma compare_double_le_0: "compare_double x y \<le> 0 \<longleftrightarrow>
  is_nan x \<or> fcompare_double x y \<in> {ccode.Eq, ccode.Lt}"
  by (rule linorder_cases[of "compare_double x y" 0]; simp)
    (auto simp: compare_double_simps nan_fcompare_double)

lift_definition double_of_integer :: "integer \<Rightarrow> double" is
  "\<lambda>x. zerosign 0 (intround To_nearest (int_of_integer x))" .

definition double_of_int where [code del]: "double_of_int x = double_of_integer (integer_of_int x)"

lift_definition integer_of_double :: "double \<Rightarrow> integer" is
  "\<lambda>x. if IEEE.is_nan x \<or> IEEE.is_infinity x then undefined
     else integer_of_int \<lfloor>valof (intround float_To_zero (valof x) :: (11, 52) float)\<rfloor>"
  by auto

definition int_of_double: "int_of_double x = int_of_integer (integer_of_double x)"

subsection \<open>Linear ordering\<close>

definition lcompare_double :: "double \<Rightarrow> double \<Rightarrow> integer" where
  "lcompare_double x y = (if is_zero x \<and> is_zero y then
      compare_double (copysign_double 1 x) (copysign_double 1 y)
    else compare_double x y)"

lemma fcompare_double_swap: "fcompare_double x y = ccode.Gt \<longleftrightarrow> fcompare_double y x = ccode.Lt"
  by transfer (auto simp: fcompare_def)

lemma fcompare_double_refl: "\<not> is_nan x \<Longrightarrow> fcompare_double x x = ccode.Eq"
  by transfer (auto simp: fcompare_def)

lemma fcompare_double_Eq1: "fcompare_double x y = ccode.Eq \<Longrightarrow> fcompare_double y z = c \<Longrightarrow> fcompare_double x z = c"
  by transfer (auto simp: fcompare_def split: if_splits)

lemma fcompare_double_Eq2: "fcompare_double y z = ccode.Eq \<Longrightarrow> fcompare_double x y = c \<Longrightarrow> fcompare_double x z = c"
  by transfer (auto simp: fcompare_def split: if_splits)

lemma fcompare_double_Lt_trans: "fcompare_double x y = ccode.Lt \<Longrightarrow> fcompare_double y z = ccode.Lt \<Longrightarrow> fcompare_double x z = ccode.Lt"
  by transfer (auto simp: fcompare_def split: if_splits)

lemma fcompare_double_eq: "\<not> is_zero x \<or> \<not> is_zero y \<Longrightarrow> fcompare_double x y = ccode.Eq \<Longrightarrow> x = y"
  by transfer (auto simp: fcompare_def valof_eq IEEE.is_infinity_def split: if_splits intro!: float_eqI)

lemma fcompare_double_Lt_asym: "fcompare_double x y = ccode.Lt \<Longrightarrow> fcompare_double y x = ccode.Lt \<Longrightarrow> False"
  by transfer (auto simp: fcompare_def split: if_splits)

lemma compare_double_swap: "0 < compare_double x y \<longleftrightarrow> compare_double y x < 0"
  by (auto simp: compare_double_simps fcompare_double_swap)

lemma compare_double_refl: "compare_double x x = 0"
  by (auto simp: compare_double_eq intro!: fcompare_double_refl)

lemma compare_double_trans: "compare_double x y \<le> 0 \<Longrightarrow> compare_double y z \<le> 0 \<Longrightarrow> compare_double x z \<le> 0"
  by (fastforce simp: compare_double_le_0 nan_fcompare_double
      dest: fcompare_double_Eq1 fcompare_double_Eq2 fcompare_double_Lt_trans)

lemma compare_double_antisym: "compare_double x y \<le> 0 \<Longrightarrow> compare_double y x \<le> 0 \<Longrightarrow>
  \<not> is_zero x \<or> \<not> is_zero y \<Longrightarrow> x = y"
  unfolding compare_double_le_0
  by (auto simp: nan_fcompare_double is_nan_conv
      intro: fcompare_double_eq fcompare_double_eq[symmetric]
      dest: fcompare_double_Lt_asym)

lemma zero_compare_double_copysign: "compare_double (copysign_double 1 x) (copysign_double 1 y) \<le> 0 \<Longrightarrow>
  is_zero x \<Longrightarrow> is_zero y \<Longrightarrow> compare_double x y \<le> 0"
  unfolding compare_double_le_0
  by transfer (auto simp: nan_not_zero zero_fcompare split: if_splits)

lemma is_zero_double_cases: "is_zero x \<Longrightarrow> (x = 0 \<Longrightarrow> P) \<Longrightarrow> (x = -0 \<Longrightarrow> P) \<Longrightarrow> P"
  by transfer (auto elim!: is_zero_cases)

lemma copysign_1_0[simp]: "copysign_double 1 0 = 1" "copysign_double 1 (-0) = -1"
  by (transfer, simp, transfer, auto)+

lemma is_zero_uminus_double[simp]: "is_zero (- x) \<longleftrightarrow> is_zero x"
  by transfer simp

lemma not_is_zero_one_double[simp]: "\<not> is_zero 1"
  by (transfer, unfold IEEE.is_zero_def, transfer, simp)

lemma uminus_one_neq_one_double[simp]: "- 1 \<noteq> (1 :: double)"
  by (transfer, transfer, simp)

definition lle_double :: "double \<Rightarrow> double \<Rightarrow> bool" where
  "lle_double x y \<longleftrightarrow> lcompare_double x y \<le> 0"

definition lless_double :: "double \<Rightarrow> double \<Rightarrow> bool" where
  "lless_double x y \<longleftrightarrow> lcompare_double x y < 0"

lemma lcompare_double_ge_0: "lcompare_double x y \<ge> 0 \<longleftrightarrow> lle_double y x"
  unfolding lle_double_def lcompare_double_def
  using compare_double_swap not_less by auto

lemma lcompare_double_gt_0: "lcompare_double x y > 0 \<longleftrightarrow> lless_double y x"
  unfolding lless_double_def lcompare_double_def
  using compare_double_swap by auto

lemma lcompare_double_eq_0: "lcompare_double x y = 0 \<longleftrightarrow> x = y"
proof
  assume *: "lcompare_double x y = 0"
  show "x = y" proof (cases "is_zero x \<and> is_zero y")
    case True
    with * show ?thesis
      by (fastforce simp: lcompare_double_def compare_double_simps is_nan_conv
          elim: is_zero_double_cases dest!: fcompare_double_eq[rotated])
  next
    case False
    with * show ?thesis
      by (auto simp: lcompare_double_def linorder_not_less[symmetric] compare_double_swap
          intro!: compare_double_antisym)
  qed
next
  assume "x = y"
  then show "lcompare_double x y = 0"
    by (simp add: lcompare_double_def compare_double_refl)
qed

lemmas lcompare_double_0_folds = lle_double_def[symmetric] lless_double_def[symmetric]
  lcompare_double_ge_0 lcompare_double_gt_0 lcompare_double_eq_0

interpretation double_linorder: linorder lle_double lless_double
proof
  fix x y z :: double
  show "lless_double x y \<longleftrightarrow> lle_double x y \<and> \<not> lle_double y x"
    unfolding lless_double_def lle_double_def lcompare_double_def
    by (auto simp: compare_double_swap not_le)
  show "lle_double x x"
    unfolding lle_double_def lcompare_double_def
    by (auto simp: compare_double_refl)
  show "lle_double x z" if "lle_double x y" and "lle_double y z"
    using that
    by (auto 0 3 simp: lle_double_def lcompare_double_def not_le compare_double_swap
        split: if_splits dest: compare_double_trans zero_compare_double_copysign
        zero_compare_double_copysign[OF less_imp_le] compare_double_antisym)
  show "x = y" if "lle_double x y" and "lle_double y x"
  proof (cases "is_zero x \<and> is_zero y")
    case True
    with that show ?thesis
      by (auto 0 3 simp: lle_double_def lcompare_double_def elim: is_zero_double_cases
          dest!: compare_double_antisym)
  next
    case False
    with that show ?thesis
      by (auto simp: lle_double_def lcompare_double_def elim!: compare_double_antisym)
  qed
  show "lle_double x y \<or> lle_double y x"
    unfolding lle_double_def lcompare_double_def
    by (auto simp: compare_double_swap not_le)
qed

instantiation double :: equal
begin

definition equal_double :: "double \<Rightarrow> double \<Rightarrow> bool" where
  "equal_double x y \<longleftrightarrow> lcompare_double x y = 0"

instance by intro_classes (simp add: equal_double_def lcompare_double_eq_0)

end

derive (eq) ceq double

definition comparator_double :: "double comparator" where
  "comparator_double x y = (let c = lcompare_double x y in
    if c = 0 then order.Eq else if c < 0 then order.Lt else order.Gt)"

lemma comparator_double: "comparator comparator_double"
  unfolding comparator_double_def
  by (auto simp: lcompare_double_0_folds split: if_splits intro!: comparator.intro)

local_setup \<open>
  Comparator_Generator.register_foreign_comparator @{typ double}
    @{term comparator_double}
    @{thm comparator_double}
\<close>

derive ccompare double

subsubsection \<open>Code setup\<close>

declare [[code drop:
      "0 :: double"
      "1 :: double"
      "plus :: double \<Rightarrow> _"
      "minus :: double \<Rightarrow> _"
      "uminus :: double \<Rightarrow> _"
      "times :: double \<Rightarrow> _"
      "less_eq :: double \<Rightarrow> _"
      "less :: double \<Rightarrow> _"
      "divide :: double \<Rightarrow> _"
      "Code_Evaluation.term_of :: double \<Rightarrow> _"
      sqrt_double infinity nan is_zero is_infinite is_nan copysign_double fcompare_double
      double_of_integer integer_of_double
      ]]

code_printing
  code_module FloatUtil \<rightharpoonup> (OCaml)
\<open>module FloatUtil : sig
  val iszero : float -> bool
  val isinfinite : float -> bool
  val isnan : float -> bool
  val copysign : float -> float -> float
  val compare : float -> float -> Z.t
end = struct
  let iszero x = (Stdlib.classify_float x = Stdlib.FP_zero);;
  let isinfinite x = (Stdlib.classify_float x = Stdlib.FP_infinite);;
  let isnan x = (Stdlib.classify_float x = Stdlib.FP_nan);;
  let copysign x y = if isnan y then Stdlib.nan else Stdlib.copysign x y;;
  let compare x y = Z.of_int (Stdlib.compare x y);;
end;;\<close>

code_reserved OCaml Stdlib FloatUtil

code_printing
  type_constructor double \<rightharpoonup> (OCaml) "float"
  | constant "uminus :: double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Stdlib.(~-.)"
  | constant "(+) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Stdlib.(+.)"
  | constant "(*) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Stdlib.( *. )"
  | constant "(/) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Stdlib.('/.)"
  | constant "(-) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Stdlib.(-.)"
  | constant "0 :: double" \<rightharpoonup> (OCaml) "0.0"
  | constant "1 :: double" \<rightharpoonup> (OCaml) "1.0"
  | constant "(\<le>) :: double \<Rightarrow> double \<Rightarrow> bool" \<rightharpoonup> (OCaml) "Stdlib.(<=)"
  | constant "(<) :: double \<Rightarrow> double \<Rightarrow> bool" \<rightharpoonup> (OCaml) "Stdlib.(<)"
  | constant "sqrt_double :: double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Stdlib.sqrt"
  | constant "infinity :: double" \<rightharpoonup> (OCaml) "Stdlib.infinity"
  | constant "nan :: double" \<rightharpoonup> (OCaml) "Stdlib.nan"
  | constant "is_zero :: double \<Rightarrow> bool" \<rightharpoonup> (OCaml) "FloatUtil.iszero"
  | constant "is_infinite :: double \<Rightarrow> bool" \<rightharpoonup> (OCaml) "FloatUtil.isinfinite"
  | constant "is_nan :: double \<Rightarrow> bool" \<rightharpoonup> (OCaml) "FloatUtil.isnan"
  | constant "copysign_double :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (OCaml) "FloatUtil.copysign"
  | constant "compare_double :: double \<Rightarrow> double \<Rightarrow> integer" \<rightharpoonup> (OCaml) "FloatUtil.compare"
  | constant "double_of_integer :: integer \<Rightarrow> double" \<rightharpoonup> (OCaml) "Z.to'_float"
  | constant "integer_of_double :: double \<Rightarrow> integer" \<rightharpoonup> (OCaml) "Z.of'_float"

ML \<open>
if Real.precision <> 53 then
  error "SML real type must be double precision for Eval code adaptation"
else ();

signature REALUTIL = sig
  val nan : real
  val iszero : real -> bool
  val isinfinite : real -> bool
  val copysign : real -> real -> real
  val compare : real -> real -> int
  val toInt : real -> int
  val toTerm : real -> term
end
structure RealUtil : REALUTIL = struct
  val nan = 1.0 / 0.0;
  fun iszero x = (Real.class x = IEEEReal.ZERO);
  fun isinfinite x = (Real.class x = IEEEReal.INF);
  fun copysign x y = if Real.isNan y then nan else Real.copySign (x, y);

  fun compare x y = (case Real.compare (x, y) of
      LESS => ~1
    | EQUAL => 0
    | GREATER => 1);

  fun toInt x = Real.toInt IEEEReal.TO_ZERO x;

  fun toTerm x =
    (case Real.class x of
      IEEEReal.NAN => @{const nan}
    | IEEEReal.INF => if Real.signBit x then @{term "- infinity"} else @{term "infinity"}
    | IEEEReal.ZERO => if Real.signBit x then @{term "-0 :: double"} else @{term "0 :: double"}
    | _ => case Real.toManExp x of {man = m, exp = e} =>
      let
        val i = Real.floor (m * Math.pow (2.0, 53.0));
        val e = e - 53;
      in
        @{term abs_double} $ (@{term "of_finite_Float :: Float.float \<Rightarrow> (11, 52) float"} $
          (@{term Float} $ HOLogic.mk_number @{typ int} i $ HOLogic.mk_number @{typ int} e))
      end);
end\<close>

code_printing
  type_constructor double \<rightharpoonup> (Eval) "real"
  | constant "uminus :: double \<Rightarrow> double" \<rightharpoonup> (Eval) "Real.~"
  | constant "(+) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (Eval) "Real.+ ((_), (_))"
  | constant "(*) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (Eval) "Real.* ((_), (_))"
  | constant "(/) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (Eval) "Real.'/ ((_), (_))"
  | constant "(-) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (Eval) "Real.- ((_), (_))"
  | constant "0 :: double" \<rightharpoonup> (Eval) "0.0"
  | constant "1 :: double" \<rightharpoonup> (Eval) "1.0"
  | constant "(\<le>) :: double \<Rightarrow> double \<Rightarrow> bool" \<rightharpoonup> (Eval) "Real.<= ((_), (_))"
  | constant "(<) :: double \<Rightarrow> double \<Rightarrow> bool" \<rightharpoonup> (Eval) "Real.< ((_), (_))"
  | constant "sqrt_double :: double \<Rightarrow> double" \<rightharpoonup> (Eval) "Math.sqrt"
  | constant "infinity :: double" \<rightharpoonup> (Eval) "Real.posInf"
  | constant "nan :: double" \<rightharpoonup> (Eval) "RealUtil.nan"
  | constant "is_zero :: double \<Rightarrow> bool" \<rightharpoonup> (Eval) "RealUtil.iszero"
  | constant "is_infinite :: double \<Rightarrow> bool" \<rightharpoonup> (Eval) "RealUtil.isinfinite"
  | constant "is_nan :: double \<Rightarrow> bool" \<rightharpoonup> (Eval) "Real.isNan"
  | constant "copysign_double :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (Eval) "RealUtil.copysign"
  | constant "compare_double :: double \<Rightarrow> double \<Rightarrow> integer" \<rightharpoonup> (Eval) "RealUtil.compare"
  | constant "double_of_integer :: integer \<Rightarrow> double" \<rightharpoonup> (Eval) "Real.fromInt"
  | constant "integer_of_double :: double \<Rightarrow> integer" \<rightharpoonup> (Eval) "RealUtil.toInt"
  | constant "Code_Evaluation.term_of :: double \<Rightarrow> term" \<rightharpoonup> (Eval) "RealUtil.toTerm"

hide_const (open) fcompare_double

(*<*)
end
(*>*)


(* Author: Tobias Nipkow *)

theory Abs_Int1_const_ITP
imports Abs_Int1_ITP "../Abs_Int_Tests"
begin

subsection "Constant Propagation"

datatype const = Const val | Any

fun \<gamma>_const where
"\<gamma>_const (Const n) = {n}" |
"\<gamma>_const (Any) = UNIV"

fun plus_const where
"plus_const (Const m) (Const n) = Const(m+n)" |
"plus_const _ _ = Any"

lemma plus_const_cases: "plus_const a1 a2 =
  (case (a1,a2) of (Const m, Const n) \<Rightarrow> Const(m+n) | _ \<Rightarrow> Any)"
by(auto split: prod.split const.split)

instantiation const :: SL_top
begin

fun le_const where
"_ \<sqsubseteq> Any = True" |
"Const n \<sqsubseteq> Const m = (n=m)" |
"Any \<sqsubseteq> Const _ = False"

fun join_const where
"Const m \<squnion> Const n = (if n=m then Const m else Any)" |
"_ \<squnion> _ = Any"

definition "\<top> = Any"

instance
proof
  case goal1 thus ?case by (cases x) simp_all
next
  case goal2 thus ?case by(cases z, cases y, cases x, simp_all)
next
  case goal3 thus ?case by(cases x, cases y, simp_all)
next
  case goal4 thus ?case by(cases y, cases x, simp_all)
next
  case goal5 thus ?case by(cases z, cases y, cases x, simp_all)
next
  case goal6 thus ?case by(simp add: Top_const_def)
qed

end

permanent_interpretation Val_abs
where \<gamma> = \<gamma>_const and num' = Const and plus' = plus_const
proof
  case goal1 thus ?case
    by(cases a, cases b, simp, simp, cases b, simp, simp)
next
  case goal2 show ?case by(simp add: Top_const_def)
next
  case goal3 show ?case by simp
next
  case goal4 thus ?case
    by(auto simp: plus_const_cases split: const.split)
qed

permanent_interpretation Abs_Int
where \<gamma> = \<gamma>_const and num' = Const and plus' = plus_const
defining AI_const = AI and step_const = step' and aval'_const = aval'
..

subsubsection "Tests"

value "show_acom (((step_const \<top>)^^0) (\<bottom>\<^sub>c test1_const))"
value "show_acom (((step_const \<top>)^^1) (\<bottom>\<^sub>c test1_const))"
value "show_acom (((step_const \<top>)^^2) (\<bottom>\<^sub>c test1_const))"
value "show_acom (((step_const \<top>)^^3) (\<bottom>\<^sub>c test1_const))"
value "show_acom_opt (AI_const test1_const)"

value "show_acom_opt (AI_const test2_const)"
value "show_acom_opt (AI_const test3_const)"

value "show_acom (((step_const \<top>)^^0) (\<bottom>\<^sub>c test4_const))"
value "show_acom (((step_const \<top>)^^1) (\<bottom>\<^sub>c test4_const))"
value "show_acom (((step_const \<top>)^^2) (\<bottom>\<^sub>c test4_const))"
value "show_acom (((step_const \<top>)^^3) (\<bottom>\<^sub>c test4_const))"
value "show_acom_opt (AI_const test4_const)"

value "show_acom (((step_const \<top>)^^0) (\<bottom>\<^sub>c test5_const))"
value "show_acom (((step_const \<top>)^^1) (\<bottom>\<^sub>c test5_const))"
value "show_acom (((step_const \<top>)^^2) (\<bottom>\<^sub>c test5_const))"
value "show_acom (((step_const \<top>)^^3) (\<bottom>\<^sub>c test5_const))"
value "show_acom (((step_const \<top>)^^4) (\<bottom>\<^sub>c test5_const))"
value "show_acom (((step_const \<top>)^^5) (\<bottom>\<^sub>c test5_const))"
value "show_acom_opt (AI_const test5_const)"

value "show_acom (((step_const \<top>)^^0) (\<bottom>\<^sub>c test6_const))"
value "show_acom (((step_const \<top>)^^1) (\<bottom>\<^sub>c test6_const))"
value "show_acom (((step_const \<top>)^^2) (\<bottom>\<^sub>c test6_const))"
value "show_acom (((step_const \<top>)^^3) (\<bottom>\<^sub>c test6_const))"
value "show_acom (((step_const \<top>)^^4) (\<bottom>\<^sub>c test6_const))"
value "show_acom (((step_const \<top>)^^5) (\<bottom>\<^sub>c test6_const))"
value "show_acom (((step_const \<top>)^^6) (\<bottom>\<^sub>c test6_const))"
value "show_acom (((step_const \<top>)^^7) (\<bottom>\<^sub>c test6_const))"
value "show_acom (((step_const \<top>)^^8) (\<bottom>\<^sub>c test6_const))"
value "show_acom (((step_const \<top>)^^9) (\<bottom>\<^sub>c test6_const))"
value "show_acom (((step_const \<top>)^^10) (\<bottom>\<^sub>c test6_const))"
value "show_acom (((step_const \<top>)^^11) (\<bottom>\<^sub>c test6_const))"
value "show_acom_opt (AI_const test6_const)"

text{* Monotonicity: *}

permanent_interpretation Abs_Int_mono
where \<gamma> = \<gamma>_const and num' = Const and plus' = plus_const
proof
  case goal1 thus ?case
    by(auto simp: plus_const_cases split: const.split)
qed

text{* Termination: *}

definition "m_const x = (case x of Const _ \<Rightarrow> 1 | Any \<Rightarrow> 0)"

lemma measure_const:
  "(strict{(x::const,y). x \<sqsubseteq> y})^-1 \<subseteq> measure m_const"
by(auto simp: m_const_def split: const.splits)

lemma measure_const_eq:
  "\<forall> x y::const. x \<sqsubseteq> y \<and> y \<sqsubseteq> x \<longrightarrow> m_const x = m_const y"
by(auto simp: m_const_def split: const.splits)

lemma "EX c'. AI_const c = Some c'"
by(rule AI_Some_measure[OF measure_const measure_const_eq])

end


(******************************************************************************)
(* File: sequences_as_lists.thy                                               *)
(* Author: Pedro Ribeiro, University of York (UK)                             *)
(******************************************************************************)

header {* Simple encoding of sequences as lists *}

theory sequences_as_lists
imports
  Main
  Sublist
  Order
  Finite_Set
begin

(* Using cases, based on a question by Samuel *)
lemma
 shows "w = 5 \<longrightarrow> (x = 5 \<longrightarrow> x = w)"
proof (cases "w = 5")
  assume "w = 5"
  show "w = 5 \<longrightarrow> (x = 5 \<longrightarrow> x = w)"
  by auto

next
  assume "w \<noteq> 5"
  show "w = 5 \<longrightarrow> (x = 5 \<longrightarrow> x = w)"
  by auto
qed

lemma
 shows "w = 5 \<longrightarrow> (x = 5 \<longrightarrow> x = w)"
proof (cases "w = 5")
  case True
  show "w = 5 \<longrightarrow> (x = 5 \<longrightarrow> x = w)"
  by auto

next
  case False
  show "w = 5 \<longrightarrow> (x = 5 \<longrightarrow> x = w)"
  by auto
qed

lemma
 shows "w = 5 \<longrightarrow> (x = 5 \<longrightarrow> x = w)"
proof (cases "w = 5")
  assume "w = 5"
  show "w = 5 \<longrightarrow> (x = 5 \<longrightarrow> x = w)"
  proof -
   have "(w = 5 \<longrightarrow> (x = 5 \<longrightarrow> x = w)) = (w = 5 \<longrightarrow> (x = 5 \<longrightarrow> x = 5))"
   by auto
   also have "... = (w = 5 \<longrightarrow> True)"
   by auto
   also have "... = True"
   by auto
  show ?thesis
  by auto
qed
next
  assume "w \<noteq> 5"
  show "w = 5 \<longrightarrow> (x = 5 \<longrightarrow> x = w)"
  proof -
   have "(w = 5 \<longrightarrow> (x = 5 \<longrightarrow> x = w)) = (False \<longrightarrow> (x = 5 \<longrightarrow> x = w))"
   by auto
   show ?thesis
  by auto
 qed
qed

definition X0 :: "nat \<Rightarrow> nat \<Rightarrow> bool" where "X0 x y = (10 * x + y = y)"
definition X1 :: "nat \<Rightarrow> nat \<Rightarrow> bool" where "X1 x y = (y - 5 * y * 3 + 3 = x)"

value "x = 1 \<and> (X0 x y) \<and> (X1 x y)"

lemma shows "\<exists>x y. (X0 x y) \<and> (X1 x y) \<and> x = 1"
oops
term "\<exists>x y z. (X0 x y) \<and> (X1 x y)"

definition minusList :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixr "-\<^sub>t" 64)
where "minusList xs ys \<equiv> drop (length ys) xs"

abbreviation prefixeqList :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" (infixr "\<le>\<^sub>t" 65)
where "(xs \<le>\<^sub>t ys) \<equiv> prefixeq xs ys"

abbreviation prefixList :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" (infixr "<\<^sub>t" 65)
where "(xs <\<^sub>t ys) \<equiv> prefix xs ys"

abbreviation concatList :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixr "^\<^sub>t" 65)
where "xs ^\<^sub>t ys \<equiv> xs @ ys"

abbreviation frontList :: "'a list  \<Rightarrow> 'a list" ("front'(_')\<^sub>t" 66)
where "frontList xs \<equiv> butlast xs"

abbreviation lastList :: "'a list  \<Rightarrow> 'a" ("last'(_')\<^sub>t" 67)
where "lastList xs \<equiv> last xs"

abbreviation headList :: "'a list \<Rightarrow> 'a" ("head'(_')\<^sub>t" 67)
where "headList xs \<equiv> hd xs"

abbreviation tailList :: "'a list \<Rightarrow> 'a list" ("tail'(_')\<^sub>t" 67)
where "tailList xs \<equiv> tl xs"

value "last([a,b])\<^sub>t"

text {* In HOL, the following is total, whereas in Z it wouldn't be.
        So care is needed to ensure that those functions are applied when
        satisfying the provisos of Z in order to obtain correct results.

        Furthermore, this is intended as an exercise, more than anything else.*}

value "last([])\<^sub>t"

text {* Similarly for front([]), where the result is [] rather than undefined. *}

value "front([])\<^sub>t"

value "front(xs)\<^sub>t"

lemma list_minus_empty[simp]: "xs -\<^sub>t [] = xs"
  by (simp add:minusList_def)

lemma list_minus_extended[simp]: "(xs ^\<^sub>t ys) -\<^sub>t xs = ys"
  by (simp add:minusList_def)

lemma
  assumes "xs \<le>\<^sub>t ys"
  shows "xs ^\<^sub>t (ys -\<^sub>t xs) = ys"
  apply (simp add:minusList_def)
  by (metis assms list_minus_extended minusList_def prefixeq_def)

lemma t_minus_s_cat_z__eq__t_cat_z_minus_s:
  assumes "s \<le>\<^sub>t t"
  shows "(t -\<^sub>t s) ^\<^sub>t z = (t ^\<^sub>t z) -\<^sub>t s"
  by (metis append_assoc assms list_minus_extended prefixeq_def)

lemma
  assumes "xs <\<^sub>t ys" and "xs \<noteq> []"
  shows "ys -\<^sub>t xs \<noteq> []"
  by (metis assms(1) list.distinct(1) list_minus_extended prefixE')

lemma
  assumes "xs <\<^sub>t ys"
  shows "ys -\<^sub>t xs \<noteq> []"
  by (metis assms list_minus_extended prefixE' prefix_bot.bot.not_eq_extremum prefix_simps(2))

lemma
  assumes "xs \<le>\<^sub>t ys" and "xs \<noteq> ys"
  shows "ys -\<^sub>t xs \<noteq> []"
  by (metis append_Nil2 assms(1) assms(2) list_minus_extended prefixeq_def)

lemma s_cat_t_empty__iff__s_empty_and_t_empty:
  shows "s ^\<^sub>t t = [] \<longleftrightarrow> s = [] \<and> t = []"
  by auto

lemma ys_not_empty:
  assumes "xs <\<^sub>t ys" and "xs \<noteq> []"
  shows "ys \<noteq> []"
  by (metis assms(1) prefix_simps(1))

lemma length_ys_gt_0:
  assumes "xs <\<^sub>t ys" and "xs \<noteq> []"
  shows "length ys > 0"
  by (metis assms(1) length_greater_0_conv prefix_simps(1))

lemma ys_not_empty_assms_front_xs_lt_ys__and__xs_not_empty:
  assumes "front(xs)\<^sub>t <\<^sub>t ys" and "xs \<noteq> []"
  shows "ys \<noteq> []"
  by (metis assms(1) prefix_simps(1))

lemma front_xs_ys__eq__xs_cat_front_ys:
  assumes "length ys > 0"
  shows "front(xs ^\<^sub>t ys)\<^sub>t = xs ^\<^sub>t front(ys)\<^sub>t"
  by (metis assms butlast_append length_greater_0_conv)

lemma front_xs_cat_ys__eq__front_xs:
  assumes "length ys = 0"
  shows "front(xs ^\<^sub>t ys)\<^sub>t = front(xs)\<^sub>t"
  by (metis append_Nil2 assms length_0_conv)

lemma front_element__eq__empty:
  shows "front([e])\<^sub>t = []"
  by (metis butlast.simps(2))

lemma last_element__eq__e:
  shows "last([e])\<^sub>t = e"
  by (metis last.simps)

lemma last_s_cat_t__eq__last_s:
  assumes "length t = 0"
  shows "last(s ^\<^sub>t t)\<^sub>t = last(s)\<^sub>t"
  by (metis append_Nil2 assms length_0_conv)

lemma last_s_cat_t__eq__last_t:
  assumes "length t > 0"
  shows "last(s ^\<^sub>t t)\<^sub>t = last(t)\<^sub>t"
  by (metis assms last_append length_greater_0_conv)

lemma length_tail_t_minus_front_s__gt__0:
  assumes "length s < length t" and "front(s)\<^sub>t <\<^sub>t t" and "length s > 0"
  shows "length(tail(t -\<^sub>t front(s)\<^sub>t)\<^sub>t) > 0"
  by (metis One_nat_def Suc_pred assms(1) assms(3) drop_Suc drop_eq_Nil length_0_conv length_butlast minusList_def neq0_conv not_less tl_drop)

lemma
  "(s \<le>\<^sub>t t \<and> (e ^\<^sub>t t) \<le>\<^sub>t u) \<longrightarrow> ((e ^\<^sub>t s) \<le>\<^sub>t u)"
  by (metis prefix_order.order_trans same_prefixeq_prefixeq)

lemma t_minus_front_s__eq__last_t:
  assumes "length t = length s" and "front(s)\<^sub>t <\<^sub>t t"
  shows "t -\<^sub>t front(s)\<^sub>t = [last(t)\<^sub>t]"
  by (metis append_butlast_last_id assms(1) assms(2) length_butlast list_minus_extended minusList_def prefix_simps(1))

lemma sequence_strict_prefix:
  "s <\<^sub>t t \<longleftrightarrow> (\<exists>xs . s ^\<^sub>t xs = t \<and> (length xs) > 0)"
  by (metis length_0_conv neq0_conv prefix_def prefixeq_def self_append_conv)

lemma sequence_prefix:
  "s \<le>\<^sub>t t \<longleftrightarrow> (\<exists>xs . s ^\<^sub>t xs = t)"
  by (metis prefixeq_def)

lemma
  assumes "length s = length t" and "front(s)\<^sub>t <\<^sub>t t"
  shows "front(s)\<^sub>t <\<^sub>t t \<longleftrightarrow> front(s)\<^sub>t = front(t)\<^sub>t"
  by (metis append_Nil2 assms(1) assms(2) butlast_append length_butlast less_not_refl prefix_def prefixeq_def prefixeq_length_less)

lemma front_s_lt_t__and__front_z_lt_t__implies__front_s__eq__front_z:
  assumes "length s > 0" and "length z > 0"
  shows "length s = length z \<and> front(s)\<^sub>t <\<^sub>t t \<and> front(z)\<^sub>t <\<^sub>t t \<longrightarrow> front(s)\<^sub>t = front(z)\<^sub>t"
  apply (simp add:sequence_strict_prefix)
  apply (auto)
  done

text
{* This is an attempt at proving generic results about sequences of pairs. *}

type_synonym ('a, 'b) listPairs = "('a \<times> 'b) list"

text
{* This is an augmented construction about sequences of pairs, whose first
   element is also a sequence. *}

type_synonym ('a, 'b) listPairs_List = "('a list, 'b) listPairs"

value "head([1,2,4])\<^sub>t"

value "(fst(head([(1,2),(2,3)] -\<^sub>t front([(1,2),(2,3)])\<^sub>t)\<^sub>t),3)"

definition difA :: "('a, 'b) listPairs_List \<Rightarrow> ('a, 'b) listPairs_List  \<Rightarrow> ('a, 'b) listPairs_List" ("difA'(_,_')\<^sub>t" 67)
where "difA t s \<equiv> [(fst(head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t) -\<^sub>t fst(last(s)\<^sub>t),snd(head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t))] ^\<^sub>t tail(t -\<^sub>t front(s)\<^sub>t)\<^sub>t"

definition difloc :: "'a list => ('a, 'b) listPairs_List \<Rightarrow> ('a, 'b) listPairs_List  \<Rightarrow> ('a, 'b) listPairs_List" ("difloc'(_,_,_')" 68)
where "difloc c t s \<equiv> [(c, snd(head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t))] ^\<^sub>t tail(t-\<^sub>tfront(s)\<^sub>t)\<^sub>t"

definition FlatA :: "('a, 'b) listPairs_List \<Rightarrow> 'a list" ("FlatA'(_')\<^sub>t" 66)
where "FlatA tx \<equiv> concat (map fst tx)"

value "difA([([a,b],1)],[([a],1)])\<^sub>t"

value "FlatA([([1],2),([3,4],4)])\<^sub>t"

lemma s_prefix_t__implies__length_s_le_length_t:
  "s \<le>\<^sub>t t \<longrightarrow> length s \<le> length t"
  by (metis prefixeq_length_le)

lemma s_prefix_t__implies__not_length_t_le_length_s:
  "s \<le>\<^sub>t t \<longrightarrow> \<not> length t < length s"
  by (metis not_less prefixeq_length_le)

lemma length_s__eq__length_t__implies__s__eq__t:
  assumes "s \<le>\<^sub>t t" and "length t = length s"
  shows "s=t"
  by (metis assms(1) assms(2) not_equal_is_parallel parallel_def)

lemma last_tail_t_minus_front_s__eq__last_t:
  assumes "length s > 0"
  shows "front(s)\<^sub>t <\<^sub>t t \<and> length s < length t \<longrightarrow> last(tail(t -\<^sub>t front(s)\<^sub>t)\<^sub>t)\<^sub>t = last(t)\<^sub>t"
  by (metis Nitpick.size_list_simp(2) assms drop_Suc last_drop length_butlast length_tl less_not_refl minusList_def tl_drop)

lemma tail_t_minus_front_s_not_empty:
  assumes "front(s)\<^sub>t <\<^sub>t t" and "length s > 0" and "length t > length s"
  shows "tail(t -\<^sub>t front(s)\<^sub>t)\<^sub>t \<noteq> []"
  by (metis (mono_tags) One_nat_def Suc_pred assms(2) assms(3) drop_Suc drop_eq_Nil length_butlast minusList_def not_less tl_def tl_drop)

lemma tail_t_minus_front_s_empty:
  assumes "front(s)\<^sub>t <\<^sub>t t" and "length s > 0" and "length t = length s"
  shows "tail(t -\<^sub>t front(s)\<^sub>t)\<^sub>t = []"
  by (metis assms(3) drop_eq_Nil length_butlast length_tl minusList_def order_refl tl_drop)

lemma last_difA_t_s__eq__last_t_one:
  assumes "front(s)\<^sub>t <\<^sub>t t" and "length s > 0" and "length t > 0" and "length t > length s"
  shows "last(difA(t,s)\<^sub>t)\<^sub>t = last(t)\<^sub>t"
  apply (insert assms(1) assms(2) assms(4))
  apply (simp add:difA_def)
  by (metis One_nat_def Suc_pred assms(2) drop_Suc drop_eq_Nil last_drop length_butlast minusList_def not_less tl_drop)

lemma last_difA_t_s__eq__last_t_two:
  assumes "front(s)\<^sub>t <\<^sub>t t" and "length s > 0" and "length t > 0" and "length t = length s"
  shows "last(difA(t,s)\<^sub>t)\<^sub>t = last(t)\<^sub>t"
  apply (insert assms(1) assms(2) assms(4))
  apply (simp add:difA_def)
  oops

lemma t_minus_front_s__eq__last_t_two:
  assumes "front(s)\<^sub>t <\<^sub>t t" and "length s > 0" and "length t > 0" and "length t = length s"
  shows "t -\<^sub>t front(s)\<^sub>t = [last(t)\<^sub>t]"
  by (metis Ex_list_of_length Suc_pred add_Suc_right append_butlast_last_id assms(3) assms(4) length_0_conv length_butlast list.distinct(1) list.size(4) list_minus_extended minusList_def monoid_add_class.add.right_neutral)

lemma difA_length_t_eq_lengths__eq__fst:
  assumes "front(s)\<^sub>t <\<^sub>t t" and "length s > 0" and "length t > 0" and "length t = length s"
  shows "difA(t,s)\<^sub>t = [(fst(last(t)\<^sub>t) -\<^sub>t fst(last(s)\<^sub>t),snd(last(t)\<^sub>t))]"
  apply (simp add:difA_def)
  by (metis (no_types, hide_lams) One_nat_def Suc_pred append_Nil2 assms(1) assms(3) assms(4) drop_Suc length_butlast list.sel(1) list.sel(3) list_minus_extended minusList_def prefixE' snoc_eq_iff_butlast tl_drop)

lemma snd_last_difA__eq__snd_last:
  assumes "front(s)\<^sub>t <\<^sub>t t" and "length s > 0" and "length t > 0"
  shows "snd(last(difA(t,s)\<^sub>t)\<^sub>t) = snd(last(t)\<^sub>t)"
  apply (simp add:difA_def)
proof -
  have "length (front(s)\<^sub>t) < length t" using assms(1) prefixeq_length_less by blast
  thus "(tail(t -\<^sub>t front(s)\<^sub>t)\<^sub>t = [] \<longrightarrow> snd (head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t) = snd (last(t)\<^sub>t)) \<and> (tail(t -\<^sub>t front(s)\<^sub>t)\<^sub>t \<noteq> [] \<longrightarrow> snd (last(tail(t -\<^sub>t front(s)\<^sub>t)\<^sub>t)\<^sub>t) = snd (last(t)\<^sub>t))" by (metis (no_types) append_butlast_last_id drop_eq_Nil hd_append last_drop last_tl length_0_conv length_butlast length_tl list.sel(1) minusList_def not_less)
qed

lemma last_difA_t_s__eq__fst_last_t_minus_fst_last_s__snd_last_t:
  assumes "length t = length s" and "front(s)\<^sub>t <\<^sub>t t"
  shows "last(difA(t,s)\<^sub>t)\<^sub>t = (fst(last(t)\<^sub>t) -\<^sub>t fst(last(s)\<^sub>t),snd(last(t)\<^sub>t))"
  by (metis (erased, hide_lams) assms(1) assms(2) butlast.simps(1) difA_length_t_eq_lengths__eq__fst last.simps length_greater_0_conv prefix_order.less_irrefl)

lemma last_difA_t_s__eq__front_s_lt_t:
  assumes "length s < length t" and "front(s)\<^sub>t <\<^sub>t t"
  shows "last(difA(t,s)\<^sub>t)\<^sub>t = last(t)\<^sub>t"
  proof -
  have "last(difA(t,s)\<^sub>t)\<^sub>t
       =
       last([(fst (head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t) -\<^sub>t fst (last(s)\<^sub>t),
           snd (head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t))] ^\<^sub>t
         tail(t -\<^sub>t front(s)\<^sub>t)\<^sub>t)\<^sub>t"
       by (simp only:difA_def)
  also have "... = last(tail(t -\<^sub>t front(s)\<^sub>t)\<^sub>t)\<^sub>t"
       oops

lemma t_cat_s__minus__t_cat_front_u__eq__s__minus__front_u:
  assumes "front(u)\<^sub>t \<le>\<^sub>t s"
  shows "(t ^\<^sub>t s) -\<^sub>t (t ^\<^sub>t front(u)\<^sub>t) = s -\<^sub>t front(u)\<^sub>t"
  by (metis append_assoc assms list_minus_extended prefixeq_def)

lemma difA_t_cat_s_t_cat_u__eq__difA_s_u:
  assumes "length u > 0" and "front(u)\<^sub>t \<le>\<^sub>t s"
  shows "difA(t ^\<^sub>t s, t ^\<^sub>t u)\<^sub>t = difA(s, u)\<^sub>t"
proof -
  have "difA(t ^\<^sub>t s, t ^\<^sub>t u)\<^sub>t =
      [(fst (head(t ^\<^sub>t s -\<^sub>t front(t ^\<^sub>t u)\<^sub>t)\<^sub>t) -\<^sub>t fst (last(t ^\<^sub>t u)\<^sub>t),
      snd (head(t ^\<^sub>t s -\<^sub>t front(t ^\<^sub>t u)\<^sub>t)\<^sub>t))] ^\<^sub>t
      tail(t ^\<^sub>t s -\<^sub>t front(t ^\<^sub>t u)\<^sub>t)\<^sub>t"
      by (simp only:difA_def)
  also have "... = [(fst (head((t ^\<^sub>t s) -\<^sub>t (t ^\<^sub>t front(u)\<^sub>t))\<^sub>t) -\<^sub>t fst (last(t ^\<^sub>t u)\<^sub>t),
      snd (head((t ^\<^sub>t s) -\<^sub>t (t ^\<^sub>t front(u)\<^sub>t))\<^sub>t))] ^\<^sub>t
      tail((t ^\<^sub>t s) -\<^sub>t (t ^\<^sub>t front(u)\<^sub>t))\<^sub>t"
      using assms(1)
      by (metis (erased, hide_lams) front_xs_ys__eq__xs_cat_front_ys)
  also have "... = [(fst (head((t ^\<^sub>t s) -\<^sub>t (t ^\<^sub>t front(u)\<^sub>t))\<^sub>t) -\<^sub>t fst (last(u)\<^sub>t),
      snd (head((t ^\<^sub>t s) -\<^sub>t (t ^\<^sub>t front(u)\<^sub>t))\<^sub>t))] ^\<^sub>t
      tail((t ^\<^sub>t s) -\<^sub>t (t ^\<^sub>t front(u)\<^sub>t))\<^sub>t"
      using assms(1)
      by (metis last_appendR length_greater_0_conv)
   also have "... = [(fst (head(s -\<^sub>t front(u)\<^sub>t)\<^sub>t) -\<^sub>t fst (last(u)\<^sub>t),
      snd (head(s -\<^sub>t front(u)\<^sub>t)\<^sub>t))] ^\<^sub>t
      tail(s -\<^sub>t front(u)\<^sub>t)\<^sub>t"
      using assms(1) assms(2)
      by (metis t_cat_s__minus__t_cat_front_u__eq__s__minus__front_u)
   also have "... = difA(s, u)\<^sub>t"
      by (simp only:difA_def)
   finally show ?thesis .
qed

lemma difA_s_front_u_cat__fst_last_u__eq__difA_s_u:
  shows "difA(s, front(u)\<^sub>t ^\<^sub>t [(fst(last(u)\<^sub>t),r)])\<^sub>t = difA(s, u)\<^sub>t"
  by (metis butlast_snoc difA_def fst_conv last_snoc)

lemma difA_s_t__eq__difA_s_u:
  assumes "front(u)\<^sub>t = front(t)\<^sub>t" and "fst(last(t)\<^sub>t) = fst(last(u)\<^sub>t)"
  shows "difA(s,t)\<^sub>t = difA(s,u)\<^sub>t"
  by (metis assms(1) assms(2) difA_def)

lemma difA_difA_t_s_empty_snd_last_s__eq__difA_t_s:
  assumes "front(s)\<^sub>t <\<^sub>t t" and "length s > 0"
  shows "difA(difA(t,s)\<^sub>t,[([],snd(last(s)\<^sub>t))])\<^sub>t = difA(t,s)\<^sub>t"
proof -
  have "difA(difA(t,s)\<^sub>t,[([],snd(last(s)\<^sub>t))])\<^sub>t
        =
        [(fst(head(difA(t,s)\<^sub>t -\<^sub>t front([([],snd(last(s)\<^sub>t))])\<^sub>t)\<^sub>t)
           -\<^sub>t
           fst(last([([],snd(last(s)\<^sub>t))])\<^sub>t),
           snd(head(difA(t,s)\<^sub>t -\<^sub>t front([([],snd(last(s)\<^sub>t))])\<^sub>t)\<^sub>t))]
        ^\<^sub>t
        tail(difA(t,s)\<^sub>t -\<^sub>t front([([],snd(last(s)\<^sub>t))])\<^sub>t)\<^sub>t"
        by (simp only:difA_def)
   also have "... = [(fst(head(difA(t,s)\<^sub>t -\<^sub>t [])\<^sub>t)
           -\<^sub>t
           fst(last([([],snd(last(s)\<^sub>t))])\<^sub>t),
           snd(head(difA(t,s)\<^sub>t -\<^sub>t [])\<^sub>t))]
        ^\<^sub>t
        tail(difA(t,s)\<^sub>t -\<^sub>t [])\<^sub>t"
        by (metis front_element__eq__empty)
   also have "... = [(fst(head(difA(t,s)\<^sub>t -\<^sub>t [])\<^sub>t)
           -\<^sub>t
           fst(([],snd(last(s)\<^sub>t))),
           snd(head(difA(t,s)\<^sub>t -\<^sub>t [])\<^sub>t))]
        ^\<^sub>t
        tail(difA(t,s)\<^sub>t -\<^sub>t [])\<^sub>t"
        by (metis last_element__eq__e)
   also have "... =
        [(fst(head(difA(t,s)\<^sub>t)\<^sub>t) -\<^sub>t fst(([],snd(last(s)\<^sub>t))),
        snd(head(difA(t,s)\<^sub>t)\<^sub>t))]
        ^\<^sub>t
        tail(difA(t,s)\<^sub>t)\<^sub>t"
        by (metis list_minus_empty)
   also have "... =
        [(fst(head(difA(t,s)\<^sub>t)\<^sub>t),snd(head(difA(t,s)\<^sub>t)\<^sub>t))]
        ^\<^sub>t
        tail(difA(t,s)\<^sub>t)\<^sub>t"
        by (metis fst_conv list_minus_empty)
   also have "... = [head(difA(t,s)\<^sub>t)\<^sub>t] ^\<^sub>t tail(difA(t,s)\<^sub>t)\<^sub>t"
        by (metis prod.collapse)
   also have "... = difA(t,s)\<^sub>t"
        by (metis append_Cons append_Nil difA_def list.collapse list.distinct(1))

   finally show ?thesis .
qed

lemma
  assumes "front(s)\<^sub>t <\<^sub>t t" and "length s > 0"
  shows "fst(head(difA(t,s)\<^sub>t)\<^sub>t) = fst(head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t) -\<^sub>t fst(last(s)\<^sub>t)"
  by (metis append_Cons difA_def fst_conv list.sel(1))

text
{* Results about Flat *}

lemma FlatA_s_cat_t__eq__Flat_s_cat_Flat_t:
  shows "FlatA(s ^\<^sub>t t)\<^sub>t = FlatA(s)\<^sub>t ^\<^sub>t FlatA(t)\<^sub>t"
  by (simp add:FlatA_def)

lemma FlatA_seq_s__eq__seq_s:
  shows "FlatA([([s],t)])\<^sub>t = [s]"
  by (simp add:FlatA_def)

lemma FlatA_s_non_empty__eq__fst_head_s_cat_FlatA_tail_s:
  assumes "length s > 0"
  shows "FlatA(s)\<^sub>t = fst(head(s)\<^sub>t) ^\<^sub>t FlatA(tail(s)\<^sub>t)\<^sub>t"
  by (metis FlatA_def assms concat.simps(2) length_greater_0_conv list.collapse list.simps(9))

lemma FlatA_s_non_empty__eq__FlatA_front_s_cat_fst_last_s:
  assumes "length s > 0"
  shows "FlatA(s)\<^sub>t = FlatA(front(s)\<^sub>t)\<^sub>t ^\<^sub>t fst(last(s)\<^sub>t)"
  by (metis FlatA_s_cat_t__eq__Flat_s_cat_Flat_t FlatA_s_non_empty__eq__fst_head_s_cat_FlatA_tail_s append_butlast_last_id assms butlast_snoc last_snoc less_numeral_extra(3) list.distinct(1) list.size(3) prefix_simps(2) prefixeq_length_less rotate1.simps(2) rotate1_hd_tl self_append_conv)

lemma
  assumes "length s > 0" and "length t > 0" and "length z > 0"
  shows "FlatA(s)\<^sub>t = [] \<and> FlatA(z)\<^sub>t = [] \<and> length s = length z \<and> front(s)\<^sub>t <\<^sub>t t \<and> front(z)\<^sub>t <\<^sub>t t
         \<longrightarrow>
         fst(last(s)\<^sub>t) = fst(last(z)\<^sub>t) \<and> front(s)\<^sub>t = front(z)\<^sub>t"
  by (metis FlatA_s_non_empty__eq__FlatA_front_s_cat_fst_last_s append_is_Nil_conv assms(1) front_s_lt_t__and__front_z_lt_t__implies__front_s__eq__front_z)

lemma FlatA_head_s__eq__fst_head_s:
  assumes "length s > 0"
  shows "FlatA([head(s)\<^sub>t])\<^sub>t = fst(head(s)\<^sub>t)"
  by (simp add:FlatA_def)

lemma FlatA_last_s__eq__fst_last_s:
  assumes "length s > 0"
  shows "FlatA([last(s)\<^sub>t])\<^sub>t = fst(last(s)\<^sub>t)"
  by (simp add:FlatA_def)

lemma FlatA_t_minus_s__eq__FlatA_t_minus_FlatA_s:
  assumes "s \<le>\<^sub>t t"
  shows "FlatA(t -\<^sub>t s)\<^sub>t = FlatA(t)\<^sub>t -\<^sub>t FlatA(s)\<^sub>t"
  by (metis FlatA_s_cat_t__eq__Flat_s_cat_Flat_t assms list_minus_extended prefixeq_def)

lemma FlatA_t_minus_front_s__eq__FlatA_t_minus_FlatA_front_s:
  assumes "front(s)\<^sub>t <\<^sub>t t" and "length s > 0" and "fst(last(s)\<^sub>t) \<le>\<^sub>t fst(head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t)"
  shows "FlatA(t -\<^sub>t front(s)\<^sub>t)\<^sub>t = FlatA(t)\<^sub>t -\<^sub>t FlatA(front(s)\<^sub>t)\<^sub>t"
  by (metis FlatA_t_minus_s__eq__FlatA_t_minus_FlatA_s assms(1) prefix_def)

lemma FlatA_t_minus_s_minus_FlatA_z__eq__FlatA_t_minus_FlatA_s_cat_z:
  assumes "s \<le>\<^sub>t t" and "(s ^\<^sub>t z) \<le>\<^sub>t t"
  shows "FlatA(t-\<^sub>ts)\<^sub>t -\<^sub>t FlatA(z)\<^sub>t = FlatA(t)\<^sub>t -\<^sub>t FlatA(s ^\<^sub>t z)\<^sub>t"
  by (smt2 FlatA_s_cat_t__eq__Flat_s_cat_Flat_t FlatA_t_minus_s__eq__FlatA_t_minus_FlatA_s append_assoc assms(1) assms(2) list_minus_extended prefixeq_def)

lemma FlatA_t_minus_s_minus_FlatA_z__eq__FlatA_t_minus_FlatA_s_cat_z_lt:
  assumes "s <\<^sub>t t" and "(s ^\<^sub>t z) <\<^sub>t t"
  shows "FlatA(t-\<^sub>ts)\<^sub>t -\<^sub>t FlatA(z)\<^sub>t = FlatA(t)\<^sub>t -\<^sub>t FlatA(s ^\<^sub>t z)\<^sub>t"
  by (metis FlatA_t_minus_s_minus_FlatA_z__eq__FlatA_t_minus_FlatA_s_cat_z append_prefixeqD assms(2) prefix_order.less_imp_le)

lemma FlatA_t_minus_s_minus_FlatA_z__eq__FlatA_t_minus_FlatA_s_cat_z_le:
  assumes "s <\<^sub>t t" and "(s ^\<^sub>t z) \<le>\<^sub>t t"
  shows "FlatA(t-\<^sub>ts)\<^sub>t -\<^sub>t FlatA(z)\<^sub>t = FlatA(t)\<^sub>t -\<^sub>t FlatA(s ^\<^sub>t z)\<^sub>t"
  by (metis FlatA_t_minus_s_minus_FlatA_z__eq__FlatA_t_minus_FlatA_s_cat_z append_prefixeqD assms(2))

lemma
  assumes "front(s)\<^sub>t <\<^sub>t t" and "length s > 0" and "fst(last(s)\<^sub>t) \<le>\<^sub>t fst(head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t)"
  shows "FlatA(t -\<^sub>t front(s)\<^sub>t)\<^sub>t ^\<^sub>t FlatA([last(s)\<^sub>t])\<^sub>t = FlatA(t)\<^sub>t -\<^sub>t FlatA(s)\<^sub>t"
  oops

lemma fst_last_s__le__fst_head_t_minus_front_s:
  assumes "front(s)\<^sub>t <\<^sub>t t" and "length s > 0"
  shows "fst(last(s)\<^sub>t) \<le>\<^sub>t fst(head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t)
         \<longrightarrow>
         FlatA([last(s)\<^sub>t])\<^sub>t \<le>\<^sub>t FlatA(t -\<^sub>t front(s)\<^sub>t)\<^sub>t"
  apply (simp add:FlatA_def)
  by (metis (erased, hide_lams) FlatA_def FlatA_s_non_empty__eq__fst_head_s_cat_FlatA_tail_s assms(1) list_minus_extended prefixeq_append sequence_strict_prefix)

lemma s_cat_t__minus__s_cat_z__eq__t_minus_z:
  assumes "z \<le>\<^sub>t t"
  shows "(s ^\<^sub>t t) -\<^sub>t (s ^\<^sub>t z) = t -\<^sub>t z"
  by (metis append_assoc assms list_minus_extended prefixeq_def)

lemma FlatA_t_minus_FlatA_s__eq__FlatA_t_minus_front_s__minus__FlatA_last_s:
  assumes "front(s)\<^sub>t <\<^sub>t t" and "length s > 0" and "fst(last(s)\<^sub>t) \<le>\<^sub>t fst(head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t)"
  shows "FlatA(t)\<^sub>t -\<^sub>t FlatA(s)\<^sub>t = FlatA(t -\<^sub>t front(s)\<^sub>t)\<^sub>t -\<^sub>t FlatA([last(s)\<^sub>t])\<^sub>t"
proof -
  have "FlatA(t)\<^sub>t -\<^sub>t FlatA(s)\<^sub>t = FlatA(t)\<^sub>t -\<^sub>t FlatA(front(s)\<^sub>t ^\<^sub>t [last(s)\<^sub>t])\<^sub>t"
    by (metis append_butlast_last_id assms(2) length_greater_0_conv)
  also have "... = FlatA(front(s)\<^sub>t ^\<^sub>t (t -\<^sub>t front(s)\<^sub>t))\<^sub>t -\<^sub>t FlatA(front(s)\<^sub>t ^\<^sub>t [last(s)\<^sub>t])\<^sub>t"
    by (metis assms(1) list_minus_extended prefixE')
  also have "... = (FlatA(front(s)\<^sub>t)\<^sub>t ^\<^sub>t FlatA(t -\<^sub>t front(s)\<^sub>t)\<^sub>t) -\<^sub>t FlatA(front(s)\<^sub>t ^\<^sub>t [last(s)\<^sub>t])\<^sub>t"
    by (metis FlatA_s_cat_t__eq__Flat_s_cat_Flat_t)
  also have "... = (FlatA(front(s)\<^sub>t)\<^sub>t ^\<^sub>t FlatA(t -\<^sub>t front(s)\<^sub>t)\<^sub>t) -\<^sub>t (FlatA(front(s)\<^sub>t)\<^sub>t ^\<^sub>t FlatA([last(s)\<^sub>t])\<^sub>t)"
    by (metis FlatA_s_cat_t__eq__Flat_s_cat_Flat_t)
  also have  "... = FlatA(t -\<^sub>t front(s)\<^sub>t)\<^sub>t -\<^sub>t FlatA([last(s)\<^sub>t])\<^sub>t"
    apply (insert assms(2))
    apply (insert assms(3))
    apply (insert s_cat_t__minus__s_cat_z__eq__t_minus_z
          [where s="FlatA(front(s)\<^sub>t)\<^sub>t"
             and t="FlatA(t -\<^sub>t front(s)\<^sub>t)\<^sub>t"
             and z="FlatA([last(s)\<^sub>t])\<^sub>t"])
    by (metis FlatA_last_s__eq__fst_last_s FlatA_s_non_empty__eq__fst_head_s_cat_FlatA_tail_s assms(1) assms(2) drop_eq_Nil list.size(3) list_minus_empty minusList_def not_less prefixeq_append prefixeq_length_less)

  finally show ?thesis .
qed

lemma front_s_lt_t__implies__not_length_t_lt_length_s:
  assumes "length s > 0"
  shows "front(s)\<^sub>t <\<^sub>t t \<longrightarrow> \<not> (length t < length s)"
  by (smt2 Nitpick.size_list_simp(2) append_is_Nil_conv butlast_append drop_Suc drop_eq_Nil length_butlast length_tl not_less prefixeq_def prefixeq_length_le sequence_strict_prefix)

lemma not_lenth_s_lt_length_t__eq__length_s_eq_length_t:
  assumes "length s > 0" and "front(s)\<^sub>t <\<^sub>t t"
  shows "(\<not> (length s < length t)) = (length s = length t)"
proof -
  have "(\<not> (length s < length t)) = ((length t < length s) \<or> (length s = length t))"
      by (metis not_less_iff_gr_or_eq)
  also have "... = (length s = length t)"
      using assms
        (*   apply (insert assms(1))
           apply (insert assms(2))
           apply (insert front_s_lt_t__implies__not_length_t_lt_length_s
                  [where s=s and t=t]) *)
      by (simp add:front_s_lt_t__implies__not_length_t_lt_length_s)

  finally show ?thesis .
qed

lemma tail_t_minus_front_s_eq_lengths__eq__empty:
  assumes "front(s)\<^sub>t <\<^sub>t t" and "length s = length t"
  shows "tail(t -\<^sub>t front(s)\<^sub>t)\<^sub>t = []"
  by (metis assms(1) assms(2) list.sel(3) t_minus_front_s__eq__last_t)

(* Sledgehammer previously suggested the following long and potentially non-terminating proof.

  proof -
  have f1: "\<And>x\<^sub>1 x\<^sub>2. drop (length (x\<^sub>1\<Colon>'a list)) (x\<^sub>1 ^\<^sub>t x\<^sub>2) = x\<^sub>2" by simp
  have f2: "Suc (length (front(s)\<^sub>t)) = length s" using assms by auto
  { assume "front(t)\<^sub>t \<noteq> front(s)\<^sub>t"
    moreover
    { assume "drop (length (front(s)\<^sub>t)) t \<noteq> [] \<and> front(t)\<^sub>t \<noteq> front(s)\<^sub>t"
      moreover
      { assume "drop (length (front(s)\<^sub>t)) t \<noteq> [] \<and> front(t)\<^sub>t \<noteq> front(s)\<^sub>t \<and> \<not> [] <\<^sub>t front(drop (length (front(s)\<^sub>t)) t)\<^sub>t"
        moreover
        { assume "drop (length (front(s)\<^sub>t)) t \<noteq> [] \<and> front(t)\<^sub>t \<noteq> front(s)\<^sub>t \<and> \<not> [] <\<^sub>t drop (length (front(s)\<^sub>t)) (front(t)\<^sub>t)"
          moreover
          { assume "drop (length (front(s)\<^sub>t)) t \<noteq> [] \<and> front(t)\<^sub>t \<noteq> front(s)\<^sub>t \<and> \<not> ([]\<Colon>'a list) <\<^sub>t esk1\<^sub>2 (front(s)\<^sub>t) (front(t)\<^sub>t)"
            hence "drop (length (front(s)\<^sub>t)) t \<noteq> [] \<and> front(t)\<^sub>t \<noteq> front(s)\<^sub>t \<and> \<not> 0 < length (esk1\<^sub>2 (front(s)\<^sub>t) (front(t)\<^sub>t))" using sequence_strict_prefix by blast
            hence "drop (length (front(s)\<^sub>t)) t \<noteq> [] \<and> front(t)\<^sub>t \<noteq> front(s)\<^sub>t \<and> \<not> front(s)\<^sub>t <\<^sub>t front(t)\<^sub>t" using sequence_strict_prefix by blast (* > 2 s, timed out *) }
          moreover
          { assume "esk1\<^sub>2 (front(s)\<^sub>t) (front(t)\<^sub>t) \<noteq> drop (length (front(s)\<^sub>t)) (front(t)\<^sub>t) \<and> drop (length (front(s)\<^sub>t)) t \<noteq> [] \<and> front(t)\<^sub>t \<noteq> front(s)\<^sub>t"
            hence "front(s)\<^sub>t ^\<^sub>t esk1\<^sub>2 (front(s)\<^sub>t) (front(t)\<^sub>t) \<noteq> front(t)\<^sub>t \<and> drop (length (front(s)\<^sub>t)) t \<noteq> [] \<and> front(t)\<^sub>t \<noteq> front(s)\<^sub>t" using f1 by metis
            hence "drop (length (front(s)\<^sub>t)) t \<noteq> [] \<and> front(t)\<^sub>t \<noteq> front(s)\<^sub>t \<and> \<not> front(s)\<^sub>t <\<^sub>t front(t)\<^sub>t" using sequence_strict_prefix by blast (* > 2 s, timed out *) }
          ultimately have "front(s)\<^sub>t ^\<^sub>t front(drop (length (front(s)\<^sub>t)) t)\<^sub>t \<noteq> front(t)\<^sub>t \<and> drop (length (front(s)\<^sub>t)) t \<noteq> []" by (metis prefix_def prefixeq_def) }
        ultimately have "front(s)\<^sub>t ^\<^sub>t front(drop (length (front(s)\<^sub>t)) t)\<^sub>t \<noteq> front(t)\<^sub>t \<and> drop (length (front(s)\<^sub>t)) t \<noteq> []" using f1 by metis }
      ultimately have "Suc (length (front(t)\<^sub>t)) = length t \<longrightarrow> (front(s)\<^sub>t <\<^sub>t t \<and> \<not> length s < length t \<longrightarrow> length s = length t) \<or> front(s)\<^sub>t ^\<^sub>t front(drop (length (front(s)\<^sub>t)) t)\<^sub>t \<noteq> front(t)\<^sub>t \<and> drop (length (front(s)\<^sub>t)) t \<noteq> []" using f1 f2 by (metis One_nat_def add_Suc_right append.simps(2) drop_eq_Nil list.size(4) monoid_add_class.add.right_neutral not_less prefix_def) }
    ultimately have "0 < length (drop (length (front(s)\<^sub>t)) t) \<and> Suc (length (front(t)\<^sub>t)) = length t \<longrightarrow> (front(s)\<^sub>t <\<^sub>t t \<and> \<not> length s < length t \<longrightarrow> length s = length t) \<or> front(s)\<^sub>t ^\<^sub>t front(drop (length (front(s)\<^sub>t)) t)\<^sub>t \<noteq> front(t)\<^sub>t \<and> drop (length (front(s)\<^sub>t)) t \<noteq> []" by blast }
  moreover
  { assume "\<not> 0 < length (drop (length (front(s)\<^sub>t)) t)"
    moreover
    { assume "\<not> 0 < length (esk1\<^sub>2 (front(s)\<^sub>t) t\<Colon>'a list)"
      hence "front(s)\<^sub>t <\<^sub>t t \<and> \<not> length s < length t \<longrightarrow> length s = length t" using sequence_strict_prefix by blast (* > 2 s, timed out *) }
    ultimately have "esk1\<^sub>2 (front(s)\<^sub>t) t = drop (length (front(s)\<^sub>t)) t \<longrightarrow> front(s)\<^sub>t <\<^sub>t t \<and> \<not> length s < length t \<longrightarrow> length s = length t" by presburger }
  moreover
  { assume "front(s)\<^sub>t ^\<^sub>t esk1\<^sub>2 (front(s)\<^sub>t) t \<noteq> t"
    hence "front(s)\<^sub>t <\<^sub>t t \<and> \<not> length s < length t \<longrightarrow> length s = length t" using sequence_strict_prefix by blast (* > 2 s, timed out *) }
  ultimately show "front(s)\<^sub>t <\<^sub>t t \<and> \<not> length s < length t \<longrightarrow> length s = length t" using f1 by (metis (no_types) Nitpick.size_list_simp(2) append_is_Nil_conv butlast_append length_butlast length_greater_0_conv length_tl)
qed*)
(*  by (metis Ex_list_of_length Nitpick.size_list_simp(2) One_nat_def Suc_pred add_Suc_right append.simps(1) append.simps(2) append_assoc append_eq_append_conv append_is_Nil_conv assms butlast.simps(1) butlast_append drop_eq_Nil length_butlast length_greater_0_conv length_tl list.distinct(1) list.size(3) list.size(4) list_minus_extended minusList_def monoid_add_class.add.right_neutral not_less prefixeq_def sequence_strict_prefix tl_def)
*)

lemma
  assumes "front(s)\<^sub>t <\<^sub>t t" and "length s > 0" and "length t > 0" and "fst(last(s)\<^sub>t) \<le>\<^sub>t fst(head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t)"
  shows "FlatA(t-\<^sub>tfront(s)\<^sub>t)\<^sub>t -\<^sub>t FlatA([last(s)\<^sub>t])\<^sub>t = FlatA(t)\<^sub>t -\<^sub>t FlatA(front(s)\<^sub>t ^\<^sub>t [last(s)\<^sub>t])\<^sub>t"
  apply (insert FlatA_t_minus_s__eq__FlatA_t_minus_FlatA_s
         [where s="front(s)\<^sub>t" and t=t])
  by (metis FlatA_last_s__eq__fst_last_s FlatA_s_cat_t__eq__Flat_s_cat_Flat_t FlatA_s_non_empty__eq__FlatA_front_s_cat_fst_last_s FlatA_t_minus_FlatA_s__eq__FlatA_t_minus_front_s__minus__FlatA_last_s assms(1) assms(2) assms(4))
(*  by (metis FlatA_t_minus_FlatA_s__eq__FlatA_t_minus_front_s__minus__FlatA_last_s append_butlast_last_id assms(1) assms(2) assms(4) less_nat_zero_code list.size(3)) *)

text {* Proof of Lemma 24. *}
lemma
  assumes "front(s)\<^sub>t <\<^sub>t t" and "length s > 0" and "fst(last(s)\<^sub>t) \<le>\<^sub>t fst(head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t)"
  shows "FlatA(difA(t,s)\<^sub>t)\<^sub>t = FlatA(t)\<^sub>t -\<^sub>t FlatA(s)\<^sub>t"
proof -
  (* Before splitting the cases, enforce that s cannot be smaller than t. *)
  have eq_lengths: "(\<not> length s < length t) = (length s = length t)"
      by (smt2 assms(1) assms(2) not_lenth_s_lt_length_t__eq__length_s_eq_length_t)

  then (* Now we split the cases. *)
  have thesis:"FlatA(difA(t,s)\<^sub>t)\<^sub>t = FlatA(t)\<^sub>t -\<^sub>t FlatA(s)\<^sub>t"
      apply (cases "length s < length t")
      apply auto
      proof -

  (* #s < #t *)
  show "length s < length t \<Longrightarrow> FlatA(difA(t,s)\<^sub>t)\<^sub>t = FlatA(t)\<^sub>t -\<^sub>t FlatA(s)\<^sub>t"
  proof -
    have "FlatA(difA(t,s)\<^sub>t)\<^sub>t = FlatA([(fst (head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t) -\<^sub>t fst (last(s)\<^sub>t), snd (head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t))] ^\<^sub>t
          tail(t -\<^sub>t front(s)\<^sub>t)\<^sub>t)\<^sub>t"
          by (simp add:difA_def)
    also have "... = FlatA([(fst (head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t) -\<^sub>t fst (last(s)\<^sub>t), snd (head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t))])\<^sub>t ^\<^sub>t
          FlatA(tail(t -\<^sub>t front(s)\<^sub>t)\<^sub>t)\<^sub>t"
          by (metis FlatA_s_cat_t__eq__Flat_s_cat_Flat_t)
    also have "... = (fst (head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t) -\<^sub>t fst (last(s)\<^sub>t)) ^\<^sub>t
          FlatA(tail(t -\<^sub>t front(s)\<^sub>t)\<^sub>t)\<^sub>t"
          by (simp add:FlatA_def)
    also have "... = (fst (head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t) -\<^sub>t FlatA([last(s)\<^sub>t])\<^sub>t) ^\<^sub>t
          FlatA(tail(t -\<^sub>t front(s)\<^sub>t)\<^sub>t)\<^sub>t"
          by (simp add:FlatA_def)
    also have "... = (FlatA([head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t])\<^sub>t -\<^sub>t FlatA([last(s)\<^sub>t])\<^sub>t) ^\<^sub>t
          FlatA(tail(t -\<^sub>t front(s)\<^sub>t)\<^sub>t)\<^sub>t"
          by (simp add:FlatA_def)
    also have "... = (FlatA([head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t])\<^sub>t ^\<^sub>t
          FlatA(tail(t -\<^sub>t front(s)\<^sub>t)\<^sub>t)\<^sub>t -\<^sub>t FlatA([last(s)\<^sub>t])\<^sub>t)"
          apply (insert assms(3))
          apply (insert t_minus_s_cat_z__eq__t_cat_z_minus_s
                [where t="FlatA([head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t])\<^sub>t"
                   and s="FlatA([last(s)\<^sub>t])\<^sub>t"
                   and z="FlatA(tail(t -\<^sub>t front(s)\<^sub>t)\<^sub>t)\<^sub>t"])
          by (simp add:FlatA_def)
    also have "... = (FlatA([head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t] ^\<^sub>t
          tail(t -\<^sub>t front(s)\<^sub>t)\<^sub>t)\<^sub>t -\<^sub>t FlatA([last(s)\<^sub>t])\<^sub>t)"
          by (metis FlatA_s_cat_t__eq__Flat_s_cat_Flat_t)
    also have "... = (FlatA(t -\<^sub>t front(s)\<^sub>t)\<^sub>t -\<^sub>t FlatA([last(s)\<^sub>t])\<^sub>t)"
          by (metis append_Cons append_Nil append_Nil2 assms(1) calculation list.collapse list_minus_extended prefix_order.less_imp_le prefix_order.less_irrefl prefixeqE)
    also have "... = FlatA(t)\<^sub>t -\<^sub>t FlatA(front(s)\<^sub>t ^\<^sub>t [last(s)\<^sub>t])\<^sub>t"
          apply (insert assms(1))
          apply (insert assms(2))
          apply (insert assms(3))
          apply (insert FlatA_t_minus_FlatA_s__eq__FlatA_t_minus_front_s__minus__FlatA_last_s
                [where s=s and t=t])
          by (simp_all)
    also have "... = FlatA(t)\<^sub>t -\<^sub>t FlatA(s)\<^sub>t"
         apply (insert assms(2))
         by (metis append_butlast_last_id less_numeral_extra(3) list.size(3))
    finally show ?thesis .
   qed

   (* #s = #t *)
   next
     show "length s = length t \<Longrightarrow> FlatA(difA(t,s)\<^sub>t)\<^sub>t = FlatA(t)\<^sub>t -\<^sub>t FlatA(s)\<^sub>t"

     proof - (* In order to reference the assumption again, we create a label here. *)
     assume 0: "length s = length t"
     have "FlatA(difA(t,s)\<^sub>t)\<^sub>t = FlatA([(fst (head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t) -\<^sub>t fst (last(s)\<^sub>t), snd (head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t))] ^\<^sub>t
          tail(t -\<^sub>t front(s)\<^sub>t)\<^sub>t)\<^sub>t"
          by (simp add:difA_def)
     also have "... = FlatA([(fst (head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t) -\<^sub>t fst (last(s)\<^sub>t), snd (head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t))])\<^sub>t"
          using assms and 0 (* Now can use the assumption above. *)
          by (simp add:tail_t_minus_front_s_eq_lengths__eq__empty)
     also have "... = fst (head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t) -\<^sub>t fst (last(s)\<^sub>t)"
          using assms and 0
          by (metis FlatA_head_s__eq__fst_head_s fst_conv length_greater_0_conv list.distinct(1) list.sel(1))
     also have "... = FlatA(t -\<^sub>t front(s)\<^sub>t)\<^sub>t -\<^sub>t fst(last(s)\<^sub>t)"
          using assms and 0
          by (metis FlatA_head_s__eq__fst_head_s length_greater_0_conv list.distinct(1) list.sel(1) t_minus_front_s__eq__last_t)
     also have "... = (FlatA(t)\<^sub>t -\<^sub>t FlatA(front(s)\<^sub>t)\<^sub>t) -\<^sub>t fst(last(s)\<^sub>t)"
          using assms
          by (metis FlatA_t_minus_front_s__eq__FlatA_t_minus_FlatA_front_s)
     also have "... = (FlatA(t)\<^sub>t -\<^sub>t FlatA(front(s)\<^sub>t)\<^sub>t) -\<^sub>t FlatA([last(s)\<^sub>t])\<^sub>t"
          by (metis FlatA_last_s__eq__fst_last_s assms(2))
     also have "... = FlatA(t)\<^sub>t -\<^sub>t (FlatA(front(s)\<^sub>t)\<^sub>t ^\<^sub>t FlatA([last(s)\<^sub>t])\<^sub>t)"
          by (metis FlatA_last_s__eq__fst_last_s FlatA_s_cat_t__eq__Flat_s_cat_Flat_t FlatA_t_minus_FlatA_s__eq__FlatA_t_minus_front_s__minus__FlatA_last_s `FlatA(t -\<^sub>t front(s)\<^sub>t)\<^sub>t -\<^sub>t fst (last(s)\<^sub>t) = (FlatA(t)\<^sub>t -\<^sub>t FlatA(front(s)\<^sub>t)\<^sub>t) -\<^sub>t fst (last(s)\<^sub>t)` append_butlast_last_id assms(1) assms(2) assms(3) less_nat_zero_code list.size(3))
     also have "... = FlatA(t)\<^sub>t -\<^sub>t FlatA(front(s)\<^sub>t ^\<^sub>t [last(s)\<^sub>t])\<^sub>t"
          by (metis FlatA_s_cat_t__eq__Flat_s_cat_Flat_t)
     also have "... = FlatA(t)\<^sub>t -\<^sub>t FlatA(s)\<^sub>t"
          using assms
          by (metis append_butlast_last_id length_greater_0_conv)
     finally show ?thesis .
     qed

     next
        show "length s < length t \<Longrightarrow> length s < length t" by auto qed
     then
        show "FlatA(difA(t,s)\<^sub>t)\<^sub>t = FlatA(t)\<^sub>t -\<^sub>t FlatA(s)\<^sub>t" by (simp)
qed

lemma length_tail_t_minus_s__eq__length_t_minus_s_plus_one:
  assumes "s <\<^sub>t t"
  shows "length(tail(t-\<^sub>ts)\<^sub>t) = length(t-\<^sub>ts) - 1"
  by (auto)

lemma length_t_minus_s__eq__length_t_minus_length_s:
  assumes "s <\<^sub>t t"
  shows "length(t -\<^sub>t s) = length(t) - length(s)"
  by (metis length_drop minusList_def)

text {* Lemma 26 *}
lemma length_difA_t_s__eq__length_t_minus_length_s_plus_one:
  assumes "front(s)\<^sub>t <\<^sub>t t" and "length s > 0"
  shows "length(difA(t,s)\<^sub>t) = (length t - length s) + 1"
proof -
  have "length(difA(t,s)\<^sub>t) = length(tail(t-\<^sub>t front(s)\<^sub>t)\<^sub>t) + 1"
      by (simp add:difA_def)
  also have "... = length(t-\<^sub>t front(s)\<^sub>t) - 1 + 1"
      by auto
  also have "... = length(t-\<^sub>t front(s)\<^sub>t)"
      by (metis (no_types, hide_lams) Ex_list_of_length One_nat_def append_butlast_last_id assms(1) calculation length_append length_butlast list.size(4) list_minus_empty list_minus_extended prefix_def sequence_strict_prefix)
  also have "... = length(t) - length(front(s)\<^sub>t)"
      using assms
      by (simp add:length_t_minus_s__eq__length_t_minus_length_s)
  also have "... = length(t) - length(s) + 1"
      using assms
      by (metis (erased, hide_lams) Suc_eq_plus1 Suc_pred `length (t -\<^sub>t front(s)\<^sub>t) = length t - length (front(s)\<^sub>t)` `length (t -\<^sub>t front(s)\<^sub>t) - 1 + 1 = length (t -\<^sub>t front(s)\<^sub>t)` diff_diff_left length_butlast monoid_add_class.add.left_neutral)
  finally show ?thesis .
qed

lemma difA_t_s__eq__list_u_v:
  assumes "front(s)\<^sub>t <\<^sub>t t" and "length s > 0" and "fst(last(s)\<^sub>t) \<le>\<^sub>t fst(head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t)"
  shows "difA(t,s)\<^sub>t = [(u,v)] \<longleftrightarrow> (fst(head(t-\<^sub>t front(s)\<^sub>t)\<^sub>t) -\<^sub>t fst(last(s)\<^sub>t)) = u \<and> snd(head(t-\<^sub>tfront(s)\<^sub>t)\<^sub>t) = v \<and> tail(t-\<^sub>tfront(s)\<^sub>t)\<^sub>t = []"
  by (metis (no_types, hide_lams) append_Nil append_Nil2 difA_def list.distinct(1) list.sel(1) list.sel(3) prod.inject tl_append2)

text {* Corresponds to Lemma 15. *}
lemma difA_t_s__eq__list_empty_snd_last_s__iff__t__eq__s:
  assumes "front(s)\<^sub>t <\<^sub>t t" and "length s > 0" and "fst(last(s)\<^sub>t) \<le>\<^sub>t fst(head(t -\<^sub>t front(s)\<^sub>t)\<^sub>t)"
  shows "difA(t,s)\<^sub>t = [([],snd(last(s)\<^sub>t))] \<longleftrightarrow> t=s"
  using assms
  apply (simp add:difA_t_s__eq__list_u_v)
  apply auto
  apply (smt2 append_Nil append_Nil2 append_butlast_last_id butlast.simps(1) butlast_tl length_greater_0_conv list.distinct(1) list.sel(1) list_minus_extended prod.expand sequence_prefix sequence_strict_prefix tl_append2)
  apply (metis append_Nil2 append_butlast_last_id list.sel(1) list_minus_extended)
  apply (metis append_butlast_last_id list.sel(1) list_minus_extended)
  by (metis drop_eq_Nil length_butlast length_tl minusList_def order_refl tl_drop)

lemma
  assumes "length s > 0"
  shows "front(s)\<^sub>t <\<^sub>t t \<longrightarrow> t = front(s)\<^sub>t ^\<^sub>t (t -\<^sub>t front(s)\<^sub>t)"
  by (metis list_minus_extended sequence_strict_prefix)

lemma front_s_lt_t__iff__t_eq_front_s_cat_t_minus_front_s:
  assumes "length s > 0" and "length s \<le> length t"
  shows "front(s)\<^sub>t <\<^sub>t t \<longleftrightarrow> t = front(s)\<^sub>t ^\<^sub>t (t -\<^sub>t front(s)\<^sub>t)"
  by (metis One_nat_def Suc_pred assms(1) assms(2) length_butlast lessI list_minus_extended not_less prefix_def prefixeq_def)

lemma
  assumes "length s > 0"
  shows "s \<le>\<^sub>t t \<longleftrightarrow> t = s ^\<^sub>t (t -\<^sub>t s)"
  by (metis list_minus_extended prefixeq_def)

text {* One needs to be careful with the treatment of subtraction for naturals,
        otherwise length(tail(s)) = length(s) - 1, even without provisos. This
        is acceptable for lists and in the context of HOL, but not for our
        representation of sequences. *}

lemma
  assumes "length s > 0"
  shows "int(length(tail(s)\<^sub>t)) = int(length(s)) + (-1)"
  using assms
  by (auto, metis Nitpick.size_list_simp(2) One_nat_def add.commute eq_diff_eq length_tl of_nat_Suc)

lemma
  assumes "length s > 0"
  shows "length(tail(s)\<^sub>t) = length(s) - 1"
  using assms
  by (simp add:nat_diff_split)

lemma difA_t_lseq_s_rseq:
  shows "difA(t,[s])\<^sub>t = [(fst(head(t)\<^sub>t) -\<^sub>t fst(s), snd(head(t)\<^sub>t))] ^\<^sub>t tail(t)\<^sub>t"
  by (metis append_Nil butlast_snoc difA_def last_snoc list_minus_empty)

lemma head_difloc:
  shows "head(difloc(c,t,s))\<^sub>t = (c, snd(head(t-\<^sub>tfront(s)\<^sub>t)\<^sub>t))"
  by (metis append_Cons difloc_def list.sel(1))

lemma tail_difloc:
  shows "tail(difloc(c,t,s))\<^sub>t = tail(t-\<^sub>tfront(s)\<^sub>t)\<^sub>t"
  by (metis append_Cons append_Nil difloc_def list.sel(3))

lemma difA_difloc:
  shows "difA(difloc(c,t,[s]),[s])\<^sub>t = [((c-\<^sub>tfst(s)),snd(head(t)\<^sub>t))] ^\<^sub>t tail(t)\<^sub>t"
  by (metis (erased, hide_lams) append_Nil butlast_snoc difA_t_lseq_s_rseq fst_conv head_difloc list_minus_empty snd_conv tail_difloc)

lemma difA_difloc_cts_seq_z:
  shows "difA(difloc(c,t,s),[z])\<^sub>t = [(c -\<^sub>t fst(z), snd(head(t-\<^sub>tfront(s)\<^sub>t)\<^sub>t))] ^\<^sub>t tail(t-\<^sub>tfront(s)\<^sub>t)\<^sub>t"
  by (metis append_Cons append_Nil difA_t_lseq_s_rseq difloc_def fst_conv list.sel(1) list.sel(3) snd_conv)

lemma s_cat_t__minus__s_cat_z__eq__t_minus_z_no_proviso:
  shows "(s ^\<^sub>t t) -\<^sub>t (s ^\<^sub>t z) = t -\<^sub>t z"
  by (simp add:minusList_def)

lemma difA_difloc__:
  shows "difA(
        difloc(FlatA(front(tr)\<^sub>t)\<^sub>t ^\<^sub>t fst(head(tr' -\<^sub>t front(tr)\<^sub>t)\<^sub>t),tr',tr),
        [(FlatA(front(tr)\<^sub>t)\<^sub>t ^\<^sub>t fst(last(tr)\<^sub>t), snd(last(tr)\<^sub>t))]
        )\<^sub>t
        =
        difA(tr',tr)\<^sub>t"
   apply (simp add:difA_difloc_cts_seq_z)
   apply (simp add:s_cat_t__minus__s_cat_z__eq__t_minus_z_no_proviso)
   by (metis append_Cons append_Nil difA_def)

lemma length_t_eq_length_s__land_front_s_lt_t__implies__front_s_eq_front_t:
  shows "length t = length s \<and> front(s)\<^sub>t <\<^sub>t t \<longrightarrow> front(s)\<^sub>t = front(t)\<^sub>t"
  by (metis (erased, hide_lams) append_butlast_last_id append_same_eq list_minus_extended prefix_bot.bot.not_eq_extremum prefix_order.dual_order.strict_trans sequence_strict_prefix t_minus_front_s__eq__last_t)

lemma length_t_eq_length_s__land_front_s_lt_t__iff__front_s_eq_front_t:
  assumes "length s > 0" and "length t > 0"
  shows "length t = length s \<and> front(s)\<^sub>t <\<^sub>t t \<longleftrightarrow> front(s)\<^sub>t = front(t)\<^sub>t"
  by (metis Suc_eq_plus1 Suc_pred append_butlast_last_id assms(1) assms(2) length_butlast length_greater_0_conv length_t_eq_length_s__land_front_s_lt_t__implies__front_s_eq_front_t list.distinct(1) monoid_add_class.add.left_neutral prefix_def prefixeq_def self_append_conv)

lemma t__eq__s__iff__FlatA_eq_and_length_eq_and_fronts_lt_t_and_snd_last_eq:
  assumes "length s > 0" and "length t > 0"
  shows "FlatA(t)\<^sub>t = FlatA(s)\<^sub>t \<and> length t = length s \<and> front(s)\<^sub>t <\<^sub>t t \<and> snd(last(s)\<^sub>t) = snd(last(t)\<^sub>t)
         \<longleftrightarrow>
         t = s"
  using assms
  apply auto
  apply (metis FlatA_s_non_empty__eq__FlatA_front_s_cat_fst_last_s append_butlast_last_id assms(1) length_t_eq_length_s__land_front_s_lt_t__implies__front_s_eq_front_t prod.collapse same_append_eq)
  by (metis append_butlast_last_id list.distinct(1) prefix_def prefixeq_def self_append_conv)

lemma shows "int(length []) = (int(length []) + (- 1))"
oops

text
{* The stuff below is an attempt at converting between lists and sets of ordered
   pairs. The function definitions work, but there isn't much proved about them. *}

primrec listToSet :: "nat \<Rightarrow> 'a list \<Rightarrow> (nat \<times> 'a) set"
where
  "listToSet n [] = {}"
| "listToSet n (x#xs) = {(n, x)} \<union> (listToSet (n+1) xs)"

definition setMapFst :: "('a \<times> 'b) set \<Rightarrow> 'a set"
 where "setMapFst xs = { x | x y. (x,y) \<in> xs}"

lemma "sorted_list_of_set {1::nat,2} = [1,2]"
 by auto

lemma
 assumes "a < b"
 shows "sorted_list_of_set {a,b} = [a,b]"
 using assms
 by auto

lemma len_a__eq__len_b__implies__front_a__noteq__b:
  shows "length a > 0 \<and> length a = length b \<longrightarrow> front(a)\<^sub>t \<noteq> b"
  by (metis Suc_eq_plus1 Suc_pred length_butlast monoid_add_class.add.left_neutral n_not_Suc_n)

lemma len_a__lt__len_b__implies__front_a__noteq__b:
  shows "length a > 0 \<and> length a < length b \<longrightarrow> front(a)\<^sub>t \<noteq> b"
  by (metis One_nat_def Suc_pred length_butlast lessI not_less_iff_gr_or_eq)

lemma len_a__le__len_b__implies__front_a__noteq__b:
  shows "length a > 0 \<and> length a \<le> length b \<longrightarrow> front(a)\<^sub>t \<noteq> b"
  by (metis len_a__eq__len_b__implies__front_a__noteq__b len_a__lt__len_b__implies__front_a__noteq__b nat_less_le)

lemma front_a_lt_b__resultof__length_a_lt_length_b_and_front_a_lt_b:
  shows "length a > 0 \<and> length a \<le> length b \<and> front(a)\<^sub>t \<le>\<^sub>t b
        \<longleftrightarrow>
        length a > 0 \<and> length a \<le> length b \<and> front(a)\<^sub>t <\<^sub>t b"
  by (metis len_a__le__len_b__implies__front_a__noteq__b prefix_def)

definition setToList :: "('a \<times> 'b) set \<Rightarrow> 'b list"
 where "Finite_Set.fold

value "{1,2}-{1}"

value "set [0,0::nat]"

schematic_lemma "set [0,0::nat] = ?x"
by simp

schematic_lemma "sorted_list_of_set {2,1,2,2,1} = ?x"
by simp_all

value "insort 2 (sorted_list_of_set ({1, 2, 1} - {2}))"

value "Finite_Set.fold Set.remove {1,2} {1}"

lemma "Finite_Set.fold Set.remove {1,2} {1} = {1,2}-{1}"
 apply (simp add:Finite_Set.minus_fold_remove)

value "fold f (\<lambda>x. x + 1) {1,2}"

type_synonym 'b listNPairs = "(nat \<times> 'b) set ::linorder"
value "sorted_list_of_set {(1,a),(2,b)}"

value "fold insort []"

function setToList :: "'a set \<Rightarrow> 'a list"
 where "setToList {} = []"
| "setToList {a} = [a]"
| "setToList (xs \<union> ys) = setToList xs @ setToList ys"
apply atomize_elim
apply simp_all
apply auto
apply
(*
function setMapFst :: "('a \<times> 'b) set \<Rightarrow> 'a set"
 where
  "setMapFst {} = {}"
| "setMapFst {a} = {fst a}"
| "setMapFst (xs \<union> {a::('a \<times> 'b)}) = {fst a} \<union> setMapFst (xs-{a})"
apply atomize_elim
apply simp_all
apply (metis Set.set_insert old.prod.exhaust subsetI subset_empty)
sledgehammer
apply auto
sledgehammer
termination by lexicographic_order
 apply (induct)
 apply (auto)
 sledgehammer
*)
(*| "setMapFst (xs\<union>{ax::('a \<times> 'b)}) = {fst ax} \<union> setMapFst xs"
*)
(*|"setMapFst xs = if (\<exists>a b. (a,b) \<in> xs) then (a \<union> (setMapFst (xs\<setminus>{(a,b)}))) else {}"
*)
primrec setToList :: "nat \<Rightarrow> (nat \<times> 'a) set \<Rightarrow> 'a list"
  where
  "setToList n {} = []"
| "setToList n xs = \<exists>z y. (z,y) \<in> xs \<and> z = min(xs

definition set_to_list :: "(nat \<times> 'a) set \<Rightarrow> 'a list"
  where "set_to_list s = (SOME l. listToSet 1 l = s)"

definition update_list_set :: "nat \<Rightarrow> (nat \<times> 'a) set \<Rightarrow> (nat \<times> 'a) set"
  where "update_list_set i s = {(n+i,x) | n x.(n,x) \<in> s}"

value "update_list_set 1 {(1,2),(3,4)}"

value "update_list_set 0 {}"

lemma list_to_set_induct[simp]:
  "listToSet i (x#xs) = (listToSet i [x]) \<union> (listToSet (i+1) xs)"
  by auto

lemma list_set_update_no_change:
  shows "listToSet i xs = update_list_set 0 (listToSet i xs)"
  apply (induct xs)
  apply (simp_all add:update_list_set_def)
  apply (auto)
  done

end
(*
lemma "listToSet i xs = update_list_set i (listToSet 0 xs)"
  apply (simp_all add:update_list_set_def)
  apply auto
  apply (rule_tac ?x = "a-i" in exI)
  apply (auto)
  oops

lemma "listToSet (i+1) xs = update_list_set 1 (listToSet i xs)"
  apply (induct_tac i)
  apply (simp_all add:update_list_set_def)
  apply auto
  oops

lemma "\<forall>n.(n, x) \<in> listToSet 1 l \<longrightarrow> n \<le> length l"
  apply (induct l)
  apply auto
  oops

lemma list_to_set_never_greater:
  "\<forall>n. n < i \<longrightarrow> (n,x) \<notin> listToSet i l"
  apply (induct l)
  apply auto
  oops

lemma "\<forall>x. length l \<noteq> 0 \<and> x \<in> {n | n y.(n,y) \<in> listToSet i l} \<longrightarrow> i \<le> x"
  apply auto
  oops

lemma "\<forall>n. (n,x) \<in> listToSet (Suc i) l \<longrightarrow> i < n"
  apply (induct_tac l)
  apply (auto)
  apply (simp add:listToSet_def)
  apply auto
  oops

lemma "\<forall>n. (n,x) \<in> listToSet i l \<longrightarrow> (n+1,x) \<in> listToSet (Suc i) l"
  apply auto
  oops

lemma list_to_set_single: "listToSet i [x] = {(i,x)}"
  apply auto
  done

lemma list_to_set_multiple: "listToSet i (x#xs) = {(i,x)} \<union> listToSet (Suc i) xs"
  apply auto
  done

lemma "\<forall>n.\<exists>m. (n,a) \<in> (listToSet i x) \<and> (m,b) \<in> (listToSet i (x#xs)) \<and> n < m"
  oops

lemma "\<forall>n x. (n,x) \<in> listToSet i xs \<longrightarrow> i \<le> n"
  apply (induct xs)
  apply (metis empty_iff listToSet.simps(1))
  apply (subst list_to_set_multiple)
  apply simp
  apply auto
  apply (simp add:listToSet_def)
  oops

lemma "{n | n. (n,x) \<in> listToSet 1 l} = {1..length l}"
  apply auto
  unfolding listToSet_def
  sledgehammer
  oops

lemma  set_set_to_list:
   "finite s \<Longrightarrow> listToSet 1 (set_to_list s) = s"
   apply (simp add:set_to_list_def)
   apply (simp add:listToSet_def)

value "set_to_list {(1,a),(3,b)}"

value "sorted_list_of_set {(1,a),(2,b)}"

function setToList :: "nat \<Rightarrow> (nat \<times> 'a) set \<Rightarrow> 'a list"
where
 "setToList n {} = []"
 "setToList n x =

(* where "listToSet n (setToList n ss)"*)

(*where "(listToSet ni (setToList ni s)) = s"*)

(* where "\<exists>li. (setToList ni s) = li \<and> (listToSet ni li) = s" *)

primrec setToList2 :: "nat \<Rightarrow> (nat \<times> 'a) set \<Rightarrow> 'a list"
where
  "setToList2 n {} = []"
| "setToList2 n (xs-{(n,x)}) = x#(setToList (n+1) xs)"

value "setToList 1 {(1,2)}"

value "card (set [1,2,1,3,2])"

value "remdups [1, 2, 1]"
*)


(*  Title:      Native_Word_Test_Emu.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

theory Native_Word_Test_Emu imports
  Native_Word_Test
  Code_Target_Bits_Int
begin

section {* Test cases for emulation of native words *}

subsection {* Tests for @{typ uint16} *}

text {*
  Test that @{typ uint16} is emulated for PolyML and OCaml via @{typ "16 word"}
  if @{theory Code_Target_Bits_Int} is imported.
*}

definition test_uint16_emulation :: bool where
  "test_uint16_emulation \<longleftrightarrow> (0xFFFFF - 0x1000 = (0xEFFF :: uint16))"

export_code test_uint16_emulation checking SML OCaml?
  -- {* test the other target languages as well *} Haskell? Scala

notepad begin
have test_uint16 by eval
have test_uint16_emulation by eval
have test_uint16_emulation by normalization
have test_uint16_emulation by code_simp
end

ML_val {*
  val true = @{code test_uint16};
  val true = @{code test_uint16_emulation};
*}

lemma "x AND y = x OR (y :: uint16)"
quickcheck[random, expect=counterexample]
quickcheck[exhaustive, expect=counterexample]
oops

subsection {* Tests for @{typ uint8} *}

text {*
  Test that @{typ uint8} is emulated for OCaml via @{typ "8 word"}
  if @{theory Code_Target_Bits_Int} is imported.
*}

definition test_uint8_emulation :: bool where
  "test_uint8_emulation \<longleftrightarrow> (0xFFF - 0x10 = (0xEF :: uint8))"

export_code test_uint8_emulation checking OCaml?
  -- {* test the other target languages as well *} SML Haskell? Scala

end


section \<open>Using the axioms\<close>

theory CatLValue
  imports CatLValue_Axioms_Mat
begin

definition
  \<open>compatible x y \<longleftrightarrow> (is_lvalue x \<and> is_lvalue y \<and> (\<forall>f g. (x \<cdot> f) o\<^sub>m (y \<cdot> g) = (y \<cdot> g) o\<^sub>m (x \<cdot> f)))\<close>

(* definition
  \<open>pair x y = (THE xy. \<forall>f g. xy \<cdot> (f \<otimes> g) = (x \<cdot> f) o\<^sub>m (y \<cdot> g))\<close> *)

(* lemma pair_apply[simp]:
  assumes "compatible x y"
  shows "pair x y \<cdot> (f \<otimes> g) = (x \<cdot> f) o\<^sub>m (y \<cdot> g)"
  apply (rule pair_apply0) using assms by (simp add: compatible_def) *)

declare pair_apply[simp]
declare lvalue_id[simp]
declare lvalue_comp_app[simp]
(* declare lvalue_tensor_app[simp] *)
declare left_tensor_apply[simp]
declare swap_apply[simp]
declare assoc_apply[simp]
declare assoc'_apply[simp]

lemma compatibleI:
  assumes "is_lvalue x" and "is_lvalue y"
  assumes \<open>\<And>f g. (x \<cdot> f) o\<^sub>m (y \<cdot> g) = (y \<cdot> g) o\<^sub>m (x \<cdot> f)\<close>
  shows "compatible x y"
  using assms unfolding compatible_def by simp

(* lemma compatibleI:
  assumes "\<And>f g. pair x y \<cdot> (f \<otimes> g) = pair y x \<cdot> (g \<otimes> f)"
  shows "compatible x y"
  using assms unfolding compatible_def by simp *)

(* lemma compatibleI':
  assumes "pair x y = pair y x o\<^sub>l swap"
  shows "compatible x y"
  apply (rule compatibleI)
  by (simp add: assms) *)

definition "chain x y = x o\<^sub>l y"

lemma compatible_sym: "compatible x y \<Longrightarrow> compatible y x"
  by (simp add: compatible_def)

lemma lvalue_app_fun_cong: "f = g \<Longrightarrow> f \<cdot> x = g \<cdot> x" by simp

lemma compatible3:
  assumes [simp]: "compatible x y" and "compatible y z" and "compatible x z"
  shows "compatible (pair x y) z"
proof (rule compatibleI)
  have "pair (pair x y) z \<cdot> (f \<otimes> g) \<otimes> h = pair z (pair x y) \<cdot> h \<otimes> (f \<otimes> g)" for f g h
    apply auto using assms unfolding compatible_def
    by (metis maps_comp_assoc)
  then have "(pair (pair x y) z o\<^sub>l swap o\<^sub>l left_tensor h) \<cdot> (f \<otimes> g)
           = (pair z (pair x y) o\<^sub>l left_tensor h) \<cdot> (f \<otimes> g)" for f g h
    by auto
  then have *: "(pair (pair x y) z o\<^sub>l swap o\<^sub>l left_tensor h)
           = (pair z (pair x y) o\<^sub>l left_tensor h)" for h
    by (rule tensor_extensionality)
  have "(pair (pair x y) z) \<cdot> (fg \<otimes> h)
           = (pair z (pair x y)) \<cdot> (h \<otimes> fg)" for fg h
    using *[THEN lvalue_app_fun_cong]
    by auto
  then show "(pair x y \<cdot> fg) o\<^sub>m (z \<cdot> h) = (z \<cdot> h) o\<^sub>m (pair x y \<cdot> fg)" for fg h
    unfolding compatible_def by simp
  show "is_lvalue z"
    using assms(2) compatible_def by auto
  show "is_lvalue (pair x y)"
    by (meson assms(1) compatible_def pair_is_lvalue0)
qed

lemma compatible_chain_left: "compatible x y \<Longrightarrow> is_lvalue z \<Longrightarrow> compatible (chain x z) y"
  by (auto simp: chain_def comp_is_lvalue compatible_def)

lemma compatible_chain_inner:
  "compatible x y \<Longrightarrow> is_lvalue z \<Longrightarrow> compatible (chain z x) (chain z y)"
  by (auto simp flip: lvalue_app_mult simp: compatible_def chain_def comp_is_lvalue)

definition is_everything where
  "is_everything x \<longleftrightarrow> (\<exists>y. y o\<^sub>l x = 1\<^sub>l)"

(* definition is_everything where
  "is_everything x \<longleftrightarrow> inj (lvalue_app x)" *)

definition is_complement where
  "is_complement x y \<longleftrightarrow> compatible x y \<and> is_everything (pair x y)"

(* definition is_complement2 where
  "is_complement2 x y \<longleftrightarrow> compatible x y \<and> is_everything2 (pair x y)" *)

lemma tensor_extensionality3:
  assumes "\<And>f g h. x \<cdot> (f \<otimes> (g \<otimes> h)) = y \<cdot> (f \<otimes> g \<otimes> h)"
  shows "x = y"
  using [[show_sorts]]
proof -
  from assms
  have "x o\<^sub>l left_tensor f \<cdot> (g \<otimes> h) = y o\<^sub>l left_tensor f \<cdot> (g \<otimes> h)" for f g h
    by auto
  then have "x o\<^sub>l left_tensor f = y o\<^sub>l left_tensor f" for f
    by (rule tensor_extensionality)
  then have "x \<cdot> (f \<otimes> gh) = y \<cdot> (f \<otimes> gh)" for f gh
    by (metis (no_types, lifting) left_tensor_apply lvalue_comp_app)
  then show ?thesis
    by (rule tensor_extensionality)
qed

(* TODO: Can we do this without lvalue_tensor? *)
lemma complement_chain:
  assumes "is_complement x x'"
  assumes "is_complement y y'"
  shows "is_complement (chain x y) (pair (chain x y') x')"
proof (simp add: is_complement_def, rule)
  have xx'[simp]: "compatible x x'" and yy'[simp]: "compatible y y'"
    and x'x[simp]: "compatible x' x" and y'y[simp]: "compatible y' y"
    using assms is_complement_def compatible_sym by blast+
  then have [simp]: "is_lvalue x" "is_lvalue x'" "is_lvalue y" "is_lvalue y'"
    using compatible_def by blast+
  show compat: "compatible (chain x y) (pair (chain x y') x')"
    apply (rule compatible_sym)
    apply (rule compatible3)
      apply (rule compatible_chain_left, simp, simp)
     apply (rule compatible_sym)
    apply (rule compatible_chain_left, simp, simp)
    by (rule compatible_chain_inner, simp_all)
  from assms(1)
  obtain xInv where xInv: "xInv \<cdot> pair x x' \<cdot> f = f" for f
    unfolding is_complement_def is_everything_def
    by (metis lvalue_comp_app lvalue_id)
  from assms(2)
  obtain yInv where yInv: "yInv \<cdot> pair y y' \<cdot> f = f" for f
    unfolding is_complement_def is_everything_def
    by (metis lvalue_comp_app lvalue_id)

  define z where "z = assoc' o\<^sub>l lvalue_tensor yInv 1\<^sub>l o\<^sub>l xInv"
  have "z o\<^sub>l pair (chain x y) (pair (chain x y') x') \<cdot> (f \<otimes> (g \<otimes> h)) = (f \<otimes> (g \<otimes> h))" for f g h
  proof -
    have "pair (chain x y) (pair (chain x y') x') \<cdot> (f \<otimes> (g \<otimes> h))
      = (x \<cdot> y \<cdot> f) o\<^sub>m (x \<cdot> y' \<cdot> g) o\<^sub>m (x' \<cdot> h)"
      by (simp add: maps_comp_assoc chain_def)
    moreover have "\<dots> = (x \<cdot> (pair y y') \<cdot> (f \<otimes> g)) o\<^sub>m (x' \<cdot> h)"
      by (simp add: lvalue_app_mult)
    moreover have "\<dots> = (pair x x') \<cdot> ((pair y y' \<cdot> (f \<otimes> g)) \<otimes> h)"
      by simp
    moreover have "xInv \<cdot> ... = ((pair y y' \<cdot> (f \<otimes> g)) \<otimes> h)"
      using xInv apply simp by (metis pair_apply)
    moreover have "lvalue_tensor yInv 1\<^sub>l \<cdot> \<dots> = (f \<otimes> g) \<otimes> h"
      using yInv apply simp
      by (metis lvalue_id lvalue_tensor_app pair_apply yInv)
    moreover have "assoc' \<cdot> \<dots> = f \<otimes> (g \<otimes> h)"
      by simp
    ultimately show ?thesis
      unfolding z_def by simp
  qed

  then have "z o\<^sub>l pair (chain x y) (pair (chain x y') x') = 1\<^sub>l"
    by (rule_tac tensor_extensionality3, simp)
  then show "is_everything (pair (chain x y) (pair (chain x y') x'))"
    unfolding is_everything_def by auto
qed

end