theory Kernel
  imports Main
begin

section \<open>Task\<close>
subsection \<open>2\<close>
type_synonym ty_name = "char list"

datatype type =
  Ty_Var ty_name ("_:*" [1000] 999) |
  Fun type type (infixr "\<rightarrow>>" 600)

(*test*)
(*
term "''a'':*"
term "''a'':* \<rightarrow>> ''b'':*"
*)

subsection \<open>3\<close>
\<comment> \<open>variable name\<close>
type_synonym name = "nat"

text \<open>
If you want to print terms,
please use following definitions instead
and do so for other functions similarly.
\<close>
(*printable version*)
(*
datatype name = X | Y | Z | W
fun "next" :: "name \<Rightarrow> name" where
  "next X = Y" |
  "next Y = Z" |
  "next Z = W" |
  "next W = X"
lemma UNIV_name:
  "UNIV = {X, Y, Z, W}"
  by (auto intro: name.exhaust)
instantiation name :: enum
begin
definition
  "enum_name = [X, Y, Z, W]"
definition
  "enum_all_name P \<longleftrightarrow> P X \<and> P Y \<and> P Z \<and> P W"
definition
  "enum_ex_name P \<longleftrightarrow> P X \<or> P Y \<or> P Z \<or> P W"
instance by (intro_classes, auto simp add: enum_name_def enum_all_name_def enum_ex_name_def UNIV_name)
end
*)

datatype "term" =
  Var name type ("_::_" 500) |
  Abs name type "term" ("\<lambda>_::_. _>" [1000, 998, 499] 999) |
  App "term" "term" ("|[_ _]|")

(*test*)
(*
term "0::''a'':*"
term "\<lambda>0:: ''a'':*. 0::''a'':*>"
term "|[\<lambda>0:: ''a'':*. 0::''a'':*> 0::''a'':*]|"
*)

subsection \<open>4\<close>
fun type_of :: "term \<Rightarrow> type option" where
  "type_of (Var n t) = Some t" |
  "type_of (Abs n T t) = (case type_of t of
    Some T' \<Rightarrow> Some (Fun T T') |
    None \<Rightarrow> None)" |
  "type_of (App t1 t2) = (case type_of t1 of
    Some (Fun T1 T2) \<Rightarrow> if Some T1 = type_of t2 then Some T2 else None |
    _ \<Rightarrow> None)"

(*test*)
(*
lemma "type_of |[0::''a'':* 1::''b'':*]| = None" by simp
*)

type_synonym env = "name \<rightharpoonup> type"

fun env_of :: "term \<Rightarrow> env" where
  "env_of (Var n T) = [n \<mapsto> T]" |
  "env_of (Abs n T t) = (env_of t)(n := None)" |
  "env_of (App t1 t2) = env_of t1 ++ env_of t2"

fun well_typed :: "term \<Rightarrow> bool" where
  "well_typed (Var n T) = True" |
  "well_typed (Abs n T t) = (
    let n_Ty = env_of t n in
    if n_Ty = None \<or> n_Ty = Some T then well_typed t else False)" |
  "well_typed (App t1 t2) = (case type_of t1 of
    Some (Fun T _) \<Rightarrow>
      let e1 = env_of t1 in
      let e2 = env_of t2 in
      Some T = type_of t2 \<and> (\<forall>n\<in>dom e1 \<inter> dom e2. e1 n = e2 n) \<and>
        well_typed t1 \<and> well_typed t2 |
    _ \<Rightarrow> False)"

(*test*)
(*
lemma "well_typed (0::''a'':* )" by simp
lemma "\<not> well_typed |[0::''a'':* 1::''b'':*]|" by simp
lemma "(0::''a'':* ) \<noteq> undefined" oops
*)

\<comment> \<open>safe term constructors\<close>
definition mk_var :: "name \<Rightarrow> type \<Rightarrow> term option" where
  "mk_var n T = Some (Var n T)"
fun mk_abs :: "name \<Rightarrow> type \<Rightarrow> term option \<Rightarrow> term option" where
  "mk_abs n T (Some t) = (
    let ret = (Abs n T t) in
    if well_typed ret then Some ret else None)" |
  "mk_abs _ _ _ = None"
fun mk_app :: "term option \<Rightarrow> term option \<Rightarrow> term option" where
  "mk_app (Some t1) (Some t2) = (
    let ret = (App t1 t2) in
    if well_typed ret then Some ret else None)" |
  "mk_app _ _ = None"

subsection \<open>5\<close>
\<comment> \<open>user accessible functions\<close>
definition "assume" :: "name \<Rightarrow> type \<Rightarrow> term option" where
  "assume = mk_var"
definition imp_i :: "name \<Rightarrow> type \<Rightarrow> term option \<Rightarrow> term option" where
  "imp_i = mk_abs"
definition imp_e :: "term option \<Rightarrow> term option \<Rightarrow> term option" where
  "imp_e = mk_app"

lemmas mk_def = mk_var_def
lemmas rule_def = assume_def imp_i_def imp_e_def

(*test*)
(*
lemma "imp_i 0 (''a'':* ) (assume 0 (''a'':* )) = Some (\<lambda>0::''a'':*. 0::''a'':*>)"
  by (simp add: mk_def rule_def)
lemma "type_of (the (imp_i 0 (''a'':* ) (imp_i 1 (''a'':* \<rightarrow>> ''b'':* ) (imp_e (assume 1 (''a'':* \<rightarrow>> ''b'':* )) (assume 0 (''a'':* ))))))
  = Some (''a'':* \<rightarrow>> (''a'':* \<rightarrow>> ''b'':* ) \<rightarrow>> ''b'':* )"
  by (simp add: mk_def rule_def)
*)

subsection \<open>6\<close>
definition print :: "term option \<Rightarrow> type \<times> term" where
  "print t = (the (type_of (the t)), the t)"

(*test*)
(*printable version*)
(*
value "print (imp_i X (''a'':* ) (assume X (''a'':* )))"
value "print (
imp_i X (''a'':* \<rightarrow>> ''b'':* \<rightarrow>> ''c'':* ) (
  imp_i Y (''a'':* \<rightarrow>> ''b'':* ) (
    imp_i Z (''a'':* ) (
      imp_e
        (imp_e
          (assume X (''a'':* \<rightarrow>> ''b'':* \<rightarrow>> ''c'':* ))
          (assume Z (''a'':* )))
        (imp_e
          (assume Y (''a'':* \<rightarrow>> ''b'':* ))
          (assume Z (''a'':* )))
))))"
*)

subsection \<open>7\<close>
lemma example: "print (
imp_i 0 (''a'':* \<rightarrow>> ''b'':* \<rightarrow>> ''c'':* ) (
  imp_i 1 (''a'':* \<rightarrow>> ''b'':* ) (
    imp_i 2 (''a'':* ) (
      imp_e
        (imp_e
          (assume 0 (''a'':* \<rightarrow>> ''b'':* \<rightarrow>> ''c'':* ))
          (assume 2 (''a'':* )))
        (imp_e
          (assume 1 (''a'':* \<rightarrow>> ''b'':* ))
          (assume 2 (''a'':* )))
))))
=
((''a'':* \<rightarrow>> ''b'':* \<rightarrow>> ''c'':* ) \<rightarrow>> (''a'':* \<rightarrow>> ''b'':* ) \<rightarrow>> ''a'':* \<rightarrow>> ''c'':*,
\<lambda>0::(''a'':* \<rightarrow>> ''b'':* \<rightarrow>> ''c'':* ). \<lambda>1::(''a'':* \<rightarrow>> ''b'':* ). \<lambda>2::''a'':*. |[ |[0::''a'':* \<rightarrow>> ''b'':* \<rightarrow>> ''c'':* 2::''a'':*]| |[1::''a'':* \<rightarrow>> ''b'':* 2::''a'':*]| ]|>>>)"
  by (simp add: print_def rule_def mk_def)

section \<open>Addition\<close>
\<comment> \<open>proof terms\<close>
inductive pr_term :: "term \<Rightarrow> bool" where
  "assume n T = Some t \<Longrightarrow> pr_term t" |
  "pr_term t \<Longrightarrow> imp_i n T (Some t) = Some t' \<Longrightarrow> pr_term t'" |
  "pr_term t1 \<Longrightarrow> pr_term t2 \<Longrightarrow> imp_e (Some t1) (Some t2) = Some t \<Longrightarrow> pr_term t"

theorem soundness: "pr_term t \<Longrightarrow> well_typed t"
proof (induct t rule: pr_term.induct)
  case (1 n T t)
  then show ?case by (auto simp add: rule_def mk_def)
