(*  Title:      HOL/NSA/HLim.thy
    Author:     Jacques D. Fleuriot, University of Cambridge
    Author:     Lawrence C Paulson
*)

section{* Limits and Continuity (Nonstandard) *}

theory HLim
imports Star
begin

text{*Nonstandard Definitions*}

definition
  NSLIM :: "['a::real_normed_vector => 'b::real_normed_vector, 'a, 'b] => bool"
            ("((_)/ -- (_)/ --NS> (_))" [60, 0, 60] 60) where
  "f -- a --NS> L =
    (\<forall>x. (x \<noteq> star_of a & x @= star_of a --> ( *f* f) x @= star_of L))"

definition
  isNSCont :: "['a::real_normed_vector => 'b::real_normed_vector, 'a] => bool" where
    --{*NS definition dispenses with limit notions*}
  "isNSCont f a = (\<forall>y. y @= star_of a -->
         ( *f* f) y @= star_of (f a))"

definition
  isNSUCont :: "['a::real_normed_vector => 'b::real_normed_vector] => bool" where
  "isNSUCont f = (\<forall>x y. x @= y --> ( *f* f) x @= ( *f* f) y)"

subsection {* Limits of Functions *}

lemma NSLIM_I:
  "(\<And>x. \<lbrakk>x \<noteq> star_of a; x \<approx> star_of a\<rbrakk> \<Longrightarrow> starfun f x \<approx> star_of L)
   \<Longrightarrow> f -- a --NS> L"
by (simp add: NSLIM_def)

lemma NSLIM_D:
  "\<lbrakk>f -- a --NS> L; x \<noteq> star_of a; x \<approx> star_of a\<rbrakk>
   \<Longrightarrow> starfun f x \<approx> star_of L"
by (simp add: NSLIM_def)

text{*Proving properties of limits using nonstandard definition.
      The properties hold for standard limits as well!*}

lemma NSLIM_mult:
  fixes l m :: "'a::real_normed_algebra"
  shows "[| f -- x --NS> l; g -- x --NS> m |]
      ==> (%x. f(x) * g(x)) -- x --NS> (l * m)"
by (auto simp add: NSLIM_def intro!: approx_mult_HFinite)

lemma starfun_scaleR [simp]:
  "starfun (\<lambda>x. f x *\<^sub>R g x) = (\<lambda>x. scaleHR (starfun f x) (starfun g x))"
by transfer (rule refl)

lemma NSLIM_scaleR:
  "[| f -- x --NS> l; g -- x --NS> m |]
      ==> (%x. f(x) *\<^sub>R g(x)) -- x --NS> (l *\<^sub>R m)"
by (auto simp add: NSLIM_def intro!: approx_scaleR_HFinite)

lemma NSLIM_add:
     "[| f -- x --NS> l; g -- x --NS> m |]
      ==> (%x. f(x) + g(x)) -- x --NS> (l + m)"
by (auto simp add: NSLIM_def intro!: approx_add)

lemma NSLIM_const [simp]: "(%x. k) -- x --NS> k"
by (simp add: NSLIM_def)

lemma NSLIM_minus: "f -- a --NS> L ==> (%x. -f(x)) -- a --NS> -L"
by (simp add: NSLIM_def)

lemma NSLIM_diff:
  "\<lbrakk>f -- x --NS> l; g -- x --NS> m\<rbrakk> \<Longrightarrow> (\<lambda>x. f x - g x) -- x --NS> (l - m)"
  by (simp only: NSLIM_add NSLIM_minus diff_conv_add_uminus)

lemma NSLIM_add_minus: "[| f -- x --NS> l; g -- x --NS> m |] ==> (%x. f(x) + -g(x)) -- x --NS> (l + -m)"
by (simp only: NSLIM_add NSLIM_minus)

lemma NSLIM_inverse:
  fixes L :: "'a::real_normed_div_algebra"
  shows "[| f -- a --NS> L;  L \<noteq> 0 |]
      ==> (%x. inverse(f(x))) -- a --NS> (inverse L)"
apply (simp add: NSLIM_def, clarify)
apply (drule spec)
apply (auto simp add: star_of_approx_inverse)
done

lemma NSLIM_zero:
  assumes f: "f -- a --NS> l" shows "(%x. f(x) - l) -- a --NS> 0"
proof -
  have "(\<lambda>x. f x - l) -- a --NS> l - l"
    by (rule NSLIM_diff [OF f NSLIM_const])
  thus ?thesis by simp
qed

lemma NSLIM_zero_cancel: "(%x. f(x) - l) -- x --NS> 0 ==> f -- x --NS> l"
apply (drule_tac g = "%x. l" and m = l in NSLIM_add)
apply (auto simp add: add.assoc)
done

lemma NSLIM_const_not_eq:
  fixes a :: "'a::real_normed_algebra_1"
  shows "k \<noteq> L \<Longrightarrow> \<not> (\<lambda>x. k) -- a --NS> L"
apply (simp add: NSLIM_def)
apply (rule_tac x="star_of a + of_hypreal epsilon" in exI)
apply (simp add: hypreal_epsilon_not_zero approx_def)
done

lemma NSLIM_not_zero:
  fixes a :: "'a::real_normed_algebra_1"
  shows "k \<noteq> 0 \<Longrightarrow> \<not> (\<lambda>x. k) -- a --NS> 0"
by (rule NSLIM_const_not_eq)

lemma NSLIM_const_eq:
  fixes a :: "'a::real_normed_algebra_1"
  shows "(\<lambda>x. k) -- a --NS> L \<Longrightarrow> k = L"
apply (rule ccontr)
apply (blast dest: NSLIM_const_not_eq)
done

lemma NSLIM_unique:
  fixes a :: "'a::real_normed_algebra_1"
  shows "\<lbrakk>f -- a --NS> L; f -- a --NS> M\<rbrakk> \<Longrightarrow> L = M"
apply (drule (1) NSLIM_diff)
apply (auto dest!: NSLIM_const_eq)
done

lemma NSLIM_mult_zero:
  fixes f g :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_algebra"
  shows "[| f -- x --NS> 0; g -- x --NS> 0 |] ==> (%x. f(x)*g(x)) -- x --NS> 0"
by (drule NSLIM_mult, auto)

lemma NSLIM_self: "(%x. x) -- a --NS> a"
by (simp add: NSLIM_def)

subsubsection {* Equivalence of @{term filterlim} and @{term NSLIM} *}

lemma LIM_NSLIM:
  assumes f: "f -- a --> L" shows "f -- a --NS> L"