next
  case (2 t n T t')
  then show ?case
    by (smt imp_i_def mk_abs.simps(1) option.distinct(1) option.sel)
next
  case (3 t1 t2 t)
  then show ?case
    by (metis (full_types) imp_e_def mk_app.simps(1) option.distinct(1) option.sel)
qed

theorem completeness: "well_typed t \<Longrightarrow> \<exists>t'. pr_term t' \<and> type_of t' = type_of t \<and> env_of t' = env_of t"
proof (induct t rule: well_typed.induct)
  case (1 n T)
  show ?case
    apply (rule exI[of _ "Var n T"])
    by (simp add: assume_def mk_var_def pr_term.intros(1))
next
  case (2 n T t)
  have "\<exists>t'. pr_term t' \<and> type_of t' = type_of t \<and> env_of t' = env_of t"
    (is "\<exists>t'. ?t' t'")
    apply (rule "2.hyps"[of "env_of t n"])
      apply simp
    using "2.prems"
     apply (meson well_typed.simps(2))
    by (meson "2.prems" well_typed.simps(2))
  then obtain t' where t': "?t' t'" by auto
  show ?case
    apply (rule exI[of _ "\<lambda>n::T. t'>"])
    using t'
    apply auto
    apply (rule pr_term.intros(2)[of t' n T])
    using soundness
     apply (auto simp add: rule_def Let_def)
    by (meson "2.prems" well_typed.simps(2))
next
  case (3 t1 t2)
  have "\<exists>T1 T2. type_of t1 = Some (T1 \<rightarrow>> T2) \<and> type_of t2 = Some T1"
    (is "\<exists>T1 T2. ?type T1 T2")
    using "3.prems"
    apply (rule well_typed.elims(2))
      apply auto
    apply (cases "type_of t1")
     apply simp_all
    apply (rename_tac T)
    apply (case_tac T)
     apply simp_all
    by metis
  then obtain T1 T2 where T1T2: "?type T1 T2" by auto
  have "\<exists>t1' t2'. pr_term t1' \<and> type_of t1' = type_of t1 \<and> env_of t1' = env_of t1 \<and>
    pr_term t2' \<and> type_of t2' = type_of t2 \<and> env_of t2' = env_of t2"
    (is "\<exists>t1' t2'. ?term t1' t2'")
    using "3.hyps"(1)[of "T1 \<rightarrow>> T2"] "3.hyps"(2)[of "T1 \<rightarrow>> T2"] "3.prems" T1T2 by fastforce
  then obtain t1' t2' where t1t2': "?term t1' t2'" by auto
  show ?case
    apply (rule exI[of _ "|[t1' t2']|"])
    using t1t2'
    apply auto
     apply (rule pr_term.intros(3)[of t1' t2'])
       apply (auto simp add: rule_def)
     apply (cases "type_of t1")
    using T1T2
      apply auto
    using soundness "3.prems"
    apply (auto simp add: Let_def)
    done
qed

hide_type (open) "term"
hide_const (open) mk_var
hide_const (open) mk_abs
hide_const (open) mk_app

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_61
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun last :: "Nat list => Nat" where
  "last (nil2) = Z"
| "last (cons2 z (nil2)) = z"
| "last (cons2 z (cons2 x2 x3)) = last (cons2 x2 x3)"

fun lastOfTwo :: "Nat list => Nat list => Nat" where
  "lastOfTwo y (nil2) = last y"
| "lastOfTwo y (cons2 z2 x2) = last (cons2 z2 x2)"

theorem property0 :(*Probably the best proof.*)
  "((last (x xs ys)) = (lastOfTwo xs ys))"
  apply(induct xs)
   apply clarsimp
   apply(cases ys)
    apply fastforce+
  apply(case_tac xs)(*"case_tac xs" also works but leads to a longer proof script.*)
   apply(cases ys)
    apply fastforce+
  apply clarsimp
  apply(cases ys)
   apply fastforce+
  done

theorem property0' :
  "((last (x xs ys)) = (lastOfTwo xs ys))"
  apply(induct xs)
   apply(cases ys)
    apply fastforce+
  apply(cases ys)
   apply clarsimp
   apply(case_tac xs)
    apply fastforce+
  apply clarsimp
  apply(cases ys)
   apply fastforce+
  apply clarsimp
  apply(case_tac xs)
   apply fastforce+
  done

theorem property0'' :(*with sledgehammer*)
  "((last (x xs ys)) = (lastOfTwo xs ys))"
  apply(induct xs)
   apply clarsimp
   apply (metis lastOfTwo.elims)
  apply clarsimp
  apply(cases ys)
   apply clarsimp
   apply (metis TIP_prop_61.last.simps(3) x.elims)
  apply clarsimp
  apply (metis TIP_prop_61.last.simps(3) x.elims)
  done
end


(*
  File:     Build.thy
  Author:   Martin Rau, TU München
*)

section \<open>Building a balanced \<open>k\<close>-d Tree from a List of Points\<close>

theory Build
imports
  KD_Tree
  Median_Of_Medians_Selection.Median_Of_Medians_Selection  "Eval_Base.Eval_Base"
begin

text \<open>
  Build a balanced \<open>k\<close>-d Tree by recursively partition the points into two lists.
  The partitioning criteria will be the median at a particular axis \<open>k\<close>.
  The left list will contain all points \<open>p\<close> with @{term "p$k \<le> median"}.
  The right list will contain all points with median at axis @{term "median < p$k"}.
  The left and right list differ in length by one or none.
  The axis \<open>k\<close> will the widest spread axis.
\<close>

subsection "Auxiliary Lemmas"

lemma length_filter_mset_sorted_nth:
  assumes "distinct xs" "n < length xs" "sorted xs"
  shows "{# x \<in># mset xs. x \<le> xs ! n #} = mset (take (n + 1) xs)"
  using assms
proof2 (induction xs arbitrary: n rule: list.induct)
  case (Cons x xs)
  thus ?case
  proof (cases n)
    case 0
    thus ?thesis
      using Cons.prems(1,3) filter_mset_is_empty_iff by fastforce
  next
    case (Suc n')
    thus ?thesis
      using Cons by simp
  qed
qed auto

lemma length_filter_sort_nth:
  assumes "distinct xs" "n < length xs"
  shows "length (filter (\<lambda>x. x \<le> sort xs ! n) xs) = n + 1"
proof -
  have "length (filter (\<lambda>x. x \<le> sort xs ! n) xs) = length (filter (\<lambda>x. x \<le> sort xs ! n) (sort xs))"
    by (simp add: filter_sort)
  also have "... = size (mset (filter (\<lambda>x. x \<le> sort xs ! n) (sort xs)))"
    using size_mset by metis
  also have "... = size ({# x \<in># mset (sort xs). x \<le> sort xs ! n #})"
    using mset_filter by simp
  also have "... = size (mset (take (n + 1) (sort xs)))"
    using length_filter_mset_sorted_nth assms sorted_sort distinct_sort length_sort by metis
  finally show ?thesis
    using assms(2) by auto
qed

subsection \<open>Widest Spread Axis\<close>

definition calc_spread :: "('k::finite) \<Rightarrow> 'k point list \<Rightarrow> real" where
  "calc_spread k ps = (case ps of [] \<Rightarrow> 0 | ps \<Rightarrow>
    let ks = map (\<lambda>p. p$k) (tl ps) in
    fold max ks ((hd ps)$k) - fold min ks ((hd ps)$k)
  )"

fun widest_spread :: "('k::finite) list \<Rightarrow> 'k point list \<Rightarrow> 'k \<times> real" where
  "widest_spread [] _ = undefined"
| "widest_spread [k] ps = (k, calc_spread k ps)"
| "widest_spread (k # ks) ps = (
    let (k', s') = widest_spread ks ps in
    let s = calc_spread k ps in
    if s \<le> s' then (k', s') else (k, s)
  )"

lemma calc_spread_spec:
  "calc_spread k ps = spread k (set ps)"
  using Max.set_eq_fold[of "(hd ps)$k"] Min.set_eq_fold[of "(hd ps)$k"]
  by (auto simp: Let_def spread_def calc_spread_def split: list.splits, metis set_map)

lemma widest_spread_calc_spread:
  "ks \<noteq> [] \<Longrightarrow> (k, s) = widest_spread ks ps \<Longrightarrow> s = calc_spread k ps"
  apply2 (induction ks ps rule: widest_spread.induct) by (auto simp: Let_def split: prod.splits if_splits)

lemma widest_spread_axis_Un:
  shows "widest_spread_axis k K P \<Longrightarrow> spread k' P \<le> spread k P \<Longrightarrow> widest_spread_axis k (K \<union> { k' }) P"
    and "widest_spread_axis k K P \<Longrightarrow> spread k P \<le> spread k' P \<Longrightarrow> widest_spread_axis k' (K \<union> { k' }) P"
  unfolding widest_spread_axis_def by auto

lemma widest_spread_spec:
  "(k, s) = widest_spread ks ps \<Longrightarrow> widest_spread_axis k (set ks) (set ps)"
proof2 (induction ks ps arbitrary: k s rule: widest_spread.induct)
  case (3 k\<^sub>0 k\<^sub>1 ks ps)
  obtain K' S' where K'_def: "(K', S') = widest_spread (k\<^sub>1 # ks) ps"
    by (metis surj_pair)
  hence IH: "widest_spread_axis K' (set (k\<^sub>1 # ks)) (set ps)"
    using "3.IH" by blast
  hence 0: "S' = spread K' (set ps)"
    using K'_def widest_spread_calc_spread calc_spread_spec by blast
  define S where "S = calc_spread k\<^sub>0 ps"
  hence 1: "S = spread k\<^sub>0 (set ps)"
    using calc_spread_spec by blast
  show ?case
  proof (cases "S \<le> S'")
    case True
    hence "widest_spread_axis K' (set (k\<^sub>0 # k\<^sub>1 # ks)) (set ps)"
      using 0 1 widest_spread_axis_Un(1)[OF IH, of k\<^sub>0]  by auto
    thus ?thesis
      using True K'_def S_def "3.prems" by (auto split: prod.splits)
  next
    case False
    hence "widest_spread_axis k\<^sub>0 (set (k\<^sub>0 # k\<^sub>1 # ks)) (set ps)"
      using 0 1 widest_spread_axis_Un(2)[OF IH, of k\<^sub>0] "3.prems"(1) by auto
    thus ?thesis
      using False K'_def S_def "3.prems" by (auto split: prod.splits)
  qed
qed (auto simp: widest_spread_axis_def)

subsection \<open>Fast Axis Median\<close>

definition axis_median :: "('k::finite) \<Rightarrow> 'k point list \<Rightarrow> real" where
  "axis_median k ps = (let n = (length ps - 1) div 2 in fast_select n (map (\<lambda>p. p$k) ps))"

lemma length_filter_le_axis_median:
  assumes "0 < length ps" "\<forall>k. distinct (map (\<lambda>p. p$k) ps)"
  shows "length (filter (\<lambda>p. p$k \<le> axis_median k ps) ps) = (length ps - 1) div 2 + 1"
proof -
  let ?n = "(length ps - 1) div 2"
  let ?ps = "map (\<lambda>p. p$k) ps"
  let ?m = "fast_select ?n ?ps"
  have 0: "?n < length ?ps"
    using assms(1) by (auto, linarith)
  have 1: "distinct ?ps"
    using assms(2) by blast
  have "?m = select ?n ?ps"
    using fast_select_correct[OF 0] by blast
  hence "length (filter (\<lambda>p. p$k \<le> axis_median k ps) ps) =
        length (filter (\<lambda>p. p$k \<le> sort ?ps ! ?n) ps)"
    unfolding axis_median_def by (auto simp add: Let_def select_def simp del: fast_select.simps)
  also have "... = length (filter (\<lambda>v. v \<le> sort ?ps ! ?n) ?ps)"
    apply2 (induction ps) by (auto, metis comp_apply)
  also have "... = ?n + 1"
    using length_filter_sort_nth[OF 1 0] by blast
  finally show ?thesis .
qed

definition partition_by_median :: "('k::finite) \<Rightarrow> 'k point list \<Rightarrow> 'k point list \<times> real \<times> 'k point list" where
  "partition_by_median k ps = (
     let m = axis_median k ps in
     let (l, r) = partition (\<lambda>p. p$k \<le> m) ps in
     (l, m, r)
  )"

lemma set_partition_by_median:
  "(l, m, r) = partition_by_median k ps \<Longrightarrow> set ps = set l \<union> set r"
  unfolding partition_by_median_def by (auto simp: Let_def)

lemma filter_partition_by_median:
  assumes "(l, m, r) = partition_by_median k ps"
  shows "\<forall>p \<in> set l. p$k \<le> m"
    and "\<forall>p \<in> set r. \<not>p$k \<le> m"
  using assms unfolding partition_by_median_def by (auto simp: Let_def)

lemma sum_length_partition_by_median:
  assumes "(l, m, r) = partition_by_median k ps"
  shows "length ps = length l + length r"
  using assms sum_length_filter_compl[of "(\<lambda>p. p $ k \<le> axis_median k ps)"]
  unfolding partition_by_median_def by (simp add: Let_def o_def)

lemma length_l_partition_by_median:
  assumes "0 < length ps" "\<forall>k. distinct (map (\<lambda>p. p$k) ps)" "(l, m, r) = partition_by_median k ps"
  shows "length l = (length ps - 1) div 2 + 1"
  using assms unfolding partition_by_median_def by (auto simp: Let_def length_filter_le_axis_median)

corollary lengths_partition_by_median_1:
  assumes "0 < length ps"  "\<forall>k. distinct (map (\<lambda>p. p$k) ps)" "(l, m, r) = partition_by_median k ps"
  shows "length l - length r \<le> 1"
    and "length r \<le> length l"
    and "0 < length l"
    and "length r < length ps"
  using length_l_partition_by_median[OF assms] sum_length_partition_by_median[OF assms(3)] by auto

corollary lengths_partition_by_median_2:
  assumes "1 < length ps" "\<forall>k. distinct (map (\<lambda>p. p$k) ps)" "(l, m, r) = partition_by_median k ps"
  shows "0 < length r"
    and "length l < length ps"
proof -
  have *: "0 < length ps"
    using assms(1) by auto
  show "0 < length r" "length l < length ps"
    using length_l_partition_by_median[OF * assms(2,3)] sum_length_partition_by_median[OF assms(3)]
    using assms(1) by linarith+
qed

lemmas length_partition_by_median =
  sum_length_partition_by_median length_l_partition_by_median
  lengths_partition_by_median_1 lengths_partition_by_median_2

subsection \<open>Building the Tree\<close>

function (domintros, sequential) build :: "('k::finite) list \<Rightarrow> 'k point list \<Rightarrow> 'k kdt" where
  "build _ [] = undefined"
| "build _ [p] = Leaf p"
| "build ks ps = (
    let (k, _) = widest_spread ks ps in
    let (l, m, r) = partition_by_median k ps in
    Node k m (build ks l) (build ks r)
  )"
  by pat_completeness auto

lemma build_domintros3:
  assumes "(k, s) = widest_spread ks (x # y # zs)" "(l, m, r) = partition_by_median k (x # y # zs)"
  assumes "build_dom (ks, l)" "build_dom (ks, r)"
  shows "build_dom (ks, x # y # zs)"
proof -
  {
    fix k s l m r
    assume "(k, s) = widest_spread ks (x # y # zs)" "(l, m, r) = partition_by_median k (x # y # zs)"
    hence "build_dom (ks, l)" "build_dom (ks, r)"
      using assms by (metis Pair_inject)+
  }
  thus ?thesis
    by (simp add: build.domintros(3))
qed

lemma build_termination:
  assumes "\<forall>k. distinct (map (\<lambda>p. p$k) ps)"
  shows "build_dom (ks, ps)"
  using assms
proof2 (induction ps rule: length_induct)
  case (1 xs)
  consider (A) "xs = []" | (B) "\<exists>x. xs = [x]" | (C) "\<exists>x y zs. xs = x # y # zs"
    apply2 (induction xs rule: induct_list012) by auto
  then show ?case
  proof cases
    case C
    then obtain x y zs where xyzs_def: "xs = x # y # zs"
      by blast
    obtain k s where ks_def: "(k, s) = widest_spread ks xs"
      by (metis surj_pair)
    obtain l m r where lmr_def: "(l, m, r) = partition_by_median k xs"
      by (metis prod_cases3)
    note defs = xyzs_def ks_def lmr_def
    have "\<forall>k. distinct (map (\<lambda>p. p $ k) l)" "\<forall>k. distinct (map (\<lambda>p. p $ k) r)"
      using lmr_def unfolding partition_by_median_def
      by (auto simp: Let_def "1.prems" distinct_map_filter)
    moreover have "length l < length xs" "length r < length xs"
      using length_partition_by_median(8)[OF _ "1.prems"] length_partition_by_median(6)[OF _ "1.prems"]
      using defs by auto
    ultimately have "build_dom (ks, l)" "build_dom (ks, r)"
      using "1.IH" by blast+
    thus ?thesis
      using build_domintros3 defs by blast
  qed (auto intro: build.domintros)
qed

lemma build_psimp_1:
  "ps = [p] \<Longrightarrow> build k ps = Leaf p"
  by (simp add: build.domintros(2) build.psimps(2))

lemma build_psimp_2:
  assumes "(k, s) = widest_spread ks (x # y # zs)" "(l, m, r) = partition_by_median k (x # y # zs)"
  assumes "build_dom (ks, l)" "build_dom (ks, r)"
  shows "build ks (x # y # zs) = Node k m (build ks l) (build ks r)"
proof -
  have 0: "build_dom (ks, x # y # zs)"
    using assms build_domintros3 by blast
  thus ?thesis
    using build.psimps(3)[OF 0] assms(1,2) by (auto split: prod.splits)
qed

lemma length_xs_gt_1:
  "1 < length xs \<Longrightarrow> \<exists>x y ys. xs = x # y # ys"
  by (cases xs, auto simp: neq_Nil_conv)

lemma build_psimp_3:
  assumes "1 < length ps" "(k, s) = widest_spread ks ps" "(l, m, r) = partition_by_median k ps"
  assumes "build_dom (ks, l)" "build_dom (ks, r)"
  shows "build ks ps = Node k m (build ks l) (build ks r)"
  using build_psimp_2 length_xs_gt_1 assms by blast

lemmas build_psimps[simp] = build_psimp_1 build_psimp_3

subsection \<open>Main Theorems\<close>

theorem set_build:
  "0 < length ps \<Longrightarrow> \<forall>k. distinct (map (\<lambda>p. p$k) ps) \<Longrightarrow> set ps = set_kdt (build ks ps)"
proof2 (induction ps rule: length_induct)
  case (1 ps)
  show ?case
  proof (cases "1 < length ps")
    case True
    obtain k s where ks_def: "(k, s) = widest_spread ks ps"
      by (metis surj_pair)
    obtain l m r where lmr_def: "(l, m, r) = partition_by_median k ps"
      by (metis prod_cases3)
    have D: "\<forall>k. distinct (map (\<lambda>p. p$k) l)" "\<forall>k. distinct (map (\<lambda>p. p$k) r)"
      using lmr_def unfolding partition_by_median_def
      by (auto simp: "1.prems"(2) Let_def distinct_map_filter)
    moreover have "length l < length ps" "0 < length l"
                  "length r < length ps" "0 < length r"
      using length_partition_by_median(8)[OF True "1.prems"(2)]
            length_partition_by_median(5)[OF "1.prems"(1) "1.prems"(2)]
            length_partition_by_median(6)[OF "1.prems"(1) "1.prems"(2)]
            length_partition_by_median(7)[OF True "1.prems"(2)]
            lmr_def by blast+
    ultimately have "set l = set_kdt (build ks l)" "set r = set_kdt (build ks r)"
      using "1.IH" by blast+
    moreover have "set ps = set l \<union> set r"
      using lmr_def unfolding partition_by_median_def by (auto simp: Let_def)
    moreover have "build ks ps = Node k m (build ks l) (build ks r)"
      using build_psimp_3[OF True ks_def lmr_def] build_termination D by blast
    ultimately show ?thesis
      by simp
  next
    case False
    thus ?thesis
      using "1.prems" by (cases ps) auto
  qed
qed

theorem invar_build:
  "0 < length ps \<Longrightarrow> \<forall>k. distinct (map (\<lambda>p. p$k) ps) \<Longrightarrow> set ks = UNIV \<Longrightarrow> invar (build ks ps)"
proof2 (induction ps rule: length_induct)
  case (1 ps)
  show ?case
  proof (cases "1 < length ps")
    case True
    obtain k s where ks_def: "(k, s) = widest_spread ks ps"
      by (metis surj_pair)
    obtain l m r where lmr_def: "(l, m, r) = partition_by_median k ps"
      by (metis prod_cases3)
    have D: "\<forall>k. distinct (map (\<lambda>p. p$k) l)" "\<forall>k. distinct (map (\<lambda>p. p$k) r)"
      using lmr_def unfolding partition_by_median_def
      by (auto simp: "1.prems"(2) Let_def distinct_map_filter)
    moreover have "length l < length ps" "0 < length l"
                  "length r < length ps" "0 < length r"
      using length_partition_by_median(8)[OF True "1.prems"(2)]
            length_partition_by_median(5)[OF "1.prems"(1) "1.prems"(2)]
            length_partition_by_median(6)[OF "1.prems"(1) "1.prems"(2)]
            length_partition_by_median(7)[OF True "1.prems"(2)]
            lmr_def by blast+
    ultimately have "invar (build ks l)" "invar (build ks r)"
      using "1.IH" "1.prems"(3) by blast+
    moreover have "\<forall>p \<in> set l. p$k \<le> m" "\<forall>p \<in> set r. m < p$k"
      using filter_partition_by_median(1)[OF lmr_def]
            filter_partition_by_median(2)[OF lmr_def] by auto
    moreover have "widest_spread_axis k UNIV (set l \<union> set r)"
      using widest_spread_spec[OF ks_def] "1.prems"(3) set_partition_by_median[OF lmr_def] by simp
    moreover have "build ks ps = Node k m (build ks l) (build ks r)"
      using build_psimp_3[OF True ks_def lmr_def] build_termination D by blast
    ultimately show ?thesis
      using set_build[OF \<open>0 < length l\<close> D(1)] set_build[OF \<open>0 < length r\<close> D(2)] by simp
  next
    case False
    thus ?thesis
      using "1.prems" by (cases ps) auto
  qed
qed

theorem size_build:
  "0 < length ps \<Longrightarrow> \<forall>k. distinct (map (\<lambda>p. p$k) ps) \<Longrightarrow> size_kdt (build ks ps) = length ps"
proof2 (induction ps rule: length_induct)
  case (1 ps)
  show ?case
  proof (cases "1 < length ps")
    case True
    obtain k s where ks_def: "(k, s) = widest_spread ks ps"
      by (metis surj_pair)
    obtain l m r where lmr_def: "(l, m, r) = partition_by_median k ps"
      by (metis prod_cases3)
    have D: "\<forall>k. distinct (map (\<lambda>p. p$k) l)" "\<forall>k. distinct (map (\<lambda>p. p$k) r)"
      using lmr_def unfolding partition_by_median_def
      by (auto simp: "1.prems"(2) Let_def distinct_map_filter)
    moreover have "length l < length ps" "0 < length l"
                  "length r < length ps" "0 < length r"
      using length_partition_by_median(8)[OF True "1.prems"(2)]
            length_partition_by_median(5)[OF "1.prems"(1) "1.prems"(2)]
            length_partition_by_median(6)[OF "1.prems"(1) "1.prems"(2)]
            length_partition_by_median(7)[OF True "1.prems"(2)]
            lmr_def by blast+
    ultimately have "size_kdt (build ks l) = length l" "size_kdt (build ks r) = length r"
      using "1.IH" by blast+
    moreover have "build ks ps = Node k m (build ks l) (build ks r)"
      using build_psimp_3[OF True ks_def lmr_def] build_termination D by blast
    ultimately show ?thesis
      using length_partition_by_median(1)[OF lmr_def] by simp
  next
    case False
    thus ?thesis
      using "1.prems" by (cases ps) auto
  qed
qed

theorem balanced_build:
  "0 < length ps \<Longrightarrow> \<forall>k. distinct (map (\<lambda>p. p$k) ps) \<Longrightarrow> balanced (build ks ps)"
proof2 (induction ps rule: length_induct)
  case (1 ps)
  show ?case
  proof (cases "1 < length ps")
    case True
    obtain k s where ks_def: "(k, s) = widest_spread ks ps"
      by (metis surj_pair)
    obtain l m r where lmr_def: "(l, m, r) = partition_by_median k ps"
      by (metis prod_cases3)
    have D: "\<forall>k. distinct (map (\<lambda>p. p$k) l)" "\<forall>k. distinct (map (\<lambda>p. p$k) r)"
      using lmr_def unfolding partition_by_median_def
      by (auto simp: "1.prems"(2) Let_def distinct_map_filter)
    moreover have "length l < length ps" "0 < length l"
                  "length r < length ps" "0 < length r"
      using length_partition_by_median(8)[OF True "1.prems"(2)]
            length_partition_by_median(5)[OF "1.prems"(1) "1.prems"(2)]
            length_partition_by_median(6)[OF "1.prems"(1) "1.prems"(2)]
            length_partition_by_median(7)[OF True "1.prems"(2)]
            lmr_def by blast+
    ultimately have IH: "balanced (build ks l)" "balanced (build ks r)"
      using "1.IH" by blast+
    have "build ks ps = Node k m (build ks l) (build ks r)"
      using build_psimp_3[OF True ks_def lmr_def] build_termination D by blast
    moreover have "length r + 1 = length l \<or> length r = length l"
      using length_partition_by_median(1)[OF lmr_def]
            length_partition_by_median(3)[OF "1.prems"(1) "1.prems"(2) lmr_def]
            length_partition_by_median(4)[OF "1.prems"(1) "1.prems"(2) lmr_def]
      by linarith
    ultimately show ?thesis
      using balanced_Node_if_wbal1[OF IH] balanced_Node_if_wbal2[OF IH]
            size_build[OF \<open>0 < length l\<close> D(1)] size_build[OF \<open>0 < length r\<close> D(2)]
      by auto
  next
    case False
    thus ?thesis
      using "1.prems" by (cases ps) (auto simp: balanced_def)
  qed
qed

lemma complete_if_balanced_size_2powh:
  assumes "balanced kdt" "size_kdt kdt = 2 ^ h"
  shows "complete kdt"
proof (rule ccontr)
  assume "\<not> complete kdt"
  hence "2 ^ (min_height kdt) < size_kdt kdt" "size_kdt kdt < 2 ^ height kdt"
    by (simp_all add: min_height_size_if_incomplete size_height_if_incomplete)
  hence "height kdt - min_height kdt > 1"
    using assms(2) by simp
  hence "\<not> balanced kdt"
    using balanced_def by force
  thus "False"
    using assms(1) by simp
qed

theorem complete_build:
  "length ps = 2 ^ h \<Longrightarrow> \<forall>k. distinct (map (\<lambda>p. p$k) ps) \<Longrightarrow> complete (build k ps)"
  by (simp add: balanced_build complete_if_balanced_size_2powh size_build)

corollary height_build:
  assumes "length ps = 2 ^ h" "\<forall>k. distinct (map (\<lambda>p. p$k) ps)"
  shows "h = height (build k ps)"
  using complete_build[OF assms] size_build[OF _ assms(2)] by (simp add: assms(1) complete_iff_size)

end


header {* Implementation *}
theory Affine_Code
imports
  Affine_Approximation
begin

text {* Implementing partial deviations as sorted lists of coefficients. *}

subsection {* Reverse Sorted, Distinct Association Lists *}

typedef ('a, 'b) slist =
  "{xs::('a::linorder \<times> 'b) list. distinct (map fst xs) \<and> sorted (rev (map fst xs))}"
  by (auto intro!: exI[where x="[]"])

setup_lifting type_definition_slist

lift_definition map_of_slist::"(nat, 'a::zero) slist \<Rightarrow> nat \<Rightarrow> 'a option" is map_of .

lemma finite_dom_map_of_slist[intro, simp]: "finite (dom (map_of_slist xs))"
  by transfer (auto simp: finite_dom_map_of)

abbreviation "the_default a x \<equiv> (case x of None \<Rightarrow> a | Some b \<Rightarrow> b)"

definition "Pdevs_raw xs i = the_default 0 (map_of xs i)"

lemma nonzeros_Pdevs_raw_subset: "{i. Pdevs_raw xs i \<noteq> 0} \<subseteq> dom (map_of xs)"
  unfolding Pdevs_raw_def[abs_def]
  by transfer (auto simp: Pdevs_raw_def split: option.split_asm)

lift_definition Pdevs::"(nat, 'a::zero) slist \<Rightarrow> 'a pdevs"
  is Pdevs_raw
  by (rule finite_subset[OF nonzeros_Pdevs_raw_subset]) (simp add: finite_dom_map_of)

code_datatype Pdevs

subsection {* Degree *}

primrec degree_list::"(nat \<times> 'a::zero) list \<Rightarrow> nat" where
  "degree_list [] = 0"
| "degree_list (x#xs) = (if snd x = 0 then degree_list xs else Suc (fst x))"

lift_definition degree_slist::"(nat, 'a::zero) slist \<Rightarrow> nat" is degree_list .