proof (rule NSLIM_I)
  fix x
  assume neq: "x \<noteq> star_of a"
  assume approx: "x \<approx> star_of a"
  have "starfun f x - star_of L \<in> Infinitesimal"
  proof (rule InfinitesimalI2)
    fix r::real assume r: "0 < r"
    from LIM_D [OF f r]
    obtain s where s: "0 < s" and
      less_r: "\<And>x. \<lbrakk>x \<noteq> a; norm (x - a) < s\<rbrakk> \<Longrightarrow> norm (f x - L) < r"
      by fast
    from less_r have less_r':
       "\<And>x. \<lbrakk>x \<noteq> star_of a; hnorm (x - star_of a) < star_of s\<rbrakk>
        \<Longrightarrow> hnorm (starfun f x - star_of L) < star_of r"
      by transfer
    from approx have "x - star_of a \<in> Infinitesimal"
      by (unfold approx_def)
    hence "hnorm (x - star_of a) < star_of s"
      using s by (rule InfinitesimalD2)
    with neq show "hnorm (starfun f x - star_of L) < star_of r"
      by (rule less_r')
  qed
  thus "starfun f x \<approx> star_of L"
    by (unfold approx_def)
qed

lemma NSLIM_LIM:
  assumes f: "f -- a --NS> L" shows "f -- a --> L"
proof (rule LIM_I)
  fix r::real assume r: "0 < r"
  have "\<exists>s>0. \<forall>x. x \<noteq> star_of a \<and> hnorm (x - star_of a) < s
        \<longrightarrow> hnorm (starfun f x - star_of L) < star_of r"
  proof (rule exI, safe)
    show "0 < epsilon" by (rule hypreal_epsilon_gt_zero)
  next
    fix x assume neq: "x \<noteq> star_of a"
    assume "hnorm (x - star_of a) < epsilon"
    with Infinitesimal_epsilon
    have "x - star_of a \<in> Infinitesimal"
      by (rule hnorm_less_Infinitesimal)
    hence "x \<approx> star_of a"
      by (unfold approx_def)
    with f neq have "starfun f x \<approx> star_of L"
      by (rule NSLIM_D)
    hence "starfun f x - star_of L \<in> Infinitesimal"
      by (unfold approx_def)
    thus "hnorm (starfun f x - star_of L) < star_of r"
      using r by (rule InfinitesimalD2)
  qed
  thus "\<exists>s>0. \<forall>x. x \<noteq> a \<and> norm (x - a) < s \<longrightarrow> norm (f x - L) < r"
    by transfer
qed

theorem LIM_NSLIM_iff: "(f -- x --> L) = (f -- x --NS> L)"
by (blast intro: LIM_NSLIM NSLIM_LIM)

subsection {* Continuity *}

lemma isNSContD:
  "\<lbrakk>isNSCont f a; y \<approx> star_of a\<rbrakk> \<Longrightarrow> ( *f* f) y \<approx> star_of (f a)"
by (simp add: isNSCont_def)

lemma isNSCont_NSLIM: "isNSCont f a ==> f -- a --NS> (f a) "
by (simp add: isNSCont_def NSLIM_def)

lemma NSLIM_isNSCont: "f -- a --NS> (f a) ==> isNSCont f a"
apply (simp add: isNSCont_def NSLIM_def, auto)
apply (case_tac "y = star_of a", auto)
done

text{*NS continuity can be defined using NS Limit in
    similar fashion to standard def of continuity*}
lemma isNSCont_NSLIM_iff: "(isNSCont f a) = (f -- a --NS> (f a))"
by (blast intro: isNSCont_NSLIM NSLIM_isNSCont)

text{*Hence, NS continuity can be given
  in terms of standard limit*}
lemma isNSCont_LIM_iff: "(isNSCont f a) = (f -- a --> (f a))"
by (simp add: LIM_NSLIM_iff isNSCont_NSLIM_iff)

text{*Moreover, it's trivial now that NS continuity
  is equivalent to standard continuity*}
lemma isNSCont_isCont_iff: "(isNSCont f a) = (isCont f a)"
apply (simp add: isCont_def)
apply (rule isNSCont_LIM_iff)
done

text{*Standard continuity ==> NS continuity*}
lemma isCont_isNSCont: "isCont f a ==> isNSCont f a"
by (erule isNSCont_isCont_iff [THEN iffD2])

text{*NS continuity ==> Standard continuity*}
lemma isNSCont_isCont: "isNSCont f a ==> isCont f a"
by (erule isNSCont_isCont_iff [THEN iffD1])

text{*Alternative definition of continuity*}

(* Prove equivalence between NS limits - *)
(* seems easier than using standard def  *)
lemma NSLIM_h_iff: "(f -- a --NS> L) = ((%h. f(a + h)) -- 0 --NS> L)"
apply (simp add: NSLIM_def, auto)
apply (drule_tac x = "star_of a + x" in spec)
apply (drule_tac [2] x = "- star_of a + x" in spec, safe, simp)
apply (erule mem_infmal_iff [THEN iffD2, THEN Infinitesimal_add_approx_self [THEN approx_sym]])
apply (erule_tac [3] approx_minus_iff2 [THEN iffD1])
 prefer 2 apply (simp add: add.commute)
apply (rule_tac x = x in star_cases)
apply (rule_tac [2] x = x in star_cases)
apply (auto simp add: starfun star_of_def star_n_minus star_n_add add.assoc star_n_zero_num)
done

lemma NSLIM_isCont_iff: "(f -- a --NS> f a) = ((%h. f(a + h)) -- 0 --NS> f a)"
  by (fact NSLIM_h_iff)

lemma isNSCont_minus: "isNSCont f a ==> isNSCont (%x. - f x) a"
by (simp add: isNSCont_def)

lemma isNSCont_inverse:
  fixes f :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_div_algebra"
  shows "[| isNSCont f x; f x \<noteq> 0 |] ==> isNSCont (%x. inverse (f x)) x"
by (auto intro: isCont_inverse simp add: isNSCont_isCont_iff)

lemma isNSCont_const [simp]: "isNSCont (%x. k) a"
by (simp add: isNSCont_def)

lemma isNSCont_abs [simp]: "isNSCont abs (a::real)"
apply (simp add: isNSCont_def)
apply (auto intro: approx_hrabs simp add: starfun_rabs_hrabs)
done

subsection {* Uniform Continuity *}

lemma isNSUContD: "[| isNSUCont f; x \<approx> y|] ==> ( *f* f) x \<approx> ( *f* f) y"
by (simp add: isNSUCont_def)

lemma isUCont_isNSUCont:
  fixes f :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
  assumes f: "isUCont f" shows "isNSUCont f"
proof (unfold isNSUCont_def, safe)
  fix x y :: "'a star"
  assume approx: "x \<approx> y"
  have "starfun f x - starfun f y \<in> Infinitesimal"
  proof (rule InfinitesimalI2)
    fix r::real assume r: "0 < r"
    with f obtain s where s: "0 < s" and
      less_r: "\<And>x y. norm (x - y) < s \<Longrightarrow> norm (f x - f y) < r"
      by (auto simp add: isUCont_def dist_norm)
    from less_r have less_r':
       "\<And>x y. hnorm (x - y) < star_of s
        \<Longrightarrow> hnorm (starfun f x - starfun f y) < star_of r"
      by transfer
    from approx have "x - y \<in> Infinitesimal"
      by (unfold approx_def)
    hence "hnorm (x - y) < star_of s"
      using s by (rule InfinitesimalD2)
    thus "hnorm (starfun f x - starfun f y) < star_of r"
      by (rule less_r')
  qed
  thus "starfun f x \<approx> starfun f y"
    by (unfold approx_def)
qed

lemma isNSUCont_isUCont:
  fixes f :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
  assumes f: "isNSUCont f" shows "isUCont f"
proof (unfold isUCont_def dist_norm, safe)
  fix r::real assume r: "0 < r"
  have "\<exists>s>0. \<forall>x y. hnorm (x - y) < s
        \<longrightarrow> hnorm (starfun f x - starfun f y) < star_of r"
  proof (rule exI, safe)
    show "0 < epsilon" by (rule hypreal_epsilon_gt_zero)
  next
    fix x y :: "'a star"
    assume "hnorm (x - y) < epsilon"
    with Infinitesimal_epsilon
    have "x - y \<in> Infinitesimal"
      by (rule hnorm_less_Infinitesimal)
    hence "x \<approx> y"
      by (unfold approx_def)
    with f have "starfun f x \<approx> starfun f y"
      by (simp add: isNSUCont_def)
    hence "starfun f x - starfun f y \<in> Infinitesimal"
      by (unfold approx_def)
    thus "hnorm (starfun f x - starfun f y) < star_of r"
      using r by (rule InfinitesimalD2)
  qed
  thus "\<exists>s>0. \<forall>x y. norm (x - y) < s \<longrightarrow> norm (f x - f y) < r"
    by transfer
qed

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory DataStructures
imports Main
begin

(*
 * Proofs on abstract data structures that should be applicable
 * to concrete C proofs.
 *)

(*
 * Singly-linked list definitions and lemmas adapted from:
 *
 *   "Proving Pointer Programs in Higher-Order Logic"
 *   Farhad Mehta, Tobias Nipkow
 *)

locale linked_list =
  (* Fetch next pointer from object. *)
  fixes list_next :: "'a \<Rightarrow> 'p"
  (* Null pointer. *)
  and NULL :: "'p"

context linked_list begin

primrec
  list :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p list \<Rightarrow> 'p \<Rightarrow> bool"
where
  "list s [] i = (i = NULL)"
| "list s (x#xs) i =
    (i = x \<and> x \<noteq> NULL \<and> (\<exists>a. s x = Some a \<and>  list s xs (list_next a)))"

definition
  is_list :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p \<Rightarrow> bool"
where
  "is_list s p \<equiv> \<exists>xs. list s xs p"

definition
  the_list :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p \<Rightarrow> 'p list"
where
  "the_list s p \<equiv> (THE xs. list s xs p)"

lemma list_empty [simp]: "list s xs NULL = (xs = [])"
  by (case_tac "xs", auto)

lemma is_list_empty [simp]: "is_list s NULL"
  by (clarsimp simp: is_list_def)

lemma the_list_empty [simp]: "the_list s NULL = []"
  by (clarsimp simp: the_list_def)

lemma list_unique: "\<lbrakk> list s xs p; list s ys p \<rbrakk> \<Longrightarrow> xs = ys"
  apply (induct xs arbitrary: ys p)
   apply simp
  apply (case_tac ys, auto)
  done

lemma list_ptr_unique: "\<lbrakk> list s xs p; list s xs p' \<rbrakk> \<Longrightarrow> p = p'"
  by (metis linked_list.list.simps(1) linked_list.list.simps(2) neq_Nil_conv)

lemma list_non_NULL:
  "p \<noteq> NULL \<Longrightarrow>
    list s xs p = (\<exists>ys. xs= p#ys \<and> (\<exists>a. s p = Some a \<and> list s ys (list_next a)))"
  by (case_tac xs, auto)

lemma is_list_non_NULL:
  "p \<noteq> NULL \<Longrightarrow>
    is_list s p = (\<exists>a. s p = Some a \<and> is_list s (list_next a))"
  apply (clarsimp simp: is_list_def list_non_NULL)
  apply force
  done

lemma the_list_non_NULL:
  "\<lbrakk> p \<noteq> NULL; is_list s p \<rbrakk> \<Longrightarrow>
    the_list s p = (p # (the_list s (list_next (the (s p)))))"
  apply (clarsimp simp: the_list_def is_list_def list_non_NULL)
  apply (rule the_equality)
   apply (clarsimp simp: list_unique)
   apply (metis (lifting) list_unique the_equality)
  apply clarsimp
  apply (metis (lifting) list_unique the_equality)
  done

lemma list_is_list: "list s xs p \<Longrightarrow> is_list s p"
  apply (clarsimp simp: is_list_def)
  apply force
  done

lemma list_the_list: "list s xs p \<Longrightarrow> the_list s p = xs"
  apply (clarsimp simp: the_list_def)
  apply (metis (lifting) list_unique the_equality)
  done

lemma the_list_empty' [simp]:
    "is_list s p \<Longrightarrow> (the_list s p = []) = (p = NULL)"
  by (metis is_list_def list_empty list_ptr_unique list_the_list)

lemma list_last_is_NULL:
    "\<lbrakk> is_list s p; the_list s p = l; p \<noteq> NULL \<rbrakk> \<Longrightarrow> list_next (the (s (last l))) = NULL"
  apply (induct l arbitrary: p)
   apply clarsimp
  apply (metis is_list_non_NULL last_ConsL last_ConsR linked_list.the_list_non_NULL option.sel the_list_empty' list.sel(3))
  done

lemma list_in_Some:
  "\<lbrakk> list s xs p; x \<in> set xs \<rbrakk> \<Longrightarrow> \<exists>a. s x = Some a"
  apply (induct xs arbitrary: p, auto)
  done

lemma list_mem: "\<lbrakk> list s xs p; p \<noteq> NULL \<rbrakk> \<Longrightarrow> p \<in> set xs"
  by (case_tac xs, auto)

lemma list_ign [iff]: "\<lbrakk> x \<notin> set xs \<rbrakk> \<Longrightarrow> list (s(x := v)) xs p = list s xs p"
  apply (induct xs arbitrary: p)
   apply clarsimp
  apply atomize
  apply clarsimp
  done

lemma list_ign_ext' [intro, iff]:
    "\<lbrakk> \<forall>x \<in> set xs. (\<exists>a. s x = Some a) = (\<exists>a. s' x = Some a) \<and> (list_next (the (s x)) = list_next (the (s' x)))  \<rbrakk> \<Longrightarrow> list s xs p = list s' xs p"
  apply (induct xs arbitrary: p, auto)
  done

lemma list_ign_ext [iff?]: "\<lbrakk> \<forall>x \<in> set xs. s x = s' x \<rbrakk> \<Longrightarrow> list s xs p = list s' xs p"
  apply force
  done

lemma list_append_Ex:
  "list s (xs@ys) p \<Longrightarrow> (\<exists>q. list s ys q)"
  apply (induct xs arbitrary: ys p)
   apply force
  apply force
  done

lemma list_head_not_in_list: "\<lbrakk> list s xs (list_next a); s p = Some a \<rbrakk> \<Longrightarrow> p \<notin> set xs"
  apply (rule ccontr)
  apply clarsimp
  apply (frule split_list)
  apply clarsimp
  apply (frule list_append_Ex)
  apply clarsimp
  apply (drule (1) list_unique)
  apply clarsimp
  done

lemma list_distinct: "list s xs x \<Longrightarrow> distinct xs"
  apply (induct xs arbitrary: x)
   apply clarsimp
  apply clarsimp
  apply (drule (1) list_head_not_in_list)
  apply clarsimp
  done

lemma list_next: "\<lbrakk> list s xs x; s x = Some a; x \<noteq> NULL \<rbrakk> \<Longrightarrow> list s (tl xs) (list_next a)"
  apply (case_tac xs)
   apply clarsimp
  apply clarsimp
  done

primrec
  path :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p \<Rightarrow> 'p list \<Rightarrow> 'p \<Rightarrow> bool"
where
  "path s x [] y = (x = y)"
| "path s x (a#as) y = (x \<noteq> NULL \<and> x = a \<and> (\<exists>v. s x = Some v \<and> path s (list_next v) as y))"

lemma path_null [simp]: "path s NULL as x = (as = [] \<and> x = NULL)"
  by (case_tac as, auto)

lemma path_no_null [simp]: "\<lbrakk> path s a xs b \<rbrakk> \<Longrightarrow> NULL \<notin> set xs"
  apply (induct xs arbitrary: a)
   apply clarsimp
  apply clarsimp
  done

lemma path_next:
  "\<lbrakk> x \<noteq> NULL \<rbrakk> \<Longrightarrow> path s x as y = ((as = [] \<and> x = y)
    \<or> (\<exists>bs. as = x # bs \<and> (\<exists>a. s x = Some a \<and> path s (list_next a) bs y)))"
  apply (case_tac as, auto)
  done

lemma path_null_list: "path s a xs NULL = list s xs a"
  apply (induct xs arbitrary: a, auto)
  done

lemma path_ign [iff]: "u \<notin> set as \<Longrightarrow> path (s(u := v)) x as y = path s x as y"
  by (induct as arbitrary: x y, auto)

lemma path_split [simp]: "path s x (as @ bs) z = (\<exists>y. path s x as y \<and> path s y bs z)"
  apply (induct as arbitrary: x, auto)
  done

lemma list_split [simp]: "list s (as @ bs) x = (\<exists>y. path s x as y \<and> list s bs y)"
  by (induct as arbitrary: x, auto)

end

(*
 * Doubly-linked list, with NULL pointers.
 *)
locale dbl_linked_list =
  linked_list +
  constrains list_next :: "'a \<Rightarrow> 'p" and NULL :: "'p"
  (* Fetch prev pointer from object. *)
  fixes list_prev :: "'a \<Rightarrow> 'p"

context dbl_linked_list begin

primrec
  dbl_list_tail :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p \<Rightarrow> 'p list \<Rightarrow> 'p \<Rightarrow> bool"
where
  "dbl_list_tail s p [] h = (h = NULL)"
| "dbl_list_tail s p (x#xs) h =
    (h = x \<and> x \<noteq> NULL \<and> (\<exists>a. s x = Some a \<and> list_prev a = p \<and> dbl_list_tail s x xs (list_next a)))"

abbreviation
  dbl_list :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p list \<Rightarrow> 'p \<Rightarrow> bool"
where
  "dbl_list s l h \<equiv> dbl_list_tail s NULL l h"

lemma dbl_list_null_empty [simp]: "dbl_list_tail s p [] NULL"
  by simp

lemma dbl_list_empty [simp]: "dbl_list_tail s p xs NULL = (xs = [])"
  by (case_tac xs, auto)

lemma dbl_list_single: "\<lbrakk> s x = Some y; list_prev y = NULL; list_next y = NULL; x \<noteq> NULL \<rbrakk> \<Longrightarrow> dbl_list s [x] x"
  by simp

lemma dbl_list_tail_non_NULL:
  "h \<noteq> NULL \<Longrightarrow>
    dbl_list_tail s p xs h =
      (\<exists>ys. xs= h#ys \<and> (\<exists>a. s h = Some a \<and> list_prev a = p \<and> dbl_list_tail s h ys (list_next a)))"
  apply (case_tac xs, auto)
  done

lemma dbl_list_tail_in_Some:
  "\<lbrakk> dbl_list_tail s p xs h; x \<in> set xs \<rbrakk> \<Longrightarrow> \<exists>a. s x = Some a"
  apply (induct xs arbitrary: p h, auto)
  done

lemma dbl_list_tail_mem: "\<lbrakk> dbl_list_tail s p xs h; h \<noteq> NULL \<rbrakk> \<Longrightarrow> h \<in> set xs"
  by (case_tac xs, auto)

lemma dbl_list_ign [iff]: "\<lbrakk> x \<notin> set xs \<rbrakk> \<Longrightarrow> dbl_list_tail (s(x := v)) p xs h = dbl_list_tail s p xs h"
  apply (induct xs arbitrary: p h)
   apply clarsimp
  apply atomize
  apply clarsimp
  done

lemma dbl_list_ign_ext' [intro, iff]:
    "\<lbrakk> \<forall>x \<in> set xs.
        (\<exists>a. s x = Some a) = (\<exists>a. s' x = Some a)
        \<and> (list_next (the (s x)) = list_next (the (s' x)))
        \<and> (list_prev (the (s x)) = list_prev (the (s' x))) \<rbrakk> \<Longrightarrow>
     dbl_list_tail s p xs h = dbl_list_tail s' p xs h"
  apply (induct xs arbitrary: p h, auto)
  done

lemma dbl_list_ign_ext [iff?]: "\<lbrakk> \<forall>x \<in> set xs. s x = s' x \<rbrakk> \<Longrightarrow> dbl_list_tail s p xs h = dbl_list_tail s' p xs h"
  apply force
  done

lemma dbl_list_unique: "\<lbrakk> dbl_list_tail s p xs h; dbl_list_tail s p' ys h \<rbrakk> \<Longrightarrow> xs = ys"
  apply (induct xs arbitrary: ys p p' h)
   apply simp
  apply (case_tac ys, auto)
  done

lemma dbl_list_append_Ex:
  "dbl_list_tail s p (xs@ys) h \<Longrightarrow> (\<exists>q. dbl_list_tail s (last (p#xs)) ys q)"
  apply (induct xs arbitrary: ys p h)
   apply force
  apply force
  done

lemma dbl_list_head_not_in_list: "\<lbrakk> dbl_list_tail s p xs (list_next a); s h = Some a \<rbrakk> \<Longrightarrow> h \<notin> set xs"
  apply (rule ccontr)
  apply clarsimp
  apply (frule split_list)
  apply clarsimp
  apply (frule dbl_list_append_Ex)
  apply clarsimp
  apply (drule (1) dbl_list_unique)
  apply clarsimp
  done

lemma dbl_list_distinct: "dbl_list_tail s p xs x \<Longrightarrow> distinct xs"
  apply (induct xs arbitrary: x p)
   apply clarsimp
  apply clarsimp
  apply (drule (1) dbl_list_head_not_in_list)
  apply clarsimp
  done

lemma dbl_list_next: "\<lbrakk> dbl_list_tail s p xs x; s x = Some a; x \<noteq> NULL \<rbrakk> \<Longrightarrow> dbl_list_tail s x (tl xs) (list_next a)"
  apply (case_tac xs)
   apply clarsimp
  apply clarsimp
  done

end

(*
 * Circular-linked list, with a head node.
 *)
locale circ_linked_list =
  (* Fetch next pointer from object. *)
  fixes list_next :: "'a \<Rightarrow> 'p"
  (* Fetch previous pointer from object. *)
  fixes list_prev :: "'a \<Rightarrow> 'p"

context circ_linked_list begin

fun
  circ_list_tail :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> 'p list \<Rightarrow> 'p \<Rightarrow> bool"
where
  "circ_list_tail s head prev [] current = (current = head)"
| "circ_list_tail s head prev (x#xs) current =
        (current = x \<and> current \<noteq> head \<and>
          (\<exists>a. s x = Some a \<and> list_prev a = prev
            \<and> circ_list_tail s head x xs (list_next a)))"

lemma circ_list_defn_test: "
  \<lbrakk> s head = Some headNode;
    s n1 = Some node1;
    s n2 = Some node2;
    list_next headNode = n1; list_next node1 = n2; list_next node2 = head;
    list_prev headNode = n2; list_prev node1 = head; list_prev node2 = n1;
    n1 \<noteq> head; n2 \<noteq> head \<rbrakk> \<Longrightarrow>
   circ_list_tail s head head [n1, n2] n1"
  apply clarsimp
  done

definition
  circ_list :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p \<Rightarrow> 'p list \<Rightarrow> bool"
where
  "circ_list s head l \<equiv> (\<exists>a. s head = Some a \<and> (list_prev a = (last (head # l))) \<and> (circ_list_tail s head head l (list_next a)))"

lemma circ_list_tail_empty [simp]: "circ_list_tail s head p xs head = (xs = [])"
  apply (case_tac xs)
   apply clarsimp
  apply clarsimp
  done

lemma circ_list_empty: "\<lbrakk> s head = Some a; list_next a = head; list_prev a = head \<rbrakk> \<Longrightarrow> circ_list s head []"
  apply (clarsimp simp: circ_list_def)
  done

lemma circ_list_single: "\<lbrakk>
    x \<noteq> head;
    s x = Some a; list_next a = head; list_prev a = head;
    s head = Some b; list_next b = x; list_prev b = x
  \<rbrakk> \<Longrightarrow> circ_list s head [x]"
  apply (clarsimp simp: circ_list_def)
  done

lemma circ_list_tail_in_Some:
  "\<lbrakk> circ_list_tail s head p xs h; x \<in> set xs \<rbrakk> \<Longrightarrow> \<exists>a. s x = Some a"
  apply (induct xs arbitrary: p h, auto)
  done

lemma circ_list_tail_ign [iff]: "\<lbrakk> x \<notin> set xs \<rbrakk> \<Longrightarrow> circ_list_tail (s(x := v)) head p xs h = circ_list_tail s head p xs h"
  apply (induct xs arbitrary: p h)
   apply clarsimp
  apply clarsimp
  done

lemma circ_list_ign [iff]: "\<lbrakk> x \<notin> set xs; x \<noteq> head \<rbrakk> \<Longrightarrow> circ_list (s(x := v)) head xs = circ_list s head xs"
  apply (clarsimp simp: circ_list_def)
  done

lemmas circ_list_tail_ign' [iff] = circ_list_tail_ign [unfolded fun_upd_def]
lemmas circ_list_ign' [iff] = circ_list_ign [unfolded fun_upd_def]

lemma circ_list_tail_ign_ext' [intro?, iff?]:
    "\<lbrakk> \<forall>x \<in> set xs.
        (\<exists>a. s x = Some a) = (\<exists>a. s' x = Some a)
        \<and> (list_next (the (s x)) = list_next (the (s' x)))
        \<and> (list_prev (the (s x)) = list_prev (the (s' x))) \<rbrakk> \<Longrightarrow>
     circ_list_tail s head p xs h = circ_list_tail s' head p xs h"
  apply (induct xs arbitrary: p h, auto)
  done

lemma circ_list_ign_ext' [intro?, iff?]:
    "\<lbrakk> \<forall>x \<in> set xs.
        (\<exists>a. s x = Some a) = (\<exists>a. s' x = Some a)
        \<and> (list_next (the (s x)) = list_next (the (s' x)))
        \<and> (list_prev (the (s x)) = list_prev (the (s' x)));
       (\<exists>a. s head = Some a) = (\<exists>a. s' head = Some a);
       (list_next (the (s head)) = list_next (the (s' head)));
       (list_prev (the (s head)) = list_prev (the (s' head))) \<rbrakk> \<Longrightarrow>
     circ_list s head xs = circ_list s' head xs"
  apply (clarsimp simp: circ_list_def)
  apply (case_tac xs)
   apply force
  apply (clarsimp, safe, auto iff: circ_list_tail_ign_ext')
  done

lemma circ_list_tail_ign_ext [iff?]: "\<lbrakk> \<forall>x \<in> set xs. s x = s' x \<rbrakk> \<Longrightarrow> circ_list_tail s head p xs h = circ_list_tail s' head p xs h"
  apply (force iff: circ_list_tail_ign_ext')
  done

lemma circ_list_ign_ext [iff?]: "\<lbrakk> \<forall>x \<in> set xs. s x = s' x; s head = s' head \<rbrakk> \<Longrightarrow> circ_list s head xs = circ_list s' head xs"
  apply (force iff: circ_list_ign_ext')
  done

lemma circ_list_tail_unique: "\<lbrakk> circ_list_tail s head p xs h; circ_list_tail s head p' ys h \<rbrakk> \<Longrightarrow> xs = ys"
  apply (induct xs arbitrary: ys p p' h)
   apply clarsimp
  apply (case_tac ys, auto)
  done

lemma circ_list_unique: "\<lbrakk> circ_list s h xs; circ_list s h ys \<rbrakk> \<Longrightarrow> xs = ys"
  apply (clarsimp simp: circ_list_def)
  apply (erule (1) circ_list_tail_unique)
  done

lemma circ_list_tail_append_Ex:
  "circ_list_tail s head p (xs@ys) h \<Longrightarrow> (\<exists>q. circ_list_tail s head (last (p#xs)) ys q)"
  apply (induct xs arbitrary: ys p h)
   apply force
  apply force
  done

lemma circ_list_tail_head_not_in_list: "\<lbrakk> circ_list_tail s head p xs (list_next a); s h = Some a \<rbrakk> \<Longrightarrow> h \<notin> set xs"
  apply (rule ccontr)
  apply clarsimp
  apply (frule split_list)
  apply clarsimp
  apply (frule circ_list_tail_append_Ex)
  apply clarsimp
  apply (drule (1) circ_list_tail_unique)
  apply clarsimp
  done

lemma circ_list_head_not_in_list: "\<lbrakk> circ_list s head xs \<rbrakk> \<Longrightarrow> head \<notin> set xs"
  apply (clarsimp simp: circ_list_def)
  apply (drule (1) circ_list_tail_head_not_in_list)
  apply simp
  done

lemma circ_list_tail_distinct: "circ_list_tail s head p xs x \<Longrightarrow> distinct xs"
  apply (induct xs arbitrary: x p)
   apply clarsimp
  apply clarsimp
  apply (drule (1) circ_list_tail_head_not_in_list)
  apply clarsimp
  done

lemma circ_list_distinct: "circ_list s head xs \<Longrightarrow> distinct xs"
  by (metis circ_list_def circ_list_tail_distinct)

lemma circ_list_tail_prev':
  "\<lbrakk> circ_list_tail s h p a x; n \<in> set a; s n = Some m; list_prev m \<noteq> p \<rbrakk> \<Longrightarrow> list_prev m \<in> set a"
  apply (induct a arbitrary: p x)
   apply clarsimp
  apply force
  done

lemma circ_list_tail_prev:
  "\<lbrakk> circ_list_tail s h p a x; n \<in> set a; s n = Some m; list_prev m \<notin> set a \<rbrakk> \<Longrightarrow> list_prev m = p"
  apply (induct a arbitrary: p x)
   apply clarsimp
  apply force
  done

lemma circ_list_tail_h_not_in_list:
  "\<lbrakk> circ_list_tail s h p a x \<rbrakk> \<Longrightarrow> h \<notin> set a"
  by (induct a arbitrary: p x, auto)

lemma circ_list_tail_cong:
  "\<lbrakk> \<And>i. \<lbrakk> i \<in> set a; i \<noteq> h \<rbrakk> \<Longrightarrow> s i = s' i; h = h'; p = p'; a = a'; x = x' \<rbrakk>
     \<Longrightarrow> circ_list_tail s h p a x = circ_list_tail s' h' p' a' x'"
  apply clarsimp
  apply (case_tac "h' \<in> set a'")
   apply (metis circ_list_tail_h_not_in_list)
  apply (rule circ_list_tail_ign_ext')
  apply clarsimp
  apply metis
  done

end

end


subsection\<open>Implication-only formulas\<close>

theory MiniFormulas
imports Formulas
begin

fun is_mini_formula where
"is_mini_formula (Atom _) = True" |
"is_mini_formula \<bottom> = True" |
"is_mini_formula (Imp F G) = (is_mini_formula F \<and> is_mini_formula G)" |
"is_mini_formula _ = False"

text\<open>
  The similarity between these ``mini'' formulas and Johansson's minimal calculus of implications~\<^cite>\<open>"johansson1937minimal"\<close> is mostly in name.
  Johansson does replace @{term "\<^bold>\<not> F"} by @{term "F \<^bold>\<rightarrow> \<bottom>"} in one place, but generally keeps it.
  The main focus of ~\<^cite>\<open>"johansson1937minimal"\<close> is on removing rules from Calculi anyway, not on removing connectives.
  We are only borrowing the name.\<close>

(*lemma mini_Top[simp,intro!]: "is_mini_formula \<top>" unfolding Top_def by simp *)

primrec to_mini_formula where
"to_mini_formula (Atom k) = Atom k" |
"to_mini_formula \<bottom> = \<bottom>" |
"to_mini_formula (Imp F G) = to_mini_formula F \<^bold>\<rightarrow> to_mini_formula G" |
"to_mini_formula (Not F) = to_mini_formula F \<^bold>\<rightarrow> \<bottom>" |
"to_mini_formula (And F G) = (to_mini_formula F \<^bold>\<rightarrow> (to_mini_formula G \<^bold>\<rightarrow> \<bottom>)) \<^bold>\<rightarrow> \<bottom>" |
"to_mini_formula (Or F G) = (to_mini_formula F \<^bold>\<rightarrow> \<bottom>) \<^bold>\<rightarrow> to_mini_formula G"

lemma to_mini_is_mini[simp,intro!]: "is_mini_formula (to_mini_formula F)"
  by(induction F; simp)
lemma mini_to_mini: "is_mini_formula F \<Longrightarrow> to_mini_formula F = F"
  by(induction F; simp)
corollary mini_mini[simp]: "to_mini_formula (to_mini_formula F) = to_mini_formula F"
  using mini_to_mini[OF to_mini_is_mini] .

text\<open>We could have used an arbitrary other combination,
  e.g. @{const Atom}, @{const Not}, and @{const And}.
The choice for @{const Atom}, @{term \<bottom>}, and @{const Imp} was made because it is
 (to the best of my knowledge) the only combination that only requires three elements and verifies:\<close>
lemma mini_formula_atoms: "atoms (to_mini_formula F) = atoms F"
 by(induction F; simp)
text\<open>(The story would be different if we had different junctors, e.g. if we allowed a NAND.)\<close>

end


subsection "Splay Tree Analysis"

theory Splay_Tree_Analysis
imports
  Splay_Tree_Analysis_Base
  Amortized_Framework
begin

subsubsection "Analysis of splay"

definition A_splay :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> real" where
"A_splay a t = T_splay a t + \<Phi>(splay a t) - \<Phi> t"

text\<open>The following lemma is an attempt to prove a generic lemma that covers
both zig-zig cases. However, the lemma is not as nice as one would like.
Hence it is used only once, as a demo. Ideally the lemma would involve
function @{const A_splay}, but that is impossible because this involves @{const splay}
and thus depends on the ordering. We would need a truly symmetric version of @{const splay}
that takes the ordering as an explicit argument. Then we could define
all the symmetric cases by one final equation
\<^prop>\<open>splay2 less t = splay2 (\<lambda>x y. Not (less x y)) (mirror t)\<close>.
This would simplify the code and the proofs.\<close>

lemma zig_zig: fixes lx x rx lb b rb a ra u lb1 lb2
defines [simp]: "X == Node lx (x) rx" defines[simp]: "B == Node lb b rb"
defines [simp]: "t == Node B a ra" defines [simp]: "A' == Node rb a ra"
defines [simp]: "t' == Node lb1 u (Node lb2 b A')"
assumes hyps: "lb \<noteq> \<langle>\<rangle>" and IH: "T_splay x lb + \<Phi> lb1 + \<Phi> lb2 - \<Phi> lb \<le> 2 * \<phi> lb - 3 * \<phi> X + 1" and
 prems: "size lb = size lb1 + size lb2 + 1" "X \<in> subtrees lb"
shows "T_splay x lb + \<Phi> t' - \<Phi> t \<le> 3 * (\<phi> t - \<phi> X)"
proof -
  define B' where [simp]: "B' = Node lb2 b A'"
  have "T_splay x lb + \<Phi> t' - \<Phi> t = T_splay x lb + \<Phi> lb1 + \<Phi> lb2 - \<Phi> lb + \<phi> B' + \<phi> A' - \<phi> B"
    using prems
    by(auto simp: A_splay_def size_if_splay algebra_simps in_set_tree_if split: tree.split)
  also have "\<dots> \<le> 2 * \<phi> lb + \<phi> B' + \<phi> A' - \<phi> B - 3 * \<phi> X + 1"
    using IH prems(2) by(auto simp: algebra_simps)
  also have "\<dots> \<le> \<phi> lb + \<phi> B' + \<phi> A' - 3 * \<phi> X + 1" by(simp)
  also have "\<dots> \<le> \<phi> B' + 2 * \<phi> t - 3 * \<phi> X "
    using prems ld_ld_1_less[of "size1 lb" "size1 A'"]
    by(simp add: size_if_splay)
  also have "\<dots> \<le> 3 * \<phi> t - 3 * \<phi> X"
    using prems by(simp add: size_if_splay)
  finally show ?thesis by simp
qed

lemma A_splay_ub: "\<lbrakk> bst t; Node l x r : subtrees t \<rbrakk>
  \<Longrightarrow> A_splay x t \<le> 3 * (\<phi> t - \<phi>(Node l x r)) + 1"
proof(induction x t rule: splay.induct)
  case 1 thus ?case by simp
next
  case 2 thus ?case by (auto simp: A_splay_def)
next
  case 4 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
next
  case 5 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
next
  case 7 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
next
  case 10 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
next
  case 12 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
next
  case 13 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
next
  case (3 x b A B CD)
  (* A readable proof *)
  let ?t = "\<langle>\<langle>A, x, B\<rangle>, b, CD\<rangle>"
  let ?t' = "\<langle>A, x, \<langle>B, b, CD\<rangle>\<rangle>"
  have *: "l = A \<and> r = B" using "3.prems" by(fastforce dest: in_set_tree_if)
  have "A_splay x ?t = 1 + \<Phi> ?t' - \<Phi> ?t" using "3.hyps" by (simp add: A_splay_def)
  also have "\<dots> = 1 + \<phi> ?t' + \<phi> \<langle>B, b, CD\<rangle>  - \<phi> ?t - \<phi> \<langle>A, x, B\<rangle>" by(simp)
  also have "\<dots> = 1 + \<phi> \<langle>B, b, CD\<rangle> - \<phi> \<langle>A, x, B\<rangle>" by(simp)
  also have "\<dots> \<le>  1 + \<phi> ?t - \<phi>(Node A x B)"
    using log_le_cancel_iff[of 2 "size1(Node B b CD)" "size1 ?t"] by (simp)
  also have "\<dots> \<le> 1 + 3 * (\<phi> ?t - \<phi>(Node A x B))"
    using log_le_cancel_iff[of 2 "size1(Node A x B)" "size1 ?t"] by (simp)
  finally show ?case using * by simp
next
  case (9 b x AB C D)
  (* An automatic proof *)
  let ?A = "\<langle>AB, b, \<langle>C, x, D\<rangle>\<rangle>"
  have "x \<notin> set_tree AB" using "9.prems"(1) by auto
  with 9 show ?case using
    log_le_cancel_iff[of 2 "size1(Node AB b C)" "size1 ?A"]
    log_le_cancel_iff[of 2 "size1(Node C x D)" "size1 ?A"]
    by (auto simp: A_splay_def algebra_simps simp del:log_le_cancel_iff)
next
  case (6 x a b A B C)
  hence *: "\<langle>l, x, r\<rangle> \<in> subtrees A" by(fastforce dest: in_set_tree_if)
  obtain A1 a' A2 where sp: "splay x A = Node A1 a' A2"
    using splay_not_Leaf[OF \<open>A \<noteq> Leaf\<close>] by blast
  let ?X = "Node l x r" let ?AB = "Node A a B"  let ?ABC = "Node ?AB b C"
  let ?A' = "Node A1 a' A2"
  let ?BC = "Node B b C"  let ?A2BC = "Node A2 a ?BC" let ?A1A2BC = "Node A1 a' ?A2BC"
  have 0: "\<phi> ?A1A2BC = \<phi> ?ABC" using sp by(simp add: size_if_splay)
  have 1: "\<Phi> ?A1A2BC - \<Phi> ?ABC = \<Phi> A1 + \<Phi> A2 + \<phi> ?A2BC + \<phi> ?BC - \<Phi> A - \<phi> ?AB"
    using 0 by (simp)
  have "A_splay x ?ABC = T_splay x A + 1 + \<Phi> ?A1A2BC - \<Phi> ?ABC"
    using "6.hyps" sp by(simp add: A_splay_def)
  also have "\<dots> = T_splay x A + 1 + \<Phi> A1 + \<Phi> A2 + \<phi> ?A2BC + \<phi> ?BC - \<Phi> A - \<phi> ?AB"
    using 1 by simp
  also have "\<dots> = T_splay x A + \<Phi> ?A' - \<phi> ?A' - \<Phi> A + \<phi> ?A2BC + \<phi> ?BC - \<phi> ?AB + 1"
    by(simp)
  also have "\<dots> = A_splay x A + \<phi> ?A2BC + \<phi> ?BC - \<phi> ?AB - \<phi> ?A' + 1"
    using sp by(simp add: A_splay_def)
  also have "\<dots> \<le> 3 * \<phi> A + \<phi> ?A2BC + \<phi> ?BC - \<phi> ?AB - \<phi> ?A' - 3 * \<phi> ?X + 2"
    using "6.IH" "6.prems"(1) * by(simp)
  also have "\<dots> = 2 * \<phi> A + \<phi> ?A2BC + \<phi> ?BC - \<phi> ?AB - 3 * \<phi> ?X + 2"
    using sp by(simp add: size_if_splay)
  also have "\<dots> < \<phi> A + \<phi> ?A2BC + \<phi> ?BC - 3 * \<phi> ?X + 2" by(simp)
  also have "\<dots> < \<phi> ?A2BC + 2 * \<phi> ?ABC - 3 * \<phi> ?X + 1"
    using sp ld_ld_1_less[of "size1 A" "size1 ?BC"]
    by(simp add: size_if_splay)
  also have "\<dots> < 3 * \<phi> ?ABC - 3 * \<phi> ?X + 1"
    using sp by(simp add: size_if_splay)
  finally show ?case by simp
next
  case (8 a x b B A C)
  hence *: "\<langle>l, x, r\<rangle> \<in> subtrees B" by(fastforce dest: in_set_tree_if)
  obtain B1 b' B2 where sp: "splay x B = Node B1 b' B2"
     using splay_not_Leaf[OF \<open>B \<noteq> Leaf\<close>] by blast
  let ?X = "Node l x r" let ?AB = "Node A a B"  let ?ABC = "Node ?AB b C"
  let ?B' = "Node B1 b' B2"
  let ?AB1 = "Node A a B1"  let ?B2C = "Node B2 b C" let ?AB1B2C = "Node ?AB1 b' ?B2C"
  have 0: "\<phi> ?AB1B2C = \<phi> ?ABC" using sp by(simp add: size_if_splay)
  have 1: "\<Phi> ?AB1B2C - \<Phi> ?ABC = \<Phi> B1 + \<Phi> B2 + \<phi> ?AB1 + \<phi> ?B2C - \<Phi> B - \<phi> ?AB"
    using 0 by (simp)
  have "A_splay x ?ABC = T_splay x B + 1 + \<Phi> ?AB1B2C - \<Phi> ?ABC"
    using "8.hyps" sp by(simp add: A_splay_def)
  also have "\<dots> = T_splay x B + 1 + \<Phi> B1 + \<Phi> B2 + \<phi> ?AB1 + \<phi> ?B2C - \<Phi> B - \<phi> ?AB"
    using 1 by simp
  also have "\<dots> = T_splay x B + \<Phi> ?B' - \<phi> ?B' - \<Phi> B + \<phi> ?AB1 + \<phi> ?B2C - \<phi> ?AB + 1"
    by simp
  also have "\<dots> = A_splay x B + \<phi> ?AB1 + \<phi> ?B2C - \<phi> ?AB - \<phi> ?B' + 1"
    using sp by (simp add: A_splay_def)
  also have "\<dots> \<le> 3 * \<phi> B + \<phi> ?AB1 + \<phi> ?B2C - \<phi> ?AB - \<phi> ?B' - 3 * \<phi> ?X + 2"
    using "8.IH" "8.prems"(1) * by(simp)
  also have "\<dots> = 2 * \<phi> B + \<phi> ?AB1 + \<phi> ?B2C - \<phi> ?AB - 3 * \<phi> ?X + 2"
    using sp by(simp add: size_if_splay)
  also have "\<dots> < \<phi> B + \<phi> ?AB1 + \<phi> ?B2C - 3 * \<phi> ?X + 2" by(simp)
  also have "\<dots> < \<phi> B + 2 * \<phi> ?ABC - 3 * \<phi> ?X + 1"
    using sp ld_ld_1_less[of "size1 ?AB1" "size1 ?B2C"]
    by(simp add: size_if_splay)
  also have "\<dots> < 3 * \<phi> ?ABC - 3 * \<phi> ?X + 1" by(simp)
  finally show ?case by simp
next
  case (11 b x c C A D)
  hence *: "\<langle>l, x, r\<rangle> \<in> subtrees C" by(fastforce dest: in_set_tree_if)
  obtain C1 c' C2 where sp: "splay x C = Node C1 c' C2"
    using splay_not_Leaf[OF \<open>C \<noteq> Leaf\<close>] by blast
  let ?X = "Node l x r" let ?CD = "Node C c D"  let ?ACD = "Node A b ?CD"
  let ?C' = "Node C1 c' C2"
  let ?C2D = "Node C2 c D"  let ?AC1 = "Node A b C1"
  have "A_splay x ?ACD = A_splay x C + \<phi> ?C2D + \<phi> ?AC1 - \<phi> ?CD - \<phi> ?C' + 1"
    using "11.hyps" sp
    by(auto simp: A_splay_def size_if_splay algebra_simps split: tree.split)
  also have "\<dots> \<le> 3 * \<phi> C + \<phi> ?C2D + \<phi> ?AC1 - \<phi> ?CD - \<phi> ?C' - 3 * \<phi> ?X + 2"
    using "11.IH" "11.prems"(1) * by(auto simp: algebra_simps)
  also have "\<dots> = 2 * \<phi> C + \<phi> ?C2D + \<phi> ?AC1 - \<phi> ?CD - 3 * \<phi> ?X + 2"
    using sp by(simp add: size_if_splay)
  also have "\<dots> \<le> \<phi> C + \<phi> ?C2D + \<phi> ?AC1 - 3 * \<phi> ?X + 2" by(simp)
  also have "\<dots> \<le> \<phi> C + 2 * \<phi> ?ACD - 3 * \<phi> ?X + 1"
    using sp ld_ld_1_less[of "size1 ?C2D" "size1 ?AC1"]
    by(simp add: size_if_splay algebra_simps)
  also have "\<dots> \<le> 3 * \<phi> ?ACD - 3 * \<phi> ?X + 1" by(simp)
  finally show ?case by simp
next
  case (14 a x b CD A B)
  hence 0: "x \<notin> set_tree B \<and> x \<notin> set_tree A"
    using "14.prems"(1) \<open>b<x\<close> by(auto)
  hence 1: "x \<in> set_tree CD" using "14.prems" \<open>b<x\<close> \<open>a<x\<close> by (auto)
  obtain C c D where sp: "splay x CD = Node C c D"
    using splay_not_Leaf[OF \<open>CD \<noteq> Leaf\<close>] by blast
  from zig_zig[of CD x D C l r _ b B a A] 14 sp 0
  show ?case by(auto simp: A_splay_def size_if_splay algebra_simps)
(* The explicit version:
  have "A_splay x ?A = A_splay x ?R + \<phi> ?B' + \<phi> ?A' - \<phi> ?B - \<phi> ?R' + 1"
    using "14.prems" 1 sp
    by(auto simp: A_splay_def size_if_splay algebra_simps split: tree.split)
  also have "\<dots> \<le> 3 * \<phi> ?R + \<phi> ?B' + \<phi> ?A' - \<phi> ?B - \<phi> ?R' - 3 * \<phi> ?X + 2"
    using 14 0 by(auto simp: algebra_simps)
  also have "\<dots> = 2 * \<phi> rb + \<phi> ?B' + \<phi> ?A' - \<phi> ?B - 3 * \<phi> ?X + 2"
    using sp by(simp add: size_if_splay)
  also have "\<dots> \<le> \<phi> ?R + \<phi> ?B' + \<phi> ?A' - 3 * \<phi> ?X + 2" by(simp)
  also have "\<dots> \<le> \<phi> ?B' + 2 * \<phi> ?A - 3 * \<phi> ?X + 1"
    using sp ld_ld_1_less[of "size1 ?R" "size1 ?A'"]
    by(simp add: size_if_splay algebra_simps)
  also have "\<dots> \<le> 3 * \<phi> ?A - 3 * \<phi> ?X + 1"
    using sp by(simp add: size_if_splay)
  finally show ?case by simp
*)
qed

lemma A_splay_ub2: assumes "bst t" "x : set_tree t"
shows "A_splay x t \<le> 3 * (\<phi> t - 1) + 1"
proof -
  from assms(2) obtain l r where N: "Node l x r : subtrees t"
    by (metis set_treeE)
  have "A_splay x t \<le> 3 * (\<phi> t - \<phi>(Node l x r)) + 1" by(rule A_splay_ub[OF assms(1) N])
  also have "\<dots> \<le> 3 * (\<phi> t - 1) + 1" by(simp add: field_simps)
  finally show ?thesis .
qed

lemma A_splay_ub3: assumes "bst t" shows "A_splay x t \<le> 3 * \<phi> t + 1"
proof cases
  assume "t = Leaf" thus ?thesis by(simp add: A_splay_def)
next
  assume "t \<noteq> Leaf"
  from ex_in_set_tree[OF this assms] obtain x' where
    a': "x' \<in> set_tree t"  "splay x' t = splay x t"  "T_splay x' t = T_splay x t"
    by blast
  show ?thesis using A_splay_ub2[OF assms a'(1)] by(simp add: A_splay_def a')
qed

subsubsection "Analysis of insert"

lemma amor_insert: assumes "bst t"
shows "T_insert x t + \<Phi>(Splay_Tree.insert x t) - \<Phi> t \<le> 4 * log 2 (size1 t) + 3" (is "?l \<le> ?r")
proof cases
  assume "t = Leaf" thus ?thesis by(simp add: T_insert_def)
next
  assume "t \<noteq> Leaf"
  then obtain l e r where [simp]: "splay x t = Node l e r"
    by (metis tree.exhaust splay_Leaf_iff)
  let ?t = "real(T_splay x t)"
  let ?Plr = "\<Phi> l + \<Phi> r"  let ?Ps = "\<Phi> t"
  let ?slr = "real(size1 l) + real(size1 r)" let ?LR = "log 2 (1 + ?slr)"
  have opt: "?t + \<Phi> (splay x t) - ?Ps  \<le> 3 * log 2 (real (size1 t)) + 1"
    using A_splay_ub3[OF \<open>bst t\<close>, simplified A_splay_def, of x] by (simp)
  from less_linear[of e x]
  show ?thesis
  proof (elim disjE)
    assume "e=x"
    have nneg: "log 2 (1 + real (size t)) \<ge> 0" by simp
    thus ?thesis using \<open>t \<noteq> Leaf\<close> opt \<open>e=x\<close>
      apply(simp add: T_insert_def algebra_simps) using nneg by arith
  next
    let ?L = "log 2 (real(size1 l) + 1)"
    assume "e < x" hence "e \<noteq> x" by simp
    hence "?l = (?t + ?Plr - ?Ps) + ?L + ?LR + 1"
      using  \<open>t \<noteq> Leaf\<close> \<open>e<x\<close> by(simp add: T_insert_def)
    also have "?t + ?Plr - ?Ps \<le> 2 * log 2 ?slr + 1"
      using opt size_splay[of x t,symmetric] by(simp)
    also have "?L \<le> log 2 ?slr" by(simp)
    also have "?LR \<le> log 2 ?slr + 1"
    proof -
      have "?LR \<le> log 2 (2 * ?slr)" by (simp add:)
      also have "\<dots> \<le> log 2 ?slr + 1"
        by (simp add: log_mult del:distrib_left_numeral)
      finally show ?thesis .
    qed
    finally show ?thesis using size_splay[of x t,symmetric] by (simp)
  next
    let ?R = "log 2 (2 + real(size r))"
    assume "x < e" hence "e \<noteq> x" by simp
    hence "?l = (?t + ?Plr - ?Ps) + ?R + ?LR + 1"
      using \<open>t \<noteq> Leaf\<close> \<open>x < e\<close> by(simp add: T_insert_def)
    also have "?t + ?Plr - ?Ps \<le> 2 * log 2 ?slr + 1"
      using opt size_splay[of x t,symmetric] by(simp)
    also have "?R \<le> log 2 ?slr" by(simp)
    also have "?LR \<le> log 2 ?slr + 1"
    proof -
      have "?LR \<le> log 2 (2 * ?slr)" by (simp add:)
      also have "\<dots> \<le> log 2 ?slr + 1"
        by (simp add: log_mult del:distrib_left_numeral)
      finally show ?thesis .
    qed
    finally show ?thesis using size_splay[of x t, symmetric] by simp
  qed
qed

subsubsection "Analysis of delete"

definition A_splay_max :: "'a::linorder tree \<Rightarrow> real" where
"A_splay_max t = T_splay_max t + \<Phi>(splay_max t) - \<Phi> t"

lemma A_splay_max_ub: "t \<noteq> Leaf \<Longrightarrow> A_splay_max t \<le> 3 * (\<phi> t - 1) + 1"
proof(induction t rule: splay_max.induct)
  case 1 thus ?case by (simp)
next
  case (2 A)
  thus ?case using one_le_log_cancel_iff[of 2 "size1 A + 1"]
    by (simp add: A_splay_max_def del: one_le_log_cancel_iff)
next
  case (3 l b rl c rr)
  show ?case
  proof cases
    assume "rr = Leaf"
    thus ?thesis
      using one_le_log_cancel_iff[of 2 "1 + size1 rl"]
        one_le_log_cancel_iff[of 2 "1 + size1 l + size1 rl"]
        log_le_cancel_iff[of 2 "size1 l + size1 rl" "1 + size1 l + size1 rl"]
     by (auto simp: A_splay_max_def field_simps
           simp del: log_le_cancel_iff one_le_log_cancel_iff)
  next
    assume "rr \<noteq> Leaf"
    then obtain l' u r' where sp: "splay_max rr = Node l' u r'"
      using splay_max_Leaf_iff tree.exhaust by blast
    hence 1: "size rr = size l' + size r' + 1"
      using size_splay_max[of rr,symmetric] by(simp)
    let ?C = "Node rl c rr"  let ?B = "Node l b ?C"
    let ?B' = "Node l b rl"  let ?C' = "Node ?B' c l'"
    have "A_splay_max ?B = A_splay_max rr + \<phi> ?B' + \<phi> ?C' - \<phi> rr - \<phi> ?C + 1" using "3.prems" sp 1
      by(auto simp add: A_splay_max_def)
    also have "\<dots> \<le> 3 * (\<phi> rr - 1) + \<phi> ?B' + \<phi> ?C' - \<phi> rr - \<phi> ?C + 2"
      using 3 \<open>rr \<noteq> Leaf\<close> by auto
    also have "\<dots> = 2 * \<phi> rr + \<phi> ?B' + \<phi> ?C' - \<phi> ?C - 1" by simp
    also have "\<dots> \<le> \<phi> rr + \<phi> ?B' + \<phi> ?C' - 1" by simp
    also have "\<dots> \<le> 2 * \<phi> ?B + \<phi> ?C' - 2"
      using ld_ld_1_less[of "size1 ?B'" "size1 rr"] by(simp add:)
    also have "\<dots> \<le> 3 * \<phi> ?B - 2" using 1 by simp
    finally show ?case by simp
  qed
qed

lemma A_splay_max_ub3: "A_splay_max t \<le> 3 * \<phi> t + 1"
proof cases
  assume "t = Leaf" thus ?thesis by(simp add: A_splay_max_def)
next
  assume "t \<noteq> Leaf"
  show ?thesis using A_splay_max_ub[OF \<open>t \<noteq> Leaf\<close>] by(simp)
qed

lemma amor_delete: assumes "bst t"
shows "T_delete a t + \<Phi>(Splay_Tree.delete a t) - \<Phi> t \<le> 6 * log 2 (size1 t) + 3"
proof (cases t)
  case Leaf thus ?thesis by(simp add: Splay_Tree.delete_def T_delete_def)
next
  case [simp]: (Node ls x rs)
  then obtain l e r where sp[simp]: "splay a (Node ls x rs) = Node l e r"
    by (metis tree.exhaust splay_Leaf_iff)
  let ?t = "real(T_splay a t)"
  let ?Plr = "\<Phi> l + \<Phi> r"  let ?Ps = "\<Phi> t"
  let ?slr = "real(size1 l) + real(size1 r)" let ?LR = "log 2 (1 + ?slr)"
  let ?lslr = "log 2 (real (size ls) + (real (size rs) + 2))"
  have "?lslr \<ge> 0" by simp
  have opt: "?t + \<Phi> (splay a t) - ?Ps  \<le> 3 * log 2 (real (size1 t)) + 1"
    using A_splay_ub3[OF \<open>bst t\<close>, simplified A_splay_def, of a]
    by (simp add: field_simps)
  show ?thesis
  proof (cases "e=a")
    case False thus ?thesis
      using opt apply(simp add: Splay_Tree.delete_def T_delete_def field_simps)
      using \<open>?lslr \<ge> 0\<close> by arith
  next
    case [simp]: True
    show ?thesis
    proof (cases l)
      case Leaf
      have 1: "log 2 (real (size r) + 2) \<ge> 0" by(simp)
      show ?thesis
        using Leaf opt apply(simp add: Splay_Tree.delete_def T_delete_def field_simps)
        using 1 \<open>?lslr \<ge> 0\<close> by arith
    next
      case (Node ll y lr)
      then obtain l' y' r' where [simp]: "splay_max (Node ll y lr) = Node l' y' r'"
      using splay_max_Leaf_iff tree.exhaust by blast
      have "bst l" using bst_splay[OF \<open>bst t\<close>, of a] by simp
      have "\<Phi> r' \<ge> 0" apply (induction r') by (auto)
      have optm: "real(T_splay_max l) + \<Phi> (splay_max l) - \<Phi> l  \<le> 3 * \<phi> l + 1"
        using A_splay_max_ub3[of l, simplified A_splay_max_def] by (simp add: field_simps Node)
      have 1: "log 2 (2+(real(size l')+real(size r))) \<le> log 2 (2+(real(size l)+real(size r)))"
        using size_splay_max[of l] Node by simp
      have 2: "log 2 (2 + (real (size l') + real (size r'))) \<ge> 0" by simp
      have 3: "log 2 (size1 l' + size1 r) \<le> log 2 (size1 l' + size1 r') + log 2 ?slr"
        apply simp using 1 2 by arith
      have 4: "log 2 (real(size ll) + (real(size lr) + 2)) \<le> ?lslr"
        using size_if_splay[OF sp] Node by simp
      show ?thesis using add_mono[OF opt optm] Node 3
        apply(simp add: Splay_Tree.delete_def T_delete_def field_simps)
        using 4 \<open>\<Phi> r' \<ge> 0\<close> by arith
    qed
  qed
qed

subsubsection "Overall analysis"

fun U where
"U Empty [] = 1" |
"U (Splay _) [t] = 3 * log 2 (size1 t) + 1" |
"U (Insert _) [t] = 4 * log 2 (size1 t) + 3" |
"U (Delete _) [t] = 6 * log 2 (size1 t) + 3"

interpretation Amortized
where arity = arity and exec = exec and inv = bst
and cost = cost and \<Phi> = \<Phi> and U = U
proof (standard, goal_cases)
  case (1 ss f) show ?case
  proof (cases f)
    case Empty thus ?thesis using 1 by auto
  next
    case (Splay a)
    then obtain t where "ss = [t]" "bst t" using 1 by auto
    with Splay bst_splay[OF \<open>bst t\<close>, of a] show ?thesis
      by (auto split: tree.split)
  next
    case (Insert a)
    then obtain t where "ss = [t]" "bst t" using 1 by auto
    with bst_splay[OF \<open>bst t\<close>, of a] Insert show ?thesis
      by (auto simp: splay_bstL[OF \<open>bst t\<close>] splay_bstR[OF \<open>bst t\<close>] split: tree.split)
  next
    case (Delete a)
    then obtain t where "ss = [t]" "bst t" using 1 by auto
    with 1 Delete show ?thesis by(simp add: bst_delete)
  qed
next
  case (2 t) thus ?case by (induction t) auto
next
  case (3 ss f)
  show ?case (is "?l \<le> ?r")
  proof(cases f)
    case Empty thus ?thesis using 3(2) by(simp add: A_splay_def)
  next
    case (Splay a)
    then obtain t where "ss = [t]" "bst t" using 3 by auto
    thus ?thesis using Splay A_splay_ub3[OF \<open>bst t\<close>] by(simp add: A_splay_def)
  next
    case [simp]: (Insert a)
    then obtain t where [simp]: "ss = [t]" and "bst t" using 3 by auto
    thus ?thesis using amor_insert[of t a] by auto
  next
    case [simp]: (Delete a)
    then obtain t where [simp]: "ss = [t]" and "bst t" using 3 by auto
    thus ?thesis using amor_delete[of t a] by auto
  qed
qed

end


section \<open>Core Lens Laws\<close>

theory Lens_Laws
imports
  Two Interp
begin

subsection \<open>Lens Signature\<close>

text \<open>This theory introduces the signature of lenses and indentifies the core algebraic hierarchy of lens
  classes, including laws for well-behaved, very well-behaved, and bijective lenses~\<^cite>\<open>"Foster07" and "Fischer2015" and "Gibbons17"\<close>.\<close>

record ('a, 'b) lens =
  lens_get :: "'b \<Rightarrow> 'a" ("get\<index>")
  lens_put :: "'b \<Rightarrow> 'a \<Rightarrow> 'b" ("put\<index>")

type_notation
  lens (infixr "\<Longrightarrow>" 0)

text \<open> Alternative parameters ordering, inspired by Back and von Wright's refinement
  calculus~\<^cite>\<open>"Back1998"\<close>, which similarly uses two functions to characterise updates to variables. \<close>

abbreviation (input) lens_set :: "('a \<Longrightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b" ("lset\<index>") where
"lens_set \<equiv> (\<lambda> X v s. put\<^bsub>X\<^esub> s v)"

text \<open>
  \begin{figure}
  \begin{center}
    \includegraphics[width=6cm]{figures/Lens}
  \end{center}
  \vspace{-5ex}
  \caption{Visualisation of a simple lens}
  \label{fig:Lens}
  \end{figure}

  A lens $X : \view \lto \src$, for source type $\src$ and view type $\view$, identifies
  $\view$ with a subregion of $\src$~\<^cite>\<open>"Foster07" and "Foster09"\<close>, as illustrated in Figure~\ref{fig:Lens}. The arrow denotes
  $X$ and the hatched area denotes the subregion $\view$ it characterises. Transformations on
  $\view$ can be performed without affecting the parts of $\src$ outside the hatched area. The lens
  signature consists of a pair of functions $\lget_X : \src \Rightarrow \view$ that extracts a view
  from a source, and $\lput_X : \src \Rightarrow \view \Rightarrow \src$ that updates a view within
  a given source. \<close>

named_theorems lens_defs

text \<open> @{text lens_source} gives the set of constructible sources; that is those that can be built
  by putting a value into an arbitrary source. \<close>

definition lens_source :: "('a \<Longrightarrow> 'b) \<Rightarrow> 'b set" ("\<S>\<index>") where
"lens_source X = {s. \<exists> v s'. s = put\<^bsub>X\<^esub> s' v}"

text \<open> A partial version of @{const lens_get}, which can be useful for partial lenses. \<close>

definition lens_partial_get :: "('a \<Longrightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a option" ("pget\<index>") where
"lens_partial_get x s = (if s \<in> \<S>\<^bsub>x\<^esub> then Some (get\<^bsub>x\<^esub> s) else None)"

abbreviation some_source :: "('a \<Longrightarrow> 'b) \<Rightarrow> 'b" ("src\<index>") where
"some_source X \<equiv> (SOME s. s \<in> \<S>\<^bsub>X\<^esub>)"

definition lens_create :: "('a \<Longrightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" ("create\<index>") where
[lens_defs]: "create\<^bsub>X\<^esub> v = put\<^bsub>X\<^esub> (src\<^bsub>X\<^esub>) v"

text \<open> Function $\lcreate_X~v$ creates an instance of the source type of $X$ by injecting $v$
  as the view, and leaving the remaining context arbitrary. \<close>

definition lens_update :: "('a \<Longrightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'b)" ("update\<index>") where
[lens_defs]: "lens_update X f \<sigma> = put\<^bsub>X\<^esub> \<sigma> (f (get\<^bsub>X\<^esub> \<sigma>))"

text \<open> The update function is analogous to the record update function which lifts a function
  on a view type to one on the source type. \<close>

definition lens_obs_eq :: "('b \<Longrightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<simeq>\<index>" 50) where
[lens_defs]: "s\<^sub>1 \<simeq>\<^bsub>X\<^esub> s\<^sub>2 = (s\<^sub>1 = put\<^bsub>X\<^esub> s\<^sub>2 (get\<^bsub>X\<^esub> s\<^sub>1))"

text \<open> This relation states that two sources are equivalent outside of the region characterised
  by lens $X$. \<close>

definition lens_override :: "('b \<Longrightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<triangleleft>\<index>" 95) where
[lens_defs]: "S\<^sub>1 \<triangleleft>\<^bsub>X\<^esub> S\<^sub>2 = put\<^bsub>X\<^esub> S\<^sub>1 (get\<^bsub>X\<^esub> S\<^sub>2)"

abbreviation (input) lens_override' :: "'a \<Rightarrow> 'a \<Rightarrow> ('b \<Longrightarrow> 'a) \<Rightarrow> 'a" ("_ \<oplus>\<^sub>L _ on _" [95,0,96] 95) where
"S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on X \<equiv> S\<^sub>1 \<triangleleft>\<^bsub>X\<^esub> S\<^sub>2"

text \<open>Lens override uses a lens to replace part of a source type with a given value for the
  corresponding view.\<close>

subsection \<open>Weak Lenses\<close>

text \<open> Weak lenses are the least constrained class of lenses in our algebraic hierarchy. They
  simply require that the PutGet law~\<^cite>\<open>"Foster09" and "Fischer2015"\<close> is satisfied, meaning that
  $\lget$ is the inverse of $\lput$. \<close>

locale weak_lens =
  fixes x :: "'a \<Longrightarrow> 'b" (structure)
  assumes put_get: "get (put \<sigma> v) = v"
begin
  lemma source_nonempty: "\<exists> s. s \<in> \<S>"
    by (auto simp add: lens_source_def)

  lemma put_closure: "put \<sigma> v \<in> \<S>"
    by (auto simp add: lens_source_def)

  lemma create_closure: "create v \<in> \<S>"
    by (simp add: lens_create_def put_closure)

  lemma src_source [simp]: "src \<in> \<S>"
    using some_in_eq source_nonempty by auto

  lemma create_get: "get (create v) = v"
    by (simp add: lens_create_def put_get)

  lemma create_inj: "inj create"
    by (metis create_get injI)

  lemma get_update: "get (update f \<sigma>) = f (get \<sigma>)"
    by (simp add: put_get lens_update_def)

  lemma view_determination:
    assumes "put \<sigma> u = put \<rho> v"
    shows "u = v"
    by (metis assms put_get)

  lemma put_inj: "inj (put \<sigma>)"
    by (simp add: injI view_determination)

end

declare weak_lens.put_get [simp]
declare weak_lens.create_get [simp]

lemma dom_pget: "dom pget\<^bsub>x\<^esub> = \<S>\<^bsub>x\<^esub>"
  by (simp add: lens_partial_get_def dom_def)

subsection \<open>Well-behaved Lenses\<close>

text \<open> Well-behaved lenses add to weak lenses that requirement that the GetPut law~\<^cite>\<open>"Foster09" and "Fischer2015"\<close>
  is satisfied, meaning that $\lput$ is the inverse of $\lget$. \<close>

locale wb_lens = weak_lens +
  assumes get_put: "put \<sigma> (get \<sigma>) = \<sigma>"
begin

  lemma put_twice: "put (put \<sigma> v) v = put \<sigma> v"
    by (metis get_put put_get)

  lemma put_surjectivity: "\<exists> \<rho> v. put \<rho> v = \<sigma>"
    using get_put by blast

  lemma source_stability: "\<exists> v. put \<sigma> v = \<sigma>"
    using get_put by auto

  lemma source_UNIV [simp]: "\<S> = UNIV"
    by (metis UNIV_eq_I put_closure wb_lens.source_stability wb_lens_axioms)

end

declare wb_lens.get_put [simp]

lemma wb_lens_weak [simp]: "wb_lens x \<Longrightarrow> weak_lens x"
  by (simp add: wb_lens_def)

subsection \<open> Mainly Well-behaved Lenses \<close>

text \<open> Mainly well-behaved lenses extend weak lenses with the PutPut law that shows how one put
  override a previous one. \<close>

locale mwb_lens = weak_lens +
  assumes put_put: "put (put \<sigma> v) u = put \<sigma> u"
begin

  text \<open> Mainly well-behaved lenses give rise to a weakened version of the $get-put$ law,
    where the source must be within the set of constructible sources. \<close>

  lemma weak_get_put: "\<sigma> \<in> \<S> \<Longrightarrow> put \<sigma> (get \<sigma>) = \<sigma>"
    by (auto simp add: lens_source_def put_get put_put)

  lemma weak_source_determination:
    assumes "\<sigma> \<in> \<S>" "\<rho> \<in> \<S>" "get \<sigma> = get \<rho>" "put \<sigma> v = put \<rho> v"
    shows "\<sigma> = \<rho>"
    by (metis assms put_put weak_get_put)

   lemma weak_put_eq:
     assumes "\<sigma> \<in> \<S>" "get \<sigma> = k" "put \<sigma> u = put \<rho> v"
     shows "put \<rho> k = \<sigma>"
     by (metis assms put_put weak_get_put)

  text \<open> Provides $s$ is constructible, then @{term get} can be uniquely determined from @{term put} \<close>

  lemma weak_get_via_put: "s \<in> \<S> \<Longrightarrow> get s = (THE v. put s v = s)"
    by (rule sym, auto intro!: the_equality weak_get_put, metis put_get)

end

abbreviation (input) "partial_lens \<equiv> mwb_lens"

declare mwb_lens.put_put [simp]
declare mwb_lens.weak_get_put [simp]

lemma mwb_lens_weak [simp]:
  "mwb_lens x \<Longrightarrow> weak_lens x"
  by (simp add: mwb_lens.axioms(1))

subsection \<open>Very Well-behaved Lenses\<close>

text \<open>Very well-behaved lenses combine all three laws, as in the literature~\<^cite>\<open>"Foster09" and "Fischer2015"\<close>.
  The same set of axioms can be found in Back and von Wright's refinement calculus~\<^cite>\<open>"Back1998"\<close>,
  though with different names for the functions. \<close>

locale vwb_lens = wb_lens + mwb_lens
begin

  lemma source_determination:
    assumes "get \<sigma> = get \<rho>" "put \<sigma> v = put \<rho> v"
    shows "\<sigma> = \<rho>"
    by (metis assms get_put put_put)

 lemma put_eq:
   assumes "get \<sigma> = k" "put \<sigma> u = put \<rho> v"
   shows "put \<rho> k = \<sigma>"
   using assms weak_put_eq[of \<sigma> k u \<rho> v] by (simp)

  text \<open> @{term get} can be uniquely determined from @{term put} \<close>

  lemma get_via_put: "get s = (THE v. put s v = s)"
    by (simp add: weak_get_via_put)

  lemma get_surj: "surj get"
    by (metis put_get surjI)

  text \<open> Observation equivalence is an equivalence relation. \<close>

  lemma lens_obs_equiv: "equivp (\<simeq>)"
  proof (rule equivpI)
    show "reflp (\<simeq>)"
      by (rule reflpI, simp add: lens_obs_eq_def get_put)
    show "symp (\<simeq>)"
      by (rule sympI, simp add: lens_obs_eq_def, metis get_put put_put)
    show "transp (\<simeq>)"
      by (rule transpI, simp add: lens_obs_eq_def, metis put_put)
  qed

end

abbreviation (input) "total_lens \<equiv> vwb_lens"

lemma vwb_lens_wb [simp]: "vwb_lens x \<Longrightarrow> wb_lens x"
  by (simp add: vwb_lens_def)

lemma vwb_lens_mwb [simp]: "vwb_lens x \<Longrightarrow> mwb_lens x"
  using vwb_lens_def by auto

lemma mwb_UNIV_src_is_vwb_lens:
  "\<lbrakk> mwb_lens X; \<S>\<^bsub>X\<^esub> = UNIV \<rbrakk> \<Longrightarrow> vwb_lens X"
  using vwb_lens_def wb_lens_axioms_def wb_lens_def by fastforce

text \<open> Alternative characterisation: a very well-behaved (i.e. total) lens is a mainly well-behaved
  (i.e. partial) lens whose source is the universe set. \<close>

lemma vwb_lens_iff_mwb_UNIV_src:
  "vwb_lens X \<longleftrightarrow> (mwb_lens X \<and> \<S>\<^bsub>X\<^esub> = UNIV)"
  by (meson mwb_UNIV_src_is_vwb_lens vwb_lens_def wb_lens.source_UNIV)

subsection \<open> Ineffectual Lenses \<close>

text \<open>Ineffectual lenses can have no effect on the view type -- application of the $\lput$ function
  always yields the same source. They are thus, trivially, very well-behaved lenses.\<close>

locale ief_lens = weak_lens +
  assumes put_inef: "put \<sigma> v = \<sigma>"
begin

lemma ief_then_vwb: "vwb_lens x"
proof
  fix \<sigma> v u
  show "put \<sigma> (get \<sigma>) = \<sigma>"
    by (simp add: put_inef)
  show "put (put \<sigma> v) u = put \<sigma> u"
    by (simp add: put_inef)
qed

sublocale vwb_lens by (fact ief_then_vwb)

lemma ineffectual_const_get:
  "\<exists> v.  \<forall> \<sigma>\<in>\<S>. get \<sigma> = v"
  using put_get put_inef by auto

end

declare ief_lens.ief_then_vwb [simp]

text \<open> There is no ineffectual lens when the view type has two or more elements. \<close>

lemma no_ief_two_view:
  assumes "ief_lens (x :: 'a::two \<Longrightarrow> 's)"
  shows "False"
proof -
  obtain x y :: "'a::two" where "x \<noteq> y"
    using two_diff by auto
  with assms show ?thesis
    by (metis (full_types) ief_lens.axioms(1) ief_lens.put_inef weak_lens.put_get)
qed

abbreviation "eff_lens X \<equiv> (weak_lens X \<and> (\<not> ief_lens X))"

subsection \<open> Partially Bijective Lenses \<close>

locale pbij_lens = weak_lens +
  assumes put_det: "put \<sigma> v = put \<rho> v"
begin

  sublocale mwb_lens
  proof
    fix \<sigma> v u
    show "put (put \<sigma> v) u = put \<sigma> u"
      using put_det by blast
  qed

  lemma partial_get_put: "\<rho> \<in> \<S> \<Longrightarrow> put \<sigma> (get \<rho>) = \<rho>"
    by (metis put_det weak_get_put)

end

lemma pbij_lens_weak [simp]:
  "pbij_lens x \<Longrightarrow> weak_lens x"
  by (simp_all add: pbij_lens_def)

lemma pbij_lens_mwb [simp]: "pbij_lens x \<Longrightarrow> mwb_lens x"
  by (simp add: mwb_lens_axioms.intro mwb_lens_def pbij_lens.put_is_create)

lemma pbij_alt_intro:
  "\<lbrakk> weak_lens X; \<And> s. s \<in> \<S>\<^bsub>X\<^esub> \<Longrightarrow> create\<^bsub>X\<^esub> (get\<^bsub>X\<^esub> s) = s \<rbrakk> \<Longrightarrow> pbij_lens X"
  by (metis pbij_lens_axioms_def pbij_lens_def weak_lens.put_closure weak_lens.put_get)

subsection \<open> Bijective Lenses \<close>

text \<open>Bijective lenses characterise the situation where the source and view type are equivalent:
  in other words the view type full characterises the whole source type. It is often useful
  when the view type and source type are syntactically different, but nevertheless correspond
  precisely in terms of what they observe. Bijective lenses are formulates using
  the strong GetPut law~\<^cite>\<open>"Foster09" and "Fischer2015"\<close>.\<close>

locale bij_lens = weak_lens +
  assumes strong_get_put: "put \<sigma> (get \<rho>) = \<rho>"
begin

sublocale pbij_lens
proof
  fix \<sigma> v \<rho>
  show "put \<sigma> v = put \<rho> v"
    by (metis put_get strong_get_put)
qed

sublocale vwb_lens
proof
  fix \<sigma> v u
  show "put \<sigma> (get \<sigma>) = \<sigma>"
    by (simp add: strong_get_put)
qed

  lemma put_bij: "bij_betw (put \<sigma>) UNIV UNIV"
    by (metis bijI put_inj strong_get_put surj_def)

  lemma get_create: "create (get \<sigma>) = \<sigma>"
    by (simp add: lens_create_def strong_get_put)

end

declare bij_lens.strong_get_put [simp]
declare bij_lens.get_create [simp]

lemma bij_lens_weak [simp]:
  "bij_lens x \<Longrightarrow> weak_lens x"
  by (simp_all add: bij_lens_def)

lemma bij_lens_pbij [simp]:
  "bij_lens x \<Longrightarrow> pbij_lens x"
  by (metis bij_lens.get_create bij_lens_def pbij_lens_axioms.intro pbij_lens_def weak_lens.put_get)

lemma bij_lens_vwb [simp]: "bij_lens x \<Longrightarrow> vwb_lens x"
  by (metis bij_lens.strong_get_put bij_lens_weak mwb_lens.intro mwb_lens_axioms.intro vwb_lens_def wb_lens.intro wb_lens_axioms.intro weak_lens.put_get)

text \<open> Alternative characterisation: a bijective lens is a partial bijective lens that is also
  very well-behaved (i.e. total). \<close>

lemma pbij_vwb_is_bij_lens:
  "\<lbrakk> pbij_lens X; vwb_lens X \<rbrakk> \<Longrightarrow> bij_lens X"
  by (unfold_locales, simp_all, meson pbij_lens.put_det vwb_lens.put_eq)

lemma bij_lens_iff_pbij_vwb:
  "bij_lens X \<longleftrightarrow> (pbij_lens X \<and> vwb_lens X)"
  using pbij_vwb_is_bij_lens by auto

subsection \<open>Lens Independence\<close>

text \<open>
  \begin{figure}
  \begin{center}
    \includegraphics[width=6cm]{figures/Independence}
  \end{center}
  \vspace{-5ex}
  \caption{Lens Independence}
  \label{fig:Indep}
  \end{figure}

  Lens independence shows when two lenses $X$ and $Y$ characterise disjoint regions of the
  source type, as illustrated in Figure~\ref{fig:Indep}. We specify this by requiring that the $\lput$
  functions of the two lenses commute, and that the $\lget$ function of each lens is unaffected by
  application of $\lput$ from the corresponding lens. \<close>

locale lens_indep =
  fixes X :: "'a \<Longrightarrow> 'c" and Y :: "'b \<Longrightarrow> 'c"
  assumes lens_put_comm: "put\<^bsub>X\<^esub> (put\<^bsub>Y\<^esub> \<sigma> v) u = put\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> \<sigma> u) v"
  and lens_put_irr1: "get\<^bsub>X\<^esub> (put\<^bsub>Y\<^esub> \<sigma> v) = get\<^bsub>X\<^esub> \<sigma>"
  and lens_put_irr2: "get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> \<sigma> u) = get\<^bsub>Y\<^esub> \<sigma>"

notation lens_indep (infix "\<bowtie>" 50)

lemma lens_indepI:
  "\<lbrakk> \<And> u v \<sigma>. put\<^bsub>x\<^esub> (put\<^bsub>y\<^esub> \<sigma> v) u = put\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> \<sigma> u) v;
     \<And> v \<sigma>. get\<^bsub>x\<^esub> (put\<^bsub>y\<^esub> \<sigma> v) = get\<^bsub>x\<^esub> \<sigma>;
     \<And> u \<sigma>. get\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> \<sigma> u) = get\<^bsub>y\<^esub> \<sigma> \<rbrakk> \<Longrightarrow> x \<bowtie> y"
  by (simp add: lens_indep_def)

text \<open>Lens independence is symmetric.\<close>

lemma lens_indep_sym:  "x \<bowtie> y \<Longrightarrow> y \<bowtie> x"
  by (simp add: lens_indep_def)

lemma lens_indep_comm:
  "x \<bowtie> y \<Longrightarrow> put\<^bsub>x\<^esub> (put\<^bsub>y\<^esub> \<sigma> v) u = put\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> \<sigma> u) v"
  by (simp add: lens_indep_def)

lemma lens_indep_get [simp]:
  assumes "x \<bowtie> y"
  shows "get\<^bsub>x\<^esub> (put\<^bsub>y\<^esub> \<sigma> v) = get\<^bsub>x\<^esub> \<sigma>"
  using assms lens_indep_def by fastforce

text \<open> Characterisation of independence for two very well-behaved lenses \<close>

lemma lens_indep_vwb_iff:
  assumes "vwb_lens x" "vwb_lens y"
  shows "x \<bowtie> y \<longleftrightarrow> (\<forall> u v \<sigma>. put\<^bsub>x\<^esub> (put\<^bsub>y\<^esub> \<sigma> v) u = put\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> \<sigma> u) v)"
proof
  assume "x \<bowtie> y"
  thus "\<forall> u v \<sigma>. put\<^bsub>x\<^esub> (put\<^bsub>y\<^esub> \<sigma> v) u = put\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> \<sigma> u) v"
    by (simp add: lens_indep_comm)
next
  assume a: "\<forall> u v \<sigma>. put\<^bsub>x\<^esub> (put\<^bsub>y\<^esub> \<sigma> v) u = put\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> \<sigma> u) v"
  show "x \<bowtie> y"
  proof (unfold_locales)
    fix \<sigma> v u
    from a show "put\<^bsub>x\<^esub> (put\<^bsub>y\<^esub> \<sigma> v) u = put\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> \<sigma> u) v"
      by auto
    show "get\<^bsub>x\<^esub> (put\<^bsub>y\<^esub> \<sigma> v) = get\<^bsub>x\<^esub> \<sigma>"
      by (metis a assms(1) vwb_lens.put_eq vwb_lens_wb wb_lens_def weak_lens.put_get)
    show "get\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> \<sigma> u) = get\<^bsub>y\<^esub> \<sigma>"
      by (metis a assms(2) vwb_lens.put_eq vwb_lens_wb wb_lens_def weak_lens.put_get)
  qed
qed

subsection \<open> Lens Compatibility \<close>

text \<open> Lens compatibility is a weaker notion than independence. It allows that two lenses can overlap
  so long as they manipulate the source in the same way in that region. It is most easily defined
  in terms of a function for copying a region from one source to another using a lens. \<close>

definition lens_compat (infix "##\<^sub>L" 50) where
[lens_defs]: "lens_compat X Y = (\<forall>s\<^sub>1 s\<^sub>2. s\<^sub>1 \<triangleleft>\<^bsub>X\<^esub> s\<^sub>2 \<triangleleft>\<^bsub>Y\<^esub> s\<^sub>2 = s\<^sub>1 \<triangleleft>\<^bsub>Y\<^esub> s\<^sub>2 \<triangleleft>\<^bsub>X\<^esub> s\<^sub>2)"

lemma lens_compat_idem [simp]: "x ##\<^sub>L x"
  by (simp add: lens_defs)

lemma lens_compat_sym: "x ##\<^sub>L y \<Longrightarrow> y ##\<^sub>L x"
  by (simp add: lens_defs)

lemma lens_indep_compat [simp]: "x \<bowtie> y \<Longrightarrow> x ##\<^sub>L y"
  by (simp add: lens_override_def lens_compat_def lens_indep_comm)

end


theory Longest_Path
  imports "../DP_Lifting" "../DP_CRelVS" "../DP_Proof"
begin

context (* Longest path *)
  fixes v :: "nat \<Rightarrow> nat"
    and p :: "nat \<Rightarrow> nat"
  assumes p_lt: "p (Suc j) < Suc j"
begin

text \<open>Dimensionality given by i\<close>
function wis :: "nat \<Rightarrow> nat" where
  "wis 0 = 0" |
  "wis (Suc i) = max (wis (p (Suc i)) + v i) (wis i)"
  by pat_completeness auto
termination
  by (relation "(\<lambda>p. size p) <*mlex*> {}") (auto intro: wf_mlex mlex_less simp: p_lt)

ML_file \<open>../scratch/Transform.ML\<close>
local_setup \<open>
lift_fun NONE;
\<close>
print_theorems

interpretation wis: dp_consistency wis .

lemma "wis.consistentDP wis\<^sub>T"
  by (dp_match induct: wis.induct simp: wis.simps simp\<^sub>T: wis\<^sub>T.simps)
end

end