lemma degree_list_eq_zeroD:
  assumes "degree_list xs = 0"
  shows "the_default 0 (map_of xs i) = 0"
  using assms
  by (induct xs) (auto simp: Pdevs_raw_def sorted_append split: split_if_asm)

lemma degree_slist_eq_zeroD: "degree_slist xs = 0 \<Longrightarrow> degree (Pdevs xs) = 0"
  unfolding degree_eq_Suc_max
  by transfer (auto dest: degree_list_eq_zeroD simp: Pdevs_raw_def)

lemma degree_slist_eq_SucD: "degree_slist xs = Suc n \<Longrightarrow> pdevs_apply (Pdevs xs) n \<noteq> 0"
proof transfer
  case goal1
  thus ?case
    by (induct xs)
      (auto simp: Pdevs_raw_def sorted_append map_of_eq_None_iff[symmetric]
        split: split_if_asm option.split_asm)
qed

lemma degree_slist_zero:
  "degree_slist xs = n \<Longrightarrow> n \<le> j \<Longrightarrow> pdevs_apply (Pdevs xs) j = 0"
proof transfer
  case goal1
  thus ?case
    by (induct xs)
      (auto simp: Pdevs_raw_def sorted_append split: split_if_asm option.split)
qed

lemma compute_degree[code]: "degree (Pdevs xs) = degree_slist xs"
  by (cases "degree_slist xs")
    (auto dest: degree_slist_eq_zeroD degree_slist_eq_SucD intro!: degree_eqI degree_slist_zero)

subsection {* Auxiliary Definitions *}

fun binop where
  "binop f z [] [] = []"
| "binop f z ((i, x)#xs) [] = (i, f x z) # binop f z xs []"
| "binop f z [] ((i, y)#ys) = (i, f z y) # binop f z [] ys"
| "binop f z ((i, x)#xs) ((j, y)#ys) =
    (if (i = j)     then (i, f x y) # binop f z xs ys
    else if (i > j) then (i, f x z) # binop f z xs ((j, y)#ys)
    else                 (j, f z y) # binop f z ((i, x)#xs) ys)"

lemma set_binop_elemD1:
  "(a, b) \<in> set (binop f z xs ys) \<Longrightarrow> (a \<in> set (map fst xs) \<or> a \<in> set (map fst ys))"
  by (induct f z xs ys rule: binop.induct) (auto split: split_if_asm)

lemma set_binop_elemD2:
  "(a, b) \<in> set (binop f z xs ys) \<Longrightarrow>
    (\<exists>x\<in>set (map snd xs). b = f x z) \<or>
    (\<exists>y\<in>set (map snd ys). b = f z y) \<or>
    (\<exists>x\<in>set (map snd xs). \<exists>y\<in>set (map snd ys). b = f x y)"
  by (induct f z xs ys rule: binop.induct) (auto split: split_if_asm)

abbreviation "rsorted\<equiv>\<lambda>x. sorted (rev x)"

lemma rsorted_binop:
  fixes xs ys::"('a::linorder * 'b) list"
  assumes "rsorted ((map fst xs))"
  assumes "rsorted ((map fst ys))"
  shows "rsorted ((map fst (binop f z xs ys)))"
  using assms
  by (induct f z xs ys rule: binop.induct) (force simp: sorted_append dest!: set_binop_elemD1)+

lemma distinct_binop:
  fixes xs ys::"('a::linorder * 'b) list"
  assumes "distinct (map fst xs)"
  assumes "distinct (map fst ys)"
  assumes "rsorted ((map fst xs))"
  assumes "rsorted ((map fst ys))"
  shows "distinct (map fst (binop f z xs ys))"
  using assms
  by (induct f z xs ys rule: binop.induct)
    (force dest!: set_binop_elemD1 simp: sorted_append)+

lemma binop_plus:
  fixes b::"(nat * 'a::euclidean_space) list"
  shows "(\<Sum>(i, y)\<leftarrow>binop op + 0 b ba. e i *\<^sub>R y) = (\<Sum>(i, y)\<leftarrow>b. e i *\<^sub>R y) + (\<Sum>(i, y)\<leftarrow>ba. e i *\<^sub>R y)"
  by (induct "op +::'a\<Rightarrow>_" "0::'a" b ba rule: binop.induct)
    (auto simp: algebra_simps)

lemma binop_compose:
  "binop (\<lambda>x y. f (g x y)) z xs ys = map (apsnd f) (binop g z xs ys)"
  by (induct "\<lambda>x y. f (g x y)" z xs ys rule: binop.induct) auto

lemma linear_cmul_left[intro, simp]: "linear (op * x::real \<Rightarrow> _)"
  by (auto intro!: linearI simp: algebra_simps)

lemma length_merge_sorted_eq:
  "length (binop f z xs ys) = length (binop g y xs ys)"
  by (induction f z xs ys rule: binop.induct) auto

subsection {* Pointswise Addition *}

lift_definition add_slist::"(nat, 'a::{plus, zero}) slist \<Rightarrow> (nat, 'a) slist \<Rightarrow> (nat, 'a) slist" is
  "\<lambda>xs ys. binop op + 0 xs ys"
  by (auto simp: intro!: distinct_binop rsorted_binop)

lemma map_of_binop[simp]: "rsorted (map fst xs) \<Longrightarrow> rsorted (map fst ys) \<Longrightarrow>
  distinct (map fst xs) \<Longrightarrow> distinct (map fst ys) \<Longrightarrow>
  map_of (binop f z xs ys) i =
  (case map_of xs i of
    Some x \<Rightarrow> Some (f x (case map_of ys i of Some x \<Rightarrow> x | None \<Rightarrow> z))
  | None \<Rightarrow> (case map_of ys i of Some y \<Rightarrow> Some (f z y) | None \<Rightarrow> None))"
  by (induct f z xs ys rule: binop.induct)
    (auto split: option.split option.split_asm simp: sorted_append)

lemma pdevs_apply_Pdevs_add_slist[simp]:
  fixes xs ys::"(nat, 'a::monoid_add) slist"
  shows "pdevs_apply (Pdevs (add_slist xs ys)) i =
    pdevs_apply (Pdevs xs) i + pdevs_apply (Pdevs ys) i"
  by (transfer) (auto simp: Pdevs_raw_def split: option.split)

lemma compute_add_pdevs[code]: "add_pdevs (Pdevs xs) (Pdevs ys) = Pdevs (add_slist xs ys)"
  by (rule pdevs_eqI) simp

subsection {* Set of Coefficients *}

lift_definition set_slist::"(nat, 'a::real_vector) slist \<Rightarrow> (nat * 'a) set" is set .

lemma finite_set_slist[intro, simp]: "finite (set_slist xs)"
  by transfer simp

subsection {* Domain *}

lift_definition list_of_slist::"('a::linorder, 'b::zero) slist \<Rightarrow> ('a * 'b) list"
  is "\<lambda>xs. filter (\<lambda>x. snd x \<noteq> 0) xs" .

lemma compute_pdevs_domain[code]: "pdevs_domain (Pdevs xs) = set (map fst (list_of_slist xs))"
  unfolding pdevs_domain_def
  by transfer (force simp: Pdevs_raw_def split: option.split_asm)

lemma sort_rev_eq_sort: "distinct xs \<Longrightarrow> sort (rev xs) = sort xs"
  by (rule sorted_distinct_set_unique) auto

lemma compute_list_of_pdevs[code]: "list_of_pdevs (Pdevs xs) = list_of_slist xs"
proof -
  have "list_of_pdevs (Pdevs xs) =
    map (\<lambda>i. (i, pdevs_apply (Pdevs xs) i)) (rev (sorted_list_of_set (pdevs_domain (Pdevs xs))))"
    by (simp add: list_of_pdevs_def)
  also have "(sorted_list_of_set (pdevs_domain (Pdevs xs))) = rev (map fst (list_of_slist xs))"
    unfolding compute_pdevs_domain sorted_list_of_set_sort_remdups
  proof transfer
    case goal1
    hence distinct: "distinct (map fst [x\<leftarrow>xs . snd x \<noteq> 0])"
      by (auto simp: filter_map distinct_map intro: subset_inj_on)
    with goal1 show ?case
      using sort_rev_eq_sort[symmetric, OF distinct]
      by (auto simp: rev_map rev_filter distinct_map distinct_remdups_id
        intro!: sorted_sort_id sorted_filter)
  qed
  also
  have "map (\<lambda>i. (i, pdevs_apply (Pdevs xs) i)) (rev \<dots>) = list_of_slist xs"
  proof transfer
    case goal1
    thus ?case
      unfolding Pdevs_raw_def o_def rev_rev_ident map_map
      by (subst map_cong[where g="\<lambda>x. x"]) (auto simp: map_filter_map_filter)
  qed
  finally show ?thesis .
qed

lift_definition slist_of_pdevs::"'a pdevs \<Rightarrow> (nat, 'a::real_vector) slist" is list_of_pdevs
  by (auto simp: list_of_pdevs_def rev_map rev_filter
    filter_map o_def distinct_map image_def
    intro!: distinct_filter sorted_filter[of "\<lambda>x. x", simplified])

subsection {* Application *}

text {* TODO: slightly more efficient---sorted---implementation... *}
lift_definition slist_apply::"('a::linorder, 'b::zero) slist \<Rightarrow> 'a \<Rightarrow> 'b" is
  "\<lambda>xs i. the_default 0 (map_of xs i)" .

lemma compute_pdevs_apply[code]: "pdevs_apply (Pdevs x) i = slist_apply x i"
  by transfer (auto simp: Pdevs_raw_def)

subsection {* Total Deviation *}

lift_definition tdev_slist::"(nat, 'a::ordered_euclidean_space) slist \<Rightarrow> 'a" is
  "listsum o map (abs o snd)" .

lemma tdev_slist_setsum: "tdev_slist xs = setsum (abs \<circ> snd) (set_slist xs)"
  by transfer (auto simp: distinct_map listsum_distinct_conv_setsum_set[symmetric] o_def)

lemma pdevs_apply_set_slist: "x \<in> set_slist xs \<Longrightarrow> snd x = pdevs_apply (Pdevs xs) (fst x)"
  by transfer (auto simp: Pdevs_raw_def)

lemma
  tdev_list_eq_zeroI:
  shows "(\<And>i. pdevs_apply (Pdevs xs) i = 0) \<Longrightarrow> tdev_slist xs = 0"
  unfolding tdev_slist_setsum
  by (auto simp: pdevs_apply_set_slist)

lemma inj_on_fst_set_slist: "inj_on fst (set_slist xs)"
  by transfer (simp add: distinct_map)

lemma pdevs_apply_Pdevs_eq_0: "pdevs_apply (Pdevs xs) i = 0 \<longleftrightarrow> ((\<forall>x. (i, x) \<in> set_slist xs \<longrightarrow> x = 0))"
  by transfer (safe, auto simp: Pdevs_raw_def split: option.split)

lemma compute_tdev[code]: "tdev (Pdevs xs) = tdev_slist xs"
proof -
  have "tdev (Pdevs xs) = (\<Sum>i<degree (Pdevs xs). \<bar>pdevs_apply (Pdevs xs) i\<bar>)"
    by (simp add: tdev_def)
  also have "\<dots> = (\<Sum>i <degree (Pdevs xs). if pdevs_apply (Pdevs xs) i = 0 then 0 else \<bar>pdevs_apply (Pdevs xs) i\<bar>)"
    by (auto intro!: setsum.cong)
  also have "\<dots> = (\<Sum>i\<in>{0..<degree (Pdevs xs)} \<inter> {x. pdevs_apply (Pdevs xs) x \<noteq> 0}. \<bar>pdevs_apply (Pdevs xs) i\<bar>)"
    by (auto simp: setsum.If_cases Collect_neg_eq atLeast0LessThan)
  also have "\<dots> = (\<Sum>x\<in>fst ` set_slist xs. \<bar>pdevs_apply (Pdevs xs) x\<bar>)"
    by (rule setsum.mono_neutral_cong_left)
      (force simp: pdevs_apply_Pdevs_eq_0 intro!: imageI degree_gt)+
  also have "\<dots> = (\<Sum>x\<in>set_slist xs. \<bar>pdevs_apply (Pdevs xs) (fst x)\<bar>)"
    by (rule setsum.reindex_cong[of fst]) (auto simp: inj_on_fst_set_slist)
  also have "\<dots> = tdev_slist xs"
    by (simp add: tdev_slist_setsum pdevs_apply_set_slist)
  finally show ?thesis .
qed

subsection {* Minkowski Sum *}

lemma dropWhile_rsorted_eq_filter:
  "rsorted (map fst xs) \<Longrightarrow> dropWhile (\<lambda>(i, x). i \<ge> (m::nat)) xs = filter (\<lambda>(i, x). i < m) xs"
  (is "_ \<Longrightarrow> ?lhs xs = ?rhs xs")
proof (induct xs)
  case (Cons x xs)
  hence "?rhs (x#xs) = ?lhs (x#xs)"
    by (auto simp: sorted_append filter_id_conv intro: sym)
  thus ?case ..
qed simp

lift_definition msum_slist::"nat \<Rightarrow> (nat, 'a) slist \<Rightarrow> (nat, 'a) slist \<Rightarrow> (nat, 'a) slist"
  is "\<lambda>m xs ys. map (apfst (\<lambda>n. n +  m)) ys @ dropWhile (\<lambda>(i, x). i \<ge> m) xs"
proof safe
  case (goal1 n l1 l2)
  thus ?case
    by (auto dest: set_dropWhileD
      simp: dropWhile_rsorted_eq_filter sorted_append rev_map rev_filter sorted_filter distinct_map
      intro!: comp_inj_on subset_inj_on[where A="{x \<in> set l1. case x of (i, x) \<Rightarrow> i < n}" and B="set l1"])
next
  case (goal2 n l1 l2)
  hence "sorted (map ((\<lambda>na. na + n) \<circ> fst) (rev l2))"
    unfolding rev_map
    by (intro sorted_nth_monoI) (auto dest!: sorted_nth_mono)
  with goal2 show ?case
    by (auto simp: sorted_append dropWhile_rsorted_eq_filter rev_map rev_filter sorted_filter)
qed

lemma distinct_map_fst_snd_eqD: "distinct (map fst xs) \<Longrightarrow> (i, a) \<in> set xs \<Longrightarrow> (i, b) \<in> set xs \<Longrightarrow> a = b"
  by (metis (lifting) map_of_is_SomeI option.inject)

lemma slist_apply_msum_slist:
  "slist_apply (msum_slist m xs ys) i = (if i < m then slist_apply xs i else slist_apply ys (i - m))"
proof transfer
  case goal1
  thus ?case
  proof (cases "i \<in> dom (map_of (map (\<lambda>(x, y). (x + m, y)) ys))")
    case False
    have "\<And>a. i < m \<Longrightarrow> i \<notin> fst ` {x \<in> set xs. case x of (i, x) \<Rightarrow> i < m} \<Longrightarrow> (i, a) \<notin> set xs"
      "\<And>a. i \<notin> fst ` set xs \<Longrightarrow> (i, a) \<notin> set xs"
      "\<And>a. m \<le> i \<Longrightarrow> i \<notin> fst ` (\<lambda>(x, y). (x + m, y)) ` set ys \<Longrightarrow> (i - m, a) \<notin> set ys"
       by force+
    thus ?thesis
      using goal1 False
      by (auto simp add: dropWhile_rsorted_eq_filter map_of_eq_None_iff distinct_map_fst_snd_eqD
        split: option.split dest!: map_of_SomeD)
  qed (force simp: map_of_eq_None_iff distinct_map_fst_snd_eqD split: option.split dest!: map_of_SomeD)
qed

lemma pdevs_apply_msum_slist:
  "pdevs_apply (Pdevs (msum_slist m xs ys)) i =
    (if i < m then pdevs_apply (Pdevs xs) i else pdevs_apply (Pdevs ys) (i - m))"
  by (auto simp: compute_pdevs_apply slist_apply_msum_slist)

lemma compute_msum_pdevs[code]: "msum_pdevs m (Pdevs xs) (Pdevs ys) = Pdevs (msum_slist m xs ys)"
  by (rule pdevs_eqI) (auto simp: pdevs_apply_msum_slist pdevs_apply_msum_pdevs)

subsection {* Unary Operations *}

lift_definition map_slist::"('a \<Rightarrow> 'b) \<Rightarrow> (nat, 'a) slist \<Rightarrow> (nat, 'b) slist" is "\<lambda>f. map (apsnd f)"
  by simp

lemma pdevs_apply_map_slist:
  "f 0 = 0 \<Longrightarrow> pdevs_apply (Pdevs (map_slist f xs)) i = f (pdevs_apply (Pdevs xs) i)"
  by transfer
    (force simp: Pdevs_raw_def map_of_eq_None_iff distinct_map_fst_snd_eqD image_def
      split: option.split dest: distinct_map_fst_snd_eqD)

lemma compute_scaleR_pdves[code]: "scaleR_pdevs r (Pdevs xs) = Pdevs (map_slist (\<lambda>x. r *\<^sub>R x) xs)"
  and compute_pdevs_scaleR[code]: "pdevs_scaleR (Pdevs rs) x = Pdevs (map_slist (\<lambda>r. r *\<^sub>R x) rs)"
  and compute_uminus_pdevs[code]: "uminus_pdevs (Pdevs xs) = Pdevs (map_slist (\<lambda>x. - x) xs)"
  and compute_pdevs_inner[code]: "pdevs_inner (Pdevs xs) b = Pdevs (map_slist (\<lambda>x. x \<bullet> b) xs)"
  and compute_inner_scaleR_pdevs[code]: "inner_scaleR_pdevs x (Pdevs ys) = Pdevs (map_slist (\<lambda>y. (x \<bullet> y) *\<^sub>R y) ys)"
  and compute_trunc_pdevs[code]: "trunc_pdevs p (Pdevs xs) = Pdevs (map_slist (\<lambda>x. eucl_truncate_down p x) xs)"
  and compute_trunc_err_pdevs[code]: "trunc_err_pdevs p (Pdevs xs) = Pdevs (map_slist (\<lambda>x. eucl_truncate_down p x - x) xs)"
  by (auto intro!: pdevs_eqI simp: pdevs_apply_map_slist)

subsection {* Filter *}

lift_definition filter_slist::"(nat \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> (nat, 'a) slist \<Rightarrow> (nat, 'a) slist"
  is "\<lambda>P xs. filter (\<lambda>(i, x). (P i x)) xs"
  by (auto simp: o_def filter_map distinct_map rev_map rev_filter sorted_filter
    intro: subset_inj_on)

lemma slist_apply_filter_slist: "slist_apply (filter_slist P xs) i =
  (if P i (slist_apply xs i) then slist_apply xs i else 0)"
  by transfer (force simp: Pdevs_raw_def o_def map_of_eq_None_iff distinct_map_fst_snd_eqD
    dest: map_of_is_SomeD distinct_map_fst_snd_eqD split: option.split)

lemma pdevs_apply_filter_slist: "pdevs_apply (Pdevs (filter_slist P xs)) i =
  (if P i (pdevs_apply (Pdevs xs) i) then pdevs_apply (Pdevs xs) i else 0)"
  by (simp add: compute_pdevs_apply slist_apply_filter_slist)

lemma compute_filter_pdevs[code]: "filter_pdevs P (Pdevs xs) = Pdevs (filter_slist P xs)"
  by (auto simp: pdevs_apply_filter_slist intro!: pdevs_eqI)

subsection {* Constant *}

lift_definition zero_slist::"(nat, 'a) slist" is "[]" by simp

lemma compute_zero_pdevs[code]: "zero_pdevs = Pdevs (zero_slist)"
  by transfer (auto simp: Pdevs_raw_def)

lift_definition One_slist::"(nat, 'a::executable_euclidean_space) slist"
  is "rev (zip [0..<length (Basis_list::'a list)] (Basis_list::'a list))"
  by (simp add: zip_rev[symmetric])

lemma
  map_of_rev_zip_upto_length_eq_nth:
  assumes "i < length B"
  shows "(map_of (rev (zip [0..<length B] B)) i) = Some (B ! i)"
proof -
  have "length (rev [0..<length B]) = length (rev B)"
    by simp
  from map_of_zip_is_Some[OF this, of i] assms
  obtain y where y: "map_of (zip (rev [0..<length B]) (rev B)) i = Some y"
    by (auto simp: zip_rev)
  hence "y = B ! i"
    by (auto simp: in_set_zip rev_nth)
  with y show ?thesis
    by (simp add: zip_rev)
qed

lemma
  map_of_rev_zip_upto_length_eq_None:
  assumes "\<not>i < length B"
  shows "(map_of (rev (zip [0..<length B] B)) i) = None"
  using assms
  by (auto simp: map_of_eq_None_iff in_set_zip)

lemma pdevs_apply_One_slist:
  "pdevs_apply (Pdevs One_slist) i =
    (if i < length (Basis_list::'a::executable_euclidean_space list) then (Basis_list::'a list) ! i else 0)"
  by transfer
    (auto simp: Pdevs_raw_def map_of_rev_zip_upto_length_eq_nth map_of_rev_zip_upto_length_eq_None
      split: option.split)

lemma compute_One_pdevs[code]: "One_pdevs = Pdevs One_slist"
  by (rule pdevs_eqI) (simp add: pdevs_apply_One_slist)

subsection {* Update *}

primrec update_list::"nat \<Rightarrow> 'a \<Rightarrow> (nat * 'a) list \<Rightarrow> (nat * 'a) list"
  where
  "update_list n x [] = [(n, x)]"
| "update_list n x (y#ys) =
    (if n > fst y then (n, x)#y#ys
    else if n = fst y then (n, x)#ys
    else y#(update_list n x ys))"

lemma map_of_update_list[simp]: "map_of (update_list n x ys) = (map_of ys)(n:=Some x)"
  by (induct ys) auto

lemma in_set_update_listD:
  assumes "y \<in> set (update_list n x ys)"
  shows "y = (n, x) \<or> (y \<in> set ys)"
  using assms
  by (induct ys) (auto split: split_if_asm)

lemma in_set_update_listI:
  "y = (n, x) \<or> (fst y \<noteq> n \<and> y \<in> set ys) \<Longrightarrow> y \<in> set (update_list n x ys)"
  by (induct ys) (auto split: split_if_asm)

lemma in_set_update_list: "(n, x) \<in> set (update_list n x xs)"
  by (induct xs) simp_all

lemma overwrite_update_list: "(a, b) \<in> set xs \<Longrightarrow> (a, b) \<notin> set (update_list n x xs) \<Longrightarrow> a = n"
  by (induct xs) (auto split: split_if_asm)

lemma insert_update_list: "distinct (map fst xs) \<Longrightarrow> rsorted (map fst xs) \<Longrightarrow> (a, b) \<in> set (update_list a x xs) \<Longrightarrow> b = x"
  by (induct xs) (force split: split_if_asm simp: sorted_append)+

lemma set_update_list_eq: "distinct (map fst xs) \<Longrightarrow> rsorted (map fst xs) \<Longrightarrow>
    set (update_list n x xs) = insert (n, x) (set xs - {x. fst x = n})"
  by (auto intro!: in_set_update_listI dest: in_set_update_listD simp: insert_update_list)

lift_definition update_slist::"nat \<Rightarrow> 'a \<Rightarrow> (nat, 'a) slist \<Rightarrow> (nat, 'a) slist" is update_list
proof -
  case (goal1 n a l)
  thus ?case
    by (induct l) (force simp: sorted_append distinct_map not_less dest!: in_set_update_listD)+
qed

lemma pdevs_apply_update_slist: "pdevs_apply (Pdevs (update_slist n x xs)) i =
  (if i = n then x else pdevs_apply (Pdevs xs) i)"
  by transfer (auto simp: Pdevs_raw_def)

lemma compute_pdev_upd[code]: "pdev_upd (Pdevs xs) n x = Pdevs (update_slist n x xs)"
  by (rule pdevs_eqI) (auto simp: pdevs_apply_update_slist)

subsection {* Approximate Total Deviation *}

lift_definition fold_slist::"('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> (nat, 'a::zero) slist \<Rightarrow> 'b \<Rightarrow> 'b"
  is "\<lambda>f xs z. fold (f o snd) (filter (\<lambda>x. snd x \<noteq> 0) xs) z" .

lemma Pdevs_raw_Cons:
  "Pdevs_raw ((a, b) # xs) = (\<lambda>i. if i = a then b else Pdevs_raw xs i)"
  by (auto simp: Pdevs_raw_def map_of_eq_None_iff
    dest!: map_of_is_SomeD
    split: option.split)

lemma zeros_aux: "- (\<lambda>i. if i = a then b else Pdevs_raw xs i) -` {0} \<subseteq>
  - Pdevs_raw xs -` {0} \<union> {a}"
  by auto

lemma compute_tdev'[code]:
  "tdev' p (Pdevs xs) = fold_slist (\<lambda>a b. eucl_truncate_up p (\<bar>a\<bar> + b)) xs 0"
  unfolding tdev'_def listsum'_def compute_list_of_pdevs
  by transfer (auto simp: o_def fold_map)

subsection {* Equality *}

lemma slist_apply_list_of_slist_eq: "slist_apply a i = the_default 0 (map_of (list_of_slist a) i)"
  by (transfer)
    (force split: option.split simp: map_of_eq_None_iff distinct_map_fst_snd_eqD
      dest!: map_of_is_SomeD)

lemma compute_equal_pdevs[code]:
  "equal_class.equal (Pdevs a) (Pdevs b) \<longleftrightarrow> (list_of_slist a) = (list_of_slist b)"
  by (auto intro!: pdevs_eqI simp: equal_pdevs_def compute_pdevs_apply slist_apply_list_of_slist_eq
    compute_list_of_pdevs[symmetric])

end


(*
  File: AbGroup.thy
  Author: Bohua Zhan

  Abelian groups.
*)

theory AbGroup
  imports AlgStructure
begin

section \<open>Monoids\<close>

definition is_ab_monoid :: "i \<Rightarrow> o" where [rewrite]:
  "is_ab_monoid(G) \<longleftrightarrow> (is_abgroup_raw(G) \<and> is_add_id(G) \<and> is_plus_comm(G) \<and> is_plus_assoc(G))"

lemma is_ab_monoidD [forward]:
  "is_ab_monoid(G) \<Longrightarrow> is_abgroup_raw(G)"
  "is_ab_monoid(G) \<Longrightarrow> is_add_id(G)"
  "is_ab_monoid(G) \<Longrightarrow> is_plus_comm(G)"
  "is_ab_monoid(G) \<Longrightarrow> is_plus_assoc(G)" by auto2+
setup {* del_prfstep_thm_eqforward @{thm is_ab_monoid_def} *}

lemma is_ab_monoid_abgroup_prop [forward]:
  "is_abgroup_raw(H) \<Longrightarrow> is_ab_monoid(G) \<Longrightarrow> eq_str_abgroup(G,H) \<Longrightarrow> is_ab_monoid(H)" by auto2

section \<open>Abelian groups\<close>

definition has_add_inverse :: "i \<Rightarrow> o" where [rewrite]:
  "has_add_inverse(G) \<longleftrightarrow> (\<forall>x\<in>.G. \<exists>y\<in>.G. x +\<^sub>G y = \<zero>\<^sub>G)"

lemma has_add_inverseD [backward]:
  "has_add_inverse(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> \<exists>y\<in>.G. x +\<^sub>G y = \<zero>\<^sub>G" by auto2

lemma has_add_inverseI [backward1]:
  "unary_fun(carrier(G),f) \<Longrightarrow> \<forall>x\<in>.G. x +\<^sub>G f(x) = \<zero>\<^sub>G \<Longrightarrow> has_add_inverse(G)" by auto2
setup {* del_prfstep_thm @{thm has_add_inverse_def} *}

lemma has_add_inverse_abgroup_prop [forward]:
  "is_abgroup_raw(H) \<Longrightarrow> has_add_inverse(G) \<Longrightarrow> eq_str_abgroup(G,H) \<Longrightarrow> has_add_inverse(H)"
@proof @have "\<forall>x\<in>.H. x +\<^sub>H (SOME y\<in>.G. x +\<^sub>G y = \<zero>\<^sub>G) = \<zero>\<^sub>H" @qed

definition is_abgroup :: "i \<Rightarrow> o" where [rewrite]:
  "is_abgroup(G) \<longleftrightarrow> (is_ab_monoid(G) \<and> has_add_inverse(G))"

lemma is_abgroupD [forward]:
  "is_abgroup(G) \<Longrightarrow> is_ab_monoid(G)"
  "is_abgroup(G) \<Longrightarrow> has_add_inverse(G)" by auto2+
setup {* del_prfstep_thm_eqforward @{thm is_abgroup_def} *}

lemma is_abgroup_abgroup_prop [forward]:
  "is_abgroup_raw(H) \<Longrightarrow> is_abgroup(G) \<Longrightarrow> eq_str_abgroup(G,H) \<Longrightarrow> is_abgroup(H)" by auto2

section \<open>Negation and subtraction\<close>

setup {* fold add_rewrite_rule [@{thm plus_commD}, @{thm plus_assoc_left}] *}

lemma has_left_inverse [backward]:
  "is_abgroup(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> \<exists>y\<in>.G. y +\<^sub>G x = \<zero>\<^sub>G"
@proof @obtain "y\<in>.G" where "x +\<^sub>G y = \<zero>\<^sub>G" @qed

lemma add_cancel_left [forward]:
  "is_abgroup(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> z \<in>. G \<Longrightarrow> x +\<^sub>G y = x +\<^sub>G z \<Longrightarrow> y = z"
@proof @obtain "x'\<in>.G" where "x' +\<^sub>G x = \<zero>\<^sub>G" @have "x' +\<^sub>G (x +\<^sub>G y) = y" @qed

lemma add_cancel_right [forward]:
  "is_abgroup(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> z \<in>. G \<Longrightarrow> y +\<^sub>G x = z +\<^sub>G x \<Longrightarrow> y = z" by auto2

definition neg :: "i \<Rightarrow> i \<Rightarrow> i"  ("-\<^sub>_ _" [81,81] 80) where [rewrite]:
  "-\<^sub>G x = (THE y. y \<in>. G \<and> x +\<^sub>G y = \<zero>\<^sub>G)"
setup {* register_wellform_data ("-\<^sub>G x", ["x \<in>. G"]) *}

lemma abgroup_neg_type [typing]:
  "is_abgroup(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> -\<^sub>G x \<in>. G" by auto2

lemma abgroup_neg_left [rewrite]:
  "is_abgroup(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> -\<^sub>G x +\<^sub>G x = \<zero>\<^sub>G" by auto2

lemma abgroup_neg_right [rewrite]:
  "is_abgroup(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> x +\<^sub>G -\<^sub>G x = \<zero>\<^sub>G" by auto2

lemma abgroup_neg_unique [forward]:
  "is_abgroup(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> x +\<^sub>G -\<^sub>G y = \<zero>\<^sub>G \<Longrightarrow> x = y" by auto2

lemma abgroup_neg_eq [resolve]:
  "is_abgroup(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> x +\<^sub>G y = \<zero>\<^sub>G \<Longrightarrow> -\<^sub>G x = y"
  "is_abgroup(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> y +\<^sub>G x = \<zero>\<^sub>G \<Longrightarrow> -\<^sub>G x = y"
  "is_abgroup(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> x +\<^sub>G y = \<zero>\<^sub>G \<Longrightarrow> y = -\<^sub>G x"
  "is_abgroup(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> y +\<^sub>G x = \<zero>\<^sub>G \<Longrightarrow> y = -\<^sub>G x" by auto2+

lemma neg_abgroup_fun [rewrite]:
  "is_abgroup_raw(H) \<Longrightarrow> is_abgroup(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> eq_str_abgroup(G,H) \<Longrightarrow> -\<^sub>G x = -\<^sub>H x" by auto2

lemma abgroup_neg_zero [rewrite]:
  "is_abgroup(G) \<Longrightarrow> -\<^sub>G(\<zero>\<^sub>G) = \<zero>\<^sub>G" by auto2

lemma abgroup_neg_zero_back [forward]:
  "is_abgroup(G) \<Longrightarrow> a \<in>. G \<Longrightarrow> -\<^sub>G a = \<zero>\<^sub>G \<Longrightarrow> a = \<zero>\<^sub>G" by auto2

lemma abgroup_neg_neg [rewrite]:
  "is_abgroup(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> -\<^sub>G (-\<^sub>G x) = x" by auto2
setup {* del_prfstep_thm @{thm neg_def} *}

lemma abgroup_neg_distrib:
  "is_abgroup(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> -\<^sub>G (x +\<^sub>G y) = -\<^sub>G x +\<^sub>G -\<^sub>G y \<and> -\<^sub>G x \<in>. G \<and> -\<^sub>G y \<in>. G"
@proof @have "(x +\<^sub>G y) +\<^sub>G (-\<^sub>G x +\<^sub>G -\<^sub>G y) = \<zero>\<^sub>G" @qed

lemma abgroup_neg_distrib':
  "is_abgroup(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> -\<^sub>G x +\<^sub>G -\<^sub>G y = -\<^sub>G (x +\<^sub>G y) \<and> x +\<^sub>G y \<in>. G"
@proof @have "(x +\<^sub>G y) +\<^sub>G (-\<^sub>G x +\<^sub>G -\<^sub>G y) = \<zero>\<^sub>G" @qed

lemma abgroup_neg_inj [forward]: "is_abgroup(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> -\<^sub>G x = -\<^sub>G y \<Longrightarrow> x = y"
@proof @have "x = -\<^sub>G (-\<^sub>G x)" @qed

definition minus :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "minus(G,x,y) = (THE z. z \<in>. G \<and> z +\<^sub>G y = x)"
abbreviation minus_notation ("(_/ -\<^sub>_ _)" [65,65,66] 65) where "x -\<^sub>G y \<equiv> minus(G,x,y)"
setup {* register_wellform_data ("x -\<^sub>G y", ["x \<in>. G", "y \<in>. G"]) *}

lemma minusI:
  "z \<in>. G \<Longrightarrow> z +\<^sub>G y = x \<Longrightarrow> \<forall>z'\<in>.G. z' +\<^sub>G y = x \<longrightarrow> z' = z \<Longrightarrow> minus(G,x,y) = z" by auto2

lemma minus_exist [backward2]:
  "is_abgroup(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> \<exists>z\<in>.G. z +\<^sub>G y = x"
@proof @have "(x +\<^sub>G (-\<^sub>G y)) +\<^sub>G y = x" @qed

lemma minus_type [typing]:
  "is_abgroup(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> x -\<^sub>G y \<in>. G" by auto2

lemma minusD [rewrite]:
  "is_abgroup(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> x -\<^sub>G y = x +\<^sub>G -\<^sub>G y \<and> -\<^sub>G y \<in>. G" by auto2
setup {* del_prfstep_thm @{thm minus_def} *}

lemma minus_abgroup_fun [rewrite]:
  "is_abgroup_raw(H) \<Longrightarrow> is_abgroup(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow>
   eq_str_abgroup(G,H) \<Longrightarrow> x -\<^sub>G y = x -\<^sub>H y"
@proof @have "x -\<^sub>G y = x +\<^sub>G -\<^sub>G y" @qed

setup {* fold del_prfstep_thm [@{thm plus_commD}, @{thm plus_assoc_left}, @{thm minusD}] *}
ML_file "alg_abgroup.ML"

lemma minus_zero [rewrite]: "is_abgroup(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> a -\<^sub>R \<zero>\<^sub>R = a" by auto2

lemma minus_same_eq_zero [rewrite]:
  "is_abgroup(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> x -\<^sub>G x = \<zero>\<^sub>G" by auto2

lemma minus_eq_zero_same [forward]:
  "is_abgroup(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> x -\<^sub>G y = \<zero>\<^sub>G \<Longrightarrow> x = y"
@proof @have "x -\<^sub>G y = x +\<^sub>G -\<^sub>G y" @qed

section \<open>Subset of an abelian group\<close>

definition nonzero_elts :: "i \<Rightarrow> i" where [rewrite]:
  "nonzero_elts(R) = {x\<in>.R. x \<noteq> \<zero>\<^sub>R}"

lemma nonzero_eltsD [forward]: "x \<in> nonzero_elts(R) \<Longrightarrow> x \<in>. R \<and> x \<noteq> \<zero>\<^sub>R" by auto2
lemma nonzero_eltsI [backward2]: "x \<in>. R \<Longrightarrow> x \<noteq> \<zero>\<^sub>R \<Longrightarrow> x \<in> nonzero_elts(R)" by auto2

end


(*
Title: From Schroeder paths to Dyck paths
Author: Jose Manuel Rodriguez Caballero

We prove the following result.

theorem SchroederToDyckPath : \<open>SchroederPath w \<Longrightarrow> DyckPath (removeAll 0 w)\<close>

(This code  was verified in Isabelle2018)
*)

theory SchroederToDyck

imports Complex_Main DyckPathsDef DyckPathsCharacterization1 SchroederPathsDef

begin

lemma DyckLettersQ : \<open> \<forall> j. j < length w \<longrightarrow> w!j = 1 \<or> w!j = -1 \<Longrightarrow> DyckLetters w\<close>
proof(induction w)
  case Nil
  thus ?case
    using DyckLetters.simps(1) by blast
next
  case (Cons a w)
  thus ?case
    by (metis DyckLetters.simps(2) Suc_mono add_diff_cancel_left' length_Cons nth_Cons_0 nth_non_equal_first_eq plus_1_eq_Suc zero_less_Suc)
qed

lemma SchroederLettersQ : \<open>SchroederLetters w \<Longrightarrow> \<forall> j. j < length w \<longrightarrow> w!j = 1 \<or> w!j = -1 \<or> w!j = 0\<close>
proof(induction w)
  case Nil
  thus ?case
    by simp
next
  case (Cons a w)
  thus ?case
    by (smt One_nat_def SchroederLetters.simps(2) Suc_less_eq Suc_pred length_Cons less_Suc_eq nth_Cons' zero_less_Suc)
qed

lemma preSchroederToDyckLetters:
  assumes \<open>SchroederLetters w\<close> and \<open>\<forall> j. j < length w \<longrightarrow> w!j \<noteq> 0\<close>
  shows \<open>DyckLetters w\<close>
proof-
  have \<open>\<forall> j. j < length w \<longrightarrow> w!j = 1 \<or> w!j = -1 \<or> w!j = 0\<close>
    by (simp add: SchroederLettersQ assms(1))
  hence  \<open>\<forall> j. j < length w \<longrightarrow> w!j = 1 \<or> w!j = -1\<close>
    using \<open>\<forall> j. j < length w \<longrightarrow> w!j \<noteq> 0\<close>
    by blast
  thus ?thesis
    using DyckLettersQ by blast
qed

lemma IgnoreNonZero:
  \<open>(removeAll x w ) \<noteq> [] \<Longrightarrow> (removeAll x w)!0 \<noteq> x\<close>
  by (metis (mono_tags, lifting) length_greater_0_conv length_removeAll_less less_irrefl_nat nth_mem removeAll_filter_not removeAll_filter_not_eq)

lemma IgnoreFirst:  \<open>removeAll t (x#w) = x#w \<Longrightarrow> removeAll t w = w\<close>
  by (metis dual_order.irrefl   length_Cons length_removeAll_less list.set(2) list.set_intros(2)  removeAll_id)

lemma IgnoreQRec:
  assumes \<open>removeAll 0 w = w \<longrightarrow> (\<forall> j. j < length w \<longrightarrow> w!j \<noteq> 0)\<close>
    and \<open>removeAll 0 (x#w) = x#w\<close> and \<open>j < length (x#w)\<close>
  shows \<open>(x#w)!j \<noteq> 0\<close>
proof(cases \<open>j = 0\<close>)
  case True
  thus ?thesis
    by (metis IgnoreNonZero assms(2) assms(3) less_numeral_extra(3) list.size(3))
next
  case False
  obtain i where \<open>Suc i = j\<close>
    using False gr0_implies_Suc by auto
  have \<open>(x#w)!j = w!i\<close>
    using \<open>Suc i = j\<close> by auto
  from \<open>j < length (x#w)\<close>  \<open>Suc i = j\<close> have \<open>i < length w\<close>
    by auto
  from \<open>removeAll 0 (x#w) = x#w\<close> have \<open>removeAll 0 w = w\<close>
    by (meson IgnoreFirst)
  hence \<open>w ! i \<noteq> 0\<close>
    using \<open>i < length w\<close> assms(1) by blast
  hence \<open>(x#w)!j \<noteq> 0\<close>
    by (simp add: \<open>(x # w) ! j = w ! i\<close>)
  thus ?thesis
    by blast
qed

lemma IgnoreQ: \<open>removeAll 0 w = w \<Longrightarrow> \<forall> j. j < length w \<longrightarrow> w!j \<noteq> 0\<close>
proof(induction w)
  case Nil
  thus ?case
    by simp
next
  case (Cons a w)
  thus ?case using IgnoreQRec by blast
qed

lemma IgnoreNot: \<open>removeAll x L \<noteq> L \<Longrightarrow> \<exists> U V. L = U @ [x] @ V \<close>
  by (metis append.left_neutral append_Cons removeAll_id  split_list)

lemma SchroederLettersFactorV: \<open>SchroederLetters (u@v) \<Longrightarrow> SchroederLetters v\<close>
proof(induction u)
  case Nil
  thus ?case
    by auto
next
  case (Cons a u)
  thus ?case
    by (metis SchroederLetters.elims(2) append_Cons list.sel(2) list.sel(3))
qed

lemma SchroederLettersFactorU: \<open>SchroederLetters (u@v) \<Longrightarrow> SchroederLetters u\<close>
proof(induction u)
  case Nil
  thus ?case
    by simp
next
  case (Cons a u)
  thus ?case
    by (metis SchroederLetters.simps(2) append_Cons)
qed

lemma SchroederLettersFactor: \<open>SchroederLetters (u@v@w) \<Longrightarrow> SchroederLetters v\<close>
  using SchroederLettersFactorU SchroederLettersFactorV
  by blast

lemma ConcatIgnore: \<open>removeAll x (U@V) = (removeAll x U) @ (removeAll x V)\<close>
  by simp

lemma ConcatDyckLetters: \<open>DyckLetters (U@V) \<longleftrightarrow> (DyckLetters U) \<and> (DyckLetters V)\<close>
proof(induction U)
  case Nil
  thus ?case
    by simp
next
  case (Cons a U)
  thus ?case
    by simp
qed

lemma SchroederToDyckLettersEq:
  \<open>\<forall> w.  SchroederLetters w \<and> removeAll 0 w = w \<longrightarrow> DyckLetters (removeAll 0 w)\<close>
  by (simp add: IgnoreQ preSchroederToDyckLetters)

lemma SchroederToDyckLettersNeqIndRec:
  assumes \<open>\<forall> w. length w \<le> n \<and> SchroederLetters w \<and> removeAll 0 w \<noteq> w \<longrightarrow> DyckLetters (removeAll 0 w)\<close>
    and \<open>length w \<le> Suc n\<close> and \<open>SchroederLetters w\<close> and \<open>removeAll 0 w \<noteq> w\<close>
  shows \<open>DyckLetters (removeAll 0 w)\<close>
proof-
  obtain U V where \<open>w = U @ [0] @ V\<close>
    by (meson IgnoreNot assms(4))
  have \<open>length U \<le> n\<close>
    using \<open>w = U @ [0] @ V\<close> assms(2) by auto
  have \<open>length V \<le> n\<close>
    using \<open>w = U @ [0] @ V\<close> assms(2) by auto
  have \<open>SchroederLetters U\<close> using SchroederLettersFactor
    by (metis \<open>w = U @ [0] @ V\<close> append_Nil assms(3))
  have \<open>SchroederLetters V\<close> using SchroederLettersFactor
    by (metis (full_types) \<open>w = U @ [0] @ V\<close> assms(3) self_append_conv)
  have \<open>DyckLetters (removeAll 0 U)\<close>
    using SchroederToDyckLettersEq \<open>SchroederLetters U\<close> \<open>length U \<le> n\<close> assms(1) by blast
  have \<open>DyckLetters (removeAll 0 V)\<close>
    using SchroederToDyckLettersEq \<open>SchroederLetters V\<close> \<open>length V \<le> n\<close> assms(1) by blast
  have \<open>DyckLetters (removeAll 0 (U@V))\<close>
    by (simp add: ConcatDyckLetters \<open>DyckLetters (removeAll 0 U)\<close> \<open>DyckLetters (removeAll 0 V)\<close>)
  have \<open>removeAll 0 w = removeAll 0 (U @ [0] @ V)\<close>
    by (simp add: \<open>w = U @ [0] @ V\<close>)
  hence \<open>removeAll 0 w = (removeAll 0 U) @  (removeAll 0 [0]) @  (removeAll 0 V)\<close>
    by auto
  hence \<open>removeAll 0 w = (removeAll 0 U) @  [] @  (removeAll 0 V)\<close>
    by simp
  hence \<open>removeAll 0 w = (removeAll 0 U) @  (removeAll 0 V)\<close>
    by simp
  hence \<open>removeAll 0 w = removeAll 0 (U@V)\<close>
    by simp
  show ?thesis
    using \<open>DyckLetters (removeAll 0 (U @ V))\<close> \<open>removeAll 0 w = removeAll 0 (U @ V)\<close> by auto
qed

lemma SchroederToDyckLettersNeqInd:
  \<open>\<forall> w. length w \<le> n \<and> SchroederLetters w \<and> removeAll 0 w \<noteq> w \<longrightarrow> DyckLetters (removeAll 0 w)\<close>
proof(induction n)
  case 0
  thus ?case
    by simp
next
  case (Suc n)
  thus ?case
    using SchroederToDyckLettersNeqIndRec by blast
qed

lemma SchroederToDyckLettersNeq:
  assumes \<open>SchroederLetters w\<close> \<open>removeAll 0 w \<noteq> w\<close>
  shows \<open>DyckLetters (removeAll 0 w)\<close>
  using SchroederToDyckLettersNeqInd assms(1) assms(2) by blast

lemma SchroederToDyckLetters:
  assumes \<open>SchroederLetters w\<close>
  shows \<open>DyckLetters (removeAll 0 w)\<close>
  using SchroederToDyckLettersEq SchroederToDyckLettersNeq assms by blast

lemma NonNegCharac : \<open>NonNeg w \<longleftrightarrow> (\<forall> j. j < length w \<longrightarrow> w!j \<ge> 0)\<close>
proof(induction w)
  case Nil
  thus ?case
    by simp
next
  case (Cons a w)
  thus ?case
    by (metis NonNeg.simps(2) One_nat_def Suc_less_eq Suc_pred length_Cons nth_Cons' nth_Cons_Suc nth_non_equal_first_eq zero_less_Suc)
qed

lemma HeightListRecE :
  \<open>\<forall> x. \<exists> v. HeightList (x#w) = x#(HeightList v) \<and> length (HeightList w) = length (HeightList v)\<close>
proof(induction w)
  case Nil
  thus ?case
    by (metis HeightList.simps(1) HeightList.simps(2) length_0_conv list.size(3))
next
  case (Cons a w)
  thus ?case
    by (metis HeightList.simps(3) length_Cons)
qed

lemma LengthHeightList : \<open>length w = length (HeightList w)\<close>
proof(induction w)
  case Nil
  thus ?case
    by simp
next
  case (Cons a w)
  obtain v where \<open>HeightList (a#w) = a#(HeightList v)\<close> and \<open>length (HeightList w) = length (HeightList v)\<close>
    using HeightListRecE
    by blast
  assume \<open>length w = length (HeightList w)\<close>
  hence \<open>1+length w = 1+length (HeightList w)\<close>
    by simp
  hence \<open>length (a#w) = 1+length (HeightList w)\<close>
    by simp
  hence \<open>length (a#w) = length (a#(HeightList w))\<close>
    by simp
  have \<open>length (HeightList w) = length w\<close>
    by (simp add: Cons.IH)
  thus ?case
    by (simp add: \<open>HeightList (a # w) = a # HeightList v\<close> \<open>length (HeightList w) = length (HeightList v)\<close>)
qed

lemma NonNegPathQ : \<open>NonNegPath w \<longleftrightarrow> (\<forall> j. j < length w \<longrightarrow> (HeightList w)!j \<ge> 0)\<close>
  using NonNegCharac LengthHeightList
  by auto

lemma HeightListprefix:
  fixes j :: nat
  assumes \<open>j < length U\<close>
  shows \<open>(HeightList (U@V))!j = (HeightList U)!j\<close>
proof(cases \<open>U = []\<close>)
  case True
  thus ?thesis
    using assms by auto
next
  case False
  hence \<open>(HeightList (U@V)) = (HeightList U) @ (incr (HeightList V) (last (HeightList U)))\<close>
    by (simp add: ConcatHeight)
  thus ?thesis
    by (metis LengthHeightList assms nth_append)
qed

lemma preSchroederToDyckNonNegPathRedA : \<open>\<forall> j. j < length w \<longrightarrow> (HeightList w)!j \<ge> 0
\<Longrightarrow> w = U @ [0] @ V \<Longrightarrow>  j < length U \<Longrightarrow> (HeightList (U@V))!j \<ge> 0\<close>
  by (metis HeightListprefix append.left_neutral append_Cons le_iff_add length_append less_le_trans)

lemma HeightListbeginwithzero: \<open>HeightList (0#w) = 0 # (HeightList w)\<close>
proof(induction w)
  case Nil
  thus ?case
    by simp
next
  case (Cons a w)
  thus ?case
    by simp
qed

lemma preSchroederToDyckNonNegPathRedBempty : \<open>\<forall> j. j < length w \<longrightarrow> (HeightList w)!j \<ge> 0
\<Longrightarrow> w =  [0] @ V \<Longrightarrow>  j < length V \<Longrightarrow> (HeightList V)!j \<ge> 0\<close>
  using HeightListbeginwithzero
  by auto

lemma preSchroederToDyckNonNegPathRedB : \<open>\<forall> j. j < length w \<longrightarrow> (HeightList w)!j \<ge> 0
\<Longrightarrow> w = U @ [0] @ V \<Longrightarrow>  j < length (U@V) \<Longrightarrow> length U \<le> j  \<Longrightarrow> (HeightList (U@V))!j \<ge> 0\<close>
proof(cases \<open>U = []\<close>)
  case True
  assume \<open>\<forall> j. j < length w \<longrightarrow> (HeightList w)!j \<ge> 0\<close>
  assume \<open>w = U @ [0] @ V\<close>
  assume \<open>j < length (U@V)\<close>
  assume \<open>length U \<le> j\<close>
  thus ?thesis using preSchroederToDyckNonNegPathRedBempty
    by (metis True \<open>\<forall>j<length w. 0 \<le> HeightList w ! j\<close> \<open>j < length (U @ V)\<close> \<open>w = U @ [0] @ V\<close> append_Cons append_Nil)
next
  case False
  assume \<open>\<forall> j. j < length w \<longrightarrow> (HeightList w)!j \<ge> 0\<close>
  assume \<open>w = U @ [0] @ V\<close>
  assume \<open>j < length (U@V)\<close>
  assume \<open>length U \<le> j\<close>
  have \<open>HeightList w = HeightList ((U @ [0]) @ V)\<close> using \<open>w = U @ [0] @ V\<close> by simp
  hence  \<open>HeightList w = (HeightList (U@[0])) @ (incr ((HeightList  V)) (last (HeightList (U@[0]))))\<close>
    by (metis ConcatHeight Nil_is_append_conv list.discI)
  have \<open>HeightList (U@[0]) = (HeightList U) @ (incr [0] (last (HeightList U)))\<close>
    by (simp add: ConcatHeight False)
  hence \<open>HeightList (U@[0]) = (HeightList U) @ [last (HeightList U)]\<close>
    by simp
  have \<open>last (HeightList (U@[0])) = last (HeightList U)\<close>
    by (simp add: \<open>HeightList (U @ [0]) = HeightList U @ [last (HeightList U)]\<close>)
  hence  \<open>HeightList w = (HeightList U) @ [last (HeightList U)] @ (incr ((HeightList  V)) (last (HeightList U)))\<close>
    using \<open>HeightList (U @ [0]) = HeightList U @ [last (HeightList U)]\<close> \<open>HeightList w = HeightList (U @ [0]) @ incr (HeightList V) (last (HeightList (U @ [0])))\<close> by auto
  obtain i where \<open>j = (length U) + i\<close>
    using \<open>length U \<le> j\<close> le_Suc_ex by auto
  have \<open>(HeightList w)!(j+1) =  (incr ((HeightList  V)) (last (HeightList U)))!i\<close>
    by (metis LengthHeightList \<open>HeightList w = HeightList (U @ [0]) @ incr (HeightList V) (last (HeightList (U @ [0])))\<close> \<open>j = length U + i\<close> \<open>last (HeightList (U @ [0])) = last (HeightList U)\<close> add.commute length_append_singleton nth_append_length_plus plus_1_eq_Suc plus_nat.simps(2))
  have \<open>(HeightList w)!(j+1) = (HeightList (U@V))!j\<close>
    by (metis ConcatHeight False LengthHeightList \<open>HeightList w ! (j + 1) = incr (HeightList V) (last (HeightList U)) ! i\<close> \<open>j = length U + i\<close> nth_append_length_plus)
  have \<open>(HeightList (U@V))!j =  (incr ((HeightList  V)) (last (HeightList U)))!i\<close>
    using \<open>HeightList w ! (j + 1) = HeightList (U @ V) ! j\<close> \<open>HeightList w ! (j + 1) = incr (HeightList V) (last (HeightList U)) ! i\<close> by auto
  thus ?thesis
    using \<open>HeightList w ! (j + 1) = incr (HeightList V) (last (HeightList U)) ! i\<close> \<open>\<forall>j<length w. 0 \<le> HeightList w ! j\<close> \<open>j < length (U @ V)\<close> \<open>w = U @ [0] @ V\<close> by auto
qed

lemma preSchroederToDyckNonNegPathRedS : \<open>\<forall> j. j < length w \<longrightarrow> (HeightList w)!j \<ge> 0
\<Longrightarrow> w = U @ [0] @ V \<Longrightarrow>  j < length (U@V) \<Longrightarrow> (HeightList (U@V))!j \<ge> 0\<close>
  using preSchroederToDyckNonNegPathRedA preSchroederToDyckNonNegPathRedB
  by (metis leI)

lemma preSchroederToDyckNonNegPathRed : \<open>\<forall> j. j < length w \<longrightarrow> (HeightList w)!j \<ge> 0
\<Longrightarrow> w = U @ [0] @ V \<Longrightarrow> \<forall> j. j < length (U@V) \<longrightarrow> (HeightList (U@V))!j \<ge> 0\<close>
  using preSchroederToDyckNonNegPathRedS by blast

lemma preSchroederToDyckNonNegPathIndRec :
  assumes \<open>\<forall> w. length w = n + length(removeAll 0 w) \<and> (\<forall> j. j < length w \<longrightarrow> (HeightList w)!j \<ge> 0)
 \<longrightarrow> (\<forall> j. j < length (removeAll 0 w) \<longrightarrow> (HeightList (removeAll 0 w))!j \<ge> 0)\<close>
    and \<open>length w = (Suc n) + length(removeAll 0 w)\<close> \<open>\<forall> j. j < length w \<longrightarrow> (HeightList w)!j \<ge> 0\<close>
  shows \<open>\<forall> j. j < length (removeAll 0 w) \<longrightarrow> (HeightList (removeAll 0 w))!j \<ge> 0\<close>
proof-
  have  \<open>w \<noteq> removeAll 0 w\<close>
    using assms(2) by auto
  then obtain U V where \<open>w = U @ [0] @ V\<close>
    by (metis IgnoreNot)
  have \<open>removeAll 0 (U @ [0] @ V) = removeAll 0 (U @ V)\<close>
    by simp
  hence \<open>removeAll 0 w = removeAll 0 (U @ V)\<close>
    using \<open>w = U @ [0] @ V\<close> by blast
  hence \<open>length (U@V) = n + length(removeAll 0 (U@V))\<close>
    using \<open>w = U @ [0] @ V\<close> assms(2) by auto
  have \<open>\<forall> j. j < length (U@V) \<longrightarrow> (HeightList (U@V))!j \<ge> 0\<close>
    using \<open>\<forall>j<length w. 0 \<le> HeightList w ! j\<close> \<open>w = U @ [0] @ V\<close> preSchroederToDyckNonNegPathRed by blast
  have  \<open>\<forall> j. j < length (removeAll 0 (U@V)) \<longrightarrow> (HeightList (removeAll 0 (U@V)))!j \<ge> 0\<close>
    using  \<open>\<forall> j. j < length (U@V) \<longrightarrow> (HeightList (U@V))!j \<ge> 0\<close>  \<open>length (U@V) = n + length(removeAll 0 (U@V))\<close>
      \<open>\<forall> w. length w = n + length(removeAll 0 w) \<and> (\<forall> j. j < length w \<longrightarrow> (HeightList w)!j \<ge> 0)
 \<longrightarrow> (\<forall> j. j < length (removeAll 0 w) \<longrightarrow> (HeightList (removeAll 0 w))!j \<ge> 0)\<close>
    by blast
  thus ?thesis
    by (simp add: \<open>removeAll 0 w = removeAll 0 (U @ V)\<close>)
qed

lemma preSchroederToDyckNonNegPathInd : \<open>\<forall> w. length w = n + length(removeAll 0 w) \<and> (\<forall> j. j < length w \<longrightarrow> (HeightList w)!j \<ge> 0)
 \<longrightarrow> (\<forall> j. j < length (removeAll 0 w) \<longrightarrow> (HeightList (removeAll 0 w))!j \<ge> 0)\<close>
proof(induction n)
  case 0
  thus ?case
    by (metis add.left_neutral length_removeAll_less not_add_less2 removeAll_id)
next
  case (Suc n)
  thus ?case using preSchroederToDyckNonNegPathIndRec
    by blast
qed

lemma preSchroederToDyckNonNegPath : \<open>\<forall> j. j < length w \<longrightarrow> (HeightList w)!j \<ge> 0
 \<Longrightarrow> \<forall> j. j < length (removeAll 0 w) \<longrightarrow> (HeightList (removeAll 0 w))!j \<ge> 0\<close>
  using preSchroederToDyckNonNegPathInd
  by (metis add.commute le_iff_add length_removeAll_less_eq)

lemma SchroederToDyckNonNegPath : \<open>NonNegPath w \<Longrightarrow> NonNegPath (removeAll 0 w)\<close>
proof-
  assume \<open>NonNegPath w\<close>
  hence \<open>\<forall> j. j < length w \<longrightarrow> (HeightList w)!j \<ge> 0\<close>
    using NonNegPathQ by blast
  hence \<open>\<forall> j. j < length (removeAll 0 w) \<longrightarrow> (HeightList (removeAll 0 w))!j \<ge> 0\<close>
    by (simp add: preSchroederToDyckNonNegPath)
  thus ?thesis
    using NonNegPathQ by blast
qed

lemma preSchroederToDycklastHeightListXY:
  assumes \<open>\<forall> w. length w = n + length (removeAll 0 w) \<and> (removeAll 0 w) \<noteq> [] \<longrightarrow> last (HeightList w) = last (HeightList (removeAll 0 w))\<close>
    and \<open>length w = Suc n + length (removeAll 0 w)\<close> and \<open>(removeAll 0 w) \<noteq> []\<close>
  shows \<open>last (HeightList w) = last (HeightList (removeAll 0 w))\<close>
proof-
  from \<open>length w = Suc n + length (removeAll 0 w)\<close>
  have \<open>w \<noteq> removeAll 0 w\<close>
    by auto
  obtain U V where \<open>w = U @ [0] @ V\<close>
    by (metis IgnoreNot \<open>w \<noteq> removeAll 0 w\<close>)
  have \<open>length (U@V) =  n + length (removeAll 0 (U@V))\<close>
    using \<open>w = U @ [0] @ V\<close> assms(2) by auto
  have \<open>(removeAll 0 w) = (removeAll 0 (U@V))\<close>
    by (simp add: \<open>w = U @ [0] @ V\<close>)
  have \<open>(removeAll 0 (U@V)) \<noteq> []\<close>
    using \<open>removeAll 0 w = removeAll 0 (U @ V)\<close> assms(3) by auto
  have \<open>last (HeightList  (U @ V)) = last (HeightList (removeAll 0  (U @ V)))\<close>
    using \<open>length (U @ V) = n + length (removeAll 0 (U @ V))\<close> \<open>removeAll 0 (U @ V) \<noteq> []\<close> assms(1) by blast
  have \<open>last (HeightList w) = last (HeightList (U@V))\<close>
    by (smt ConcatHeightSum HeightList.simps(2) \<open>length (U @ V) = n + length (removeAll 0 (U @ V))\<close> \<open>removeAll 0 (U @ V) \<noteq> []\<close> \<open>w = U @ [0] @ V\<close> append.right_neutral append_is_Nil_conv append_self_conv2 last.simps length_0_conv zero_eq_add_iff_both_eq_0)
  show ?thesis
    by (simp add: \<open>last (HeightList (U @ V)) = last (HeightList (removeAll 0 (U @ V)))\<close> \<open>last (HeightList w) = last (HeightList (U @ V))\<close> \<open>removeAll 0 w = removeAll 0 (U @ V)\<close>)
qed

lemma preSchroederToDycklastHeightListX: \<open>\<forall> w. length w = n + length (removeAll 0 w) \<and> (removeAll 0 w) \<noteq> [] \<longrightarrow> last (HeightList w) = last (HeightList (removeAll 0 w))\<close>
proof(induction n)
  case 0
  thus ?case
    by (metis add.left_neutral length_removeAll_less not_add_less2 removeAll_id)
next
  case (Suc n)
  thus ?case using preSchroederToDycklastHeightListXY
    by blast
qed

lemma SchroederToDycklastHeightListX: \<open>(removeAll 0 w) \<noteq> [] \<Longrightarrow> last (HeightList w) = last (HeightList (removeAll 0 w))\<close>
  using preSchroederToDycklastHeightListX
  by (metis add.commute le_Suc_ex length_removeAll_less_eq)

lemma SchroederToDycklastHeightList: \<open>w \<noteq> [] \<longrightarrow> last (HeightList w) = 0 \<Longrightarrow> (removeAll 0 w) \<noteq> [] \<longrightarrow> last (HeightList (removeAll 0 w)) = 0\<close>
  using SchroederToDycklastHeightListX
  by (metis removeAll.simps(1))

theorem SchroederToDyckPath : \<open>SchroederPath w \<Longrightarrow> DyckPath (removeAll 0 w)\<close>
  using SchroederToDyckLetters SchroederToDyckNonNegPath SchroederToDycklastHeightList
  by simp

end