theory lt
imports Main
        "../data/Natu"
        "$HIPSTER_HOME/IsaHipster"

begin

fun lt :: "Nat => Nat => bool" where
  "lt x (Z) = False"
| "lt (Z) (S z) = True"
| "lt (S x2) (S z) = lt x2 z"

hipster lt
lemma lemma_a [thy_expl]: "lt x2 x2 = False"
by (hipster_induct_schemes lt.lt.simps)

lemma lemma_aa [thy_expl]: "lt x2 (S x2) = True"
by (hipster_induct_schemes lt.lt.simps)

lemma lemma_ab [thy_expl]: "lt (S x2) x2 = False"
by (hipster_induct_schemes lt.lt.simps)

hipster_cond lt
lemma lemma_ac [thy_expl]: "lt y2 x2 \<Longrightarrow> lt x2 y2 = False"
by (hipster_induct_schemes lt.lt.simps)

lemma lemma_ad [thy_expl]: "lt y2 x2 \<Longrightarrow> lt Z x2 = True"
by (hipster_induct_schemes lt.lt.simps)

lemma lemma_ae [thy_expl]: "lt x2 y2 \<Longrightarrow> lt x2 (S y2) = True"
by (hipster_induct_schemes lt.lt.simps)

lemma lemma_af [thy_expl]: "lt y2 x2 \<Longrightarrow> lt x2 (S y2) = False"
by (hipster_induct_schemes lt.lt.simps)

lemma lemma_ag [thy_expl]: "lt y1 x1 \<and> lt z1 y1 \<Longrightarrow> lt (S Z) x1 = True"
by (hipster_induct_schemes lt.lt.simps)

lemma unknown [thy_expl]: "lt z x \<and> lt y z \<Longrightarrow> lt x y = False"
oops

lemma unknown [thy_expl]: "lt z y \<and> lt x z \<Longrightarrow> lt x y = True"
oops

lemma unknown [thy_expl]: "lt z x \<and> lt y z \<Longrightarrow> lt x (S y) = False"
oops

lemma unknown [thy_expl]: "lt z y \<and> lt x z \<Longrightarrow> lt x (S y) = True"
oops

lemma unknown [thy_expl]: "lt z x \<and> lt y z \<Longrightarrow> lt (S x) y = False"
oops

lemma unknown [thy_expl]: "lt z y \<and> lt x z \<Longrightarrow> lt (S x) y = True"
oops

lemma unknown [thy_expl]: "lt z x \<and> lt y z \<Longrightarrow> lt (S x) (S y) = False"
oops

lemma unknown [thy_expl]: "lt z y \<and> lt x z \<Longrightarrow> lt (S x) (S y) = True"
oops

end


theory Short_Theory_ASM
  imports "HOL-IMP.AExp"
begin

datatype instr = LOADI val | LOAD vname | ADD
type_synonym stack = "val list"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
  "exec1 (LOADI n) _ stk = Some (n # stk)" |
  "exec1 (LOAD x) s stk = Some (s x # stk)" |
  "exec1 ADD _ (j # i # stk) = Some ((i + j) # stk)" |
  "exec1 ADD _ _ = None"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
  "exec [] _ stk = Some stk" |
  "exec (i # is) s stk =
    (case exec1 i s stk of
      Some stk\<^sub>i \<Rightarrow> exec is s stk\<^sub>i |
      None \<Rightarrow> None)"

fun comp :: "aexp \<Rightarrow> instr list" where
  "comp (N n) = [LOADI n]" |
  "comp (V x) = [LOAD x]" |
  "comp (Plus e\<^sub>1 e\<^sub>2) = comp e\<^sub>1 @ comp e\<^sub>2 @ [ADD]"

lemma exec_app: "exec (is\<^sub>1 @ is\<^sub>2) s stk =
  (case exec is\<^sub>1 s stk of
    Some stk\<^sub>1 \<Rightarrow> exec is\<^sub>2 s stk\<^sub>1 |
    None \<Rightarrow> None)"
  apply (induction is\<^sub>1 arbitrary: stk)
   apply (auto split: option.split)
  done

lemma "exec (comp a) s stk = Some (aval a s # stk)"
  apply (induction a arbitrary: stk)
    apply (auto simp add: exec_app)
  done

end


(*  Title:      ZF/Induct/Binary_Trees.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section \<open>Binary trees\<close>

theory Binary_Trees imports ZF begin

subsection \<open>Datatype definition\<close>

consts
  bt :: "i \<Rightarrow> i"

datatype "bt(A)" =
  Lf | Br ("a \<in> A", "t1 \<in> bt(A)", "t2 \<in> bt(A)")

declare bt.intros [simp]

lemma Br_neq_left: "l \<in> bt(A) \<Longrightarrow> Br(x, l, r) \<noteq> l"
  by (induct arbitrary: x r set: bt) auto

lemma Br_iff: "Br(a, l, r) = Br(a', l', r') \<longleftrightarrow> a = a' \<and> l = l' \<and> r = r'"
  \<comment> \<open>Proving a freeness theorem.\<close>
  by (fast elim!: bt.free_elims)

inductive_cases BrE: "Br(a, l, r) \<in> bt(A)"
  \<comment> \<open>An elimination rule, for type-checking.\<close>

text \<open>
  \medskip Lemmas to justify using \<^term>\<open>bt\<close> in other recursive type
  definitions.
\<close>

lemma bt_mono: "A \<subseteq> B \<Longrightarrow> bt(A) \<subseteq> bt(B)"
    unfolding bt.defs
  apply (rule lfp_mono)
    apply (rule bt.bnd_mono)+
  apply (rule univ_mono basic_monos | assumption)+
  done

lemma bt_univ: "bt(univ(A)) \<subseteq> univ(A)"
    unfolding bt.defs bt.con_defs
  apply (rule lfp_lowerbound)
   apply (rule_tac [2] A_subset_univ [THEN univ_mono])
  apply (fast intro!: zero_in_univ Inl_in_univ Inr_in_univ Pair_in_univ)
  done

lemma bt_subset_univ: "A \<subseteq> univ(B) \<Longrightarrow> bt(A) \<subseteq> univ(B)"
  apply (rule subset_trans)
   apply (erule bt_mono)
  apply (rule bt_univ)
  done

lemma bt_rec_type:
  "\<lbrakk>t \<in> bt(A);
    c \<in> C(Lf);
    \<And>x y z r s. \<lbrakk>x \<in> A;  y \<in> bt(A);  z \<in> bt(A);  r \<in> C(y);  s \<in> C(z)\<rbrakk> \<Longrightarrow>
    h(x, y, z, r, s) \<in> C(Br(x, y, z))
\<rbrakk> \<Longrightarrow> bt_rec(c, h, t) \<in> C(t)"
  \<comment> \<open>Type checking for recursor -- example only; not really needed.\<close>
  apply (induct_tac t)
   apply simp_all
  done

subsection \<open>Number of nodes, with an example of tail-recursion\<close>

consts  n_nodes :: "i \<Rightarrow> i"
primrec
  "n_nodes(Lf) = 0"
  "n_nodes(Br(a, l, r)) = succ(n_nodes(l) #+ n_nodes(r))"

lemma n_nodes_type [simp]: "t \<in> bt(A) \<Longrightarrow> n_nodes(t) \<in> nat"
  by (induct set: bt) auto

consts  n_nodes_aux :: "i \<Rightarrow> i"
primrec
  "n_nodes_aux(Lf) = (\<lambda>k \<in> nat. k)"
  "n_nodes_aux(Br(a, l, r)) =
      (\<lambda>k \<in> nat. n_nodes_aux(r) `  (n_nodes_aux(l) ` succ(k)))"

lemma n_nodes_aux_eq:
    "t \<in> bt(A) \<Longrightarrow> k \<in> nat \<Longrightarrow> n_nodes_aux(t)`k = n_nodes(t) #+ k"
  apply (induct arbitrary: k set: bt)
   apply simp
  apply (atomize, simp)
  done

definition
  n_nodes_tail :: "i \<Rightarrow> i"  where
  "n_nodes_tail(t) \<equiv> n_nodes_aux(t) ` 0"

lemma "t \<in> bt(A) \<Longrightarrow> n_nodes_tail(t) = n_nodes(t)"
  by (simp add: n_nodes_tail_def n_nodes_aux_eq)

subsection \<open>Number of leaves\<close>

consts
  n_leaves :: "i \<Rightarrow> i"
primrec
  "n_leaves(Lf) = 1"
  "n_leaves(Br(a, l, r)) = n_leaves(l) #+ n_leaves(r)"

lemma n_leaves_type [simp]: "t \<in> bt(A) \<Longrightarrow> n_leaves(t) \<in> nat"
  by (induct set: bt) auto

subsection \<open>Reflecting trees\<close>

consts
  bt_reflect :: "i \<Rightarrow> i"
primrec
  "bt_reflect(Lf) = Lf"
  "bt_reflect(Br(a, l, r)) = Br(a, bt_reflect(r), bt_reflect(l))"

lemma bt_reflect_type [simp]: "t \<in> bt(A) \<Longrightarrow> bt_reflect(t) \<in> bt(A)"
  by (induct set: bt) auto

text \<open>
  \medskip Theorems about \<^term>\<open>n_leaves\<close>.
\<close>

lemma n_leaves_reflect: "t \<in> bt(A) \<Longrightarrow> n_leaves(bt_reflect(t)) = n_leaves(t)"
  by (induct set: bt) (simp_all add: add_commute)

lemma n_leaves_nodes: "t \<in> bt(A) \<Longrightarrow> n_leaves(t) = succ(n_nodes(t))"
  by (induct set: bt) simp_all

text \<open>
  Theorems about \<^term>\<open>bt_reflect\<close>.
\<close>

lemma bt_reflect_bt_reflect_ident: "t \<in> bt(A) \<Longrightarrow> bt_reflect(bt_reflect(t)) = t"
  by (induct set: bt) simp_all

end


section "Resizable arrays"
theory ResizableArrays imports Main begin

text \<open>These arrays resize themselves, padding with fillValue.\<close>

type_synonym 'a rArray = "nat * (nat => 'a)"

definition fillAndUpdate :: "nat => (nat => 'a) => nat => 'a => 'a => (nat => 'a)" where
  "fillAndUpdate len f i value fillValue j ==
     if j=i then value
     else if (len <= j & j < i) then fillValue
     else f j"

definition raWrite :: "'a rArray => nat => 'a => 'a => 'a rArray" where
  "raWrite arr i value fillValue ==
   (let len = fst arr;
        f = snd arr
    in
     if i < len then (len,f(i:=value))
     else (i+1, fillAndUpdate len f i value fillValue)
   )"

definition cutoff :: "'a => 'a rArray => 'a rArray" where
  "cutoff fill arr ==
     (fst arr,
      % i. if i < fst arr then snd arr i else fill)"

lemma raWriteSizeSame [simp]: "i < fst arr ==> fst (raWrite arr i value fillValue) = fst arr"
by (simp_all add: raWrite_def fillAndUpdate_def Let_def)

lemma raWriteSizeGrows [simp]: "(fst arr <= i) ==> fst (raWrite arr i value fillValue) = i+1"
by (simp_all add: raWrite_def fillAndUpdate_def Let_def)

lemma raWriteContentChanged [simp]: "snd (raWrite arr i value fillValue) i = value"
by (simp_all add: raWrite_def fillAndUpdate_def Let_def)

lemma raWriteContentOld [simp]: "[| j < fst arr; i ~= j |] ==>
                          snd (raWrite arr i value fillValue) j = snd arr j"
by (simp_all add: raWrite_def fillAndUpdate_def Let_def)

lemma raWriteContentFill [simp]: "[| fst arr < j; j < i |] ==>
                          snd (raWrite arr i value fillValue) j = fillValue"
by (simp_all add: raWrite_def fillAndUpdate_def Let_def)

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>A simple cookbook example how to eliminate choice in programs.\<close>

theory Execute_Choice
imports Main "~~/src/HOL/Library/AList_Mapping"
begin

text \<open>
  A trivial example:
\<close>

definition valuesum :: "('a, 'b :: ab_group_add) mapping \<Rightarrow> 'b" where
  "valuesum m = (\<Sum>k \<in> Mapping.keys m. the (Mapping.lookup m k))"

text \<open>
  Not that instead of defining @{term valuesum} with choice, we define it
  directly and derive a description involving choice afterwards:
\<close>

lemma valuesum_rec:
  assumes fin: "finite (dom (Mapping.lookup m))"
  shows "valuesum m = (if Mapping.is_empty m then 0 else
    let l = (SOME l. l \<in> Mapping.keys m) in the (Mapping.lookup m l) + valuesum (Mapping.delete l m))"
proof (cases "Mapping.is_empty m")
  case True then show ?thesis by (simp add: is_empty_def keys_def valuesum_def)
next
  case False
  then have l: "\<exists>l. l \<in> dom (Mapping.lookup m)" unfolding is_empty_def by transfer auto
  then have "(let l = SOME l. l \<in> dom (Mapping.lookup m) in
     the (Mapping.lookup m l) + (\<Sum>k \<in> dom (Mapping.lookup m) - {l}. the (Mapping.lookup m k))) =
       (\<Sum>k \<in> dom (Mapping.lookup m). the (Mapping.lookup m k))"
  proof (rule someI2_ex)
    fix l
    note fin
    moreover assume "l \<in> dom (Mapping.lookup m)"
    moreover obtain A where "A = dom (Mapping.lookup m) - {l}" by simp
    ultimately have "dom (Mapping.lookup m) = insert l A" and "finite A" and "l \<notin> A" by auto
    then show "(let l = l
        in the (Mapping.lookup m l) + (\<Sum>k \<in> dom (Mapping.lookup m) - {l}. the (Mapping.lookup m k))) =
        (\<Sum>k \<in> dom (Mapping.lookup m). the (Mapping.lookup m k))"
      by simp
   qed
  then show ?thesis unfolding is_empty_def valuesum_def by transfer simp
qed

text \<open>
  In the context of the else-branch we can show that the exact choice is
  irrelvant; in practice, finding this point where choice becomes irrelevant is the
  most difficult thing!
\<close>

lemma valuesum_choice:
  "finite (Mapping.keys M) \<Longrightarrow> x \<in> Mapping.keys M \<Longrightarrow> y \<in> Mapping.keys M \<Longrightarrow>
    the (Mapping.lookup M x) + valuesum (Mapping.delete x M) =
    the (Mapping.lookup M y) + valuesum (Mapping.delete y M)"
  unfolding valuesum_def  by transfer (simp add: sum_diff)

text \<open>
  Given \<open>valuesum_rec\<close> as initial description, we stepwise refine it to something executable;
  first, we formally insert the constructor @{term Mapping} and split the one equation into two,
  where the second one provides the necessary context:
\<close>

lemma valuesum_rec_Mapping:
  shows [code]: "valuesum (Mapping []) = 0"
  and "valuesum (Mapping (x # xs)) = (let l = (SOME l. l \<in> Mapping.keys (Mapping (x # xs))) in
    the (Mapping.lookup (Mapping (x # xs)) l) + valuesum (Mapping.delete l (Mapping (x # xs))))"
  by (simp_all add: valuesum_rec finite_dom_map_of is_empty_Mapping null_def)

text \<open>
  As a side effect the precondition disappears (but note this has nothing to do with choice!).
  The first equation deals with the uncritical empty case and can already be used for code generation.

  Using \<open>valuesum_choice\<close>, we are able to prove an executable version of @{term valuesum}:
\<close>

lemma valuesum_rec_exec [code]:
  "valuesum (Mapping (x # xs)) = (let l = fst (hd (x # xs)) in
    the (Mapping.lookup (Mapping (x # xs)) l) + valuesum (Mapping.delete l (Mapping (x # xs))))"
proof -
  let ?M = "Mapping (x # xs)"
  let ?l1 = "(SOME l. l \<in> Mapping.keys ?M)"
  let ?l2 = "fst (hd (x # xs))"
  have "finite (Mapping.keys ?M)" by (simp add: keys_Mapping)
  moreover have "?l1 \<in> Mapping.keys ?M"
    by (rule someI) (auto simp add: keys_Mapping)
  moreover have "?l2 \<in> Mapping.keys ?M"
    by (simp add: keys_Mapping)
  ultimately have "the (Mapping.lookup ?M ?l1) + valuesum (Mapping.delete ?l1 ?M) =
    the (Mapping.lookup ?M ?l2) + valuesum (Mapping.delete ?l2 ?M)"
    by (rule valuesum_choice)
  then show ?thesis by (simp add: valuesum_rec_Mapping)
qed

text \<open>
  See how it works:
\<close>

value "valuesum (Mapping [(''abc'', (42::int)), (''def'', 1705)])"

end


theory Soft_Types
  imports remove_syntax GST_Logic "HOL-Eisbach.Eisbach"
begin

(*CREDIT TO KAPPELMANN: https://github.com/kappelmann/Isabelle-Set*)

subsection \<open>Typing judgements\<close>
definition has_ty :: "'a \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"  (infix ":" 45)
  where "x : P \<equiv> P x"

lemma tyI : "P x \<Longrightarrow> x : P" unfolding has_ty_def by simp
lemma tyE : "x : P \<Longrightarrow> P x" unfolding has_ty_def by simp

definition tall :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
  where "tall P Q \<equiv> \<forall>x. x : P \<longrightarrow> Q x"

definition tex :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
  where "tex P Q \<equiv> \<exists>x. x : P \<and> Q x"

definition tex1 :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
  where "tex1 P Q \<equiv> \<exists>!x. x : P \<and> Q x"

definition tuniq :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
  where "tuniq P Q \<equiv> \<exists>\<^sub>\<le>\<^sub>1x. x : P \<and> Q x"

definition typ_defdes :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a"
  where "typ_defdes P Q d \<equiv> (\<iota> x. x : P \<and> Q x else d) "

syntax
  "_tball"  :: "[pttrn, 'a \<Rightarrow> bool, bool] \<Rightarrow> bool"  ("(3\<forall>_ : _./ _)" 10)
  "_tbex"   :: "[pttrn, 'a \<Rightarrow> bool, bool] \<Rightarrow> bool"  ("(3\<exists>_ : _./ _)" 10)
  "_tex1"   :: "[pttrn, 'a \<Rightarrow> bool, bool] \<Rightarrow> bool"  ("(3\<exists>!_ : _./ _)" 10)
  "_tuniq"  :: "[pttrn, 'a \<Rightarrow> bool, bool] \<Rightarrow> bool"  ("(3\<exists>\<^sub>\<le>\<^sub>1_ : _./ _)" 10)
  "_tdefdes" :: "[pttrn, 'a \<Rightarrow> bool, 'a \<Rightarrow> bool, 'a] \<Rightarrow> 'a"  ("(4\<iota>_ : _./ _ else _)" 10)
translations
  "\<forall>x : A. P"  \<rightleftharpoons> "CONST tall A (\<lambda>x. P)"
  "\<exists>x : A. P"  \<rightleftharpoons> "CONST tex A (\<lambda>x. P)"
  "\<exists>!x : A. P" \<rightleftharpoons> "CONST tex1 A (\<lambda>x. P)"
  "\<exists>\<^sub>\<le>\<^sub>1x: A. P" \<rightleftharpoons> "CONST tuniq A (\<lambda>x. P)"
  "\<iota> x : A. P else default" \<rightleftharpoons> "CONST typ_defdes A (\<lambda>x. P) default"

lemma tallI [intro!] :
  "(\<And>x. x : P \<Longrightarrow> Q x) \<Longrightarrow> \<forall>x : P. Q x"
  unfolding tall_def by auto

lemma tallE [elim!]:
  assumes "\<forall>x : P. Q x"
  obtains "\<And>x. (x : P \<Longrightarrow> Q x)"
  using assms unfolding tall_def by auto

lemma tallD [elim]:
  "\<lbrakk> \<forall>x : P. Q x ; x : P \<rbrakk> \<Longrightarrow> Q x"
  by auto

lemma texI [intro] :
  "\<lbrakk> x : P ; Q x \<rbrakk> \<Longrightarrow> \<exists>x:P. Q x"
  unfolding tex_def by auto

lemma texE [elim!] :
  assumes "\<exists>x:P. Q x"
  obtains x where "x : P" and "Q x"
  using assms unfolding tex_def by auto

lemma typ_defdes_eq :
  assumes "b : A" "P b"
      and eq:"\<And>c. c : A \<Longrightarrow> P c \<Longrightarrow> c = b"
    shows "(\<iota> b : A. P b else d) = b"
  unfolding typ_defdes_def
  by (rule the_def_eq, rule conjI[OF \<open>b : A\<close> \<open>P b\<close>],
      use assms(3) in auto)

lemma typ_defdes_eq' :
  assumes ex1:"\<exists>! b : A. P b"
     and c:"c : A" "P c"
  shows "(\<iota> b : A. P b else d) = c"
  using ex1 c unfolding tex1_def
  by (blast intro: typ_defdes_eq)

lemma typ_defdesI :
  assumes b:"b : A" "P b"
      and eq:"\<And>c. c : A \<Longrightarrow> P c \<Longrightarrow> c = b"
  shows "P (\<iota> x : A. P x else d)"
proof -
  from typ_defdes_eq[of b A P, OF b] eq
  have "(\<iota> x : A. P x else d) = b" by auto
  thus "P (\<iota> x : A. P x else d)" using \<open>P b\<close> by simp
qed

lemma typ_defdesI' :
  assumes ex1:"\<exists>! b : A. P b"
  shows "P (\<iota> b : A. P b else d)"
  using ex1 unfolding tex1_def
  by (blast intro: typ_defdesI)

subsection \<open>Methods for soft-type automation\<close>

named_theorems typdef
named_theorems typ_intro

method unfold_typs =
  (rule typ_intro |
   simp_all only: typdef has_ty_def tall_def tex_def)+
(*Repeatedly applies rules marked with [typ_intro] attribute and
  applies simp method to all goals using facts marked with [typdef],
  the definition \<open>x : P \<equiv> P x\<close> and definitions of restricted/dervied quantifiers*)

definition Any :: "('a \<Rightarrow> bool)" (\<open>\<top>\<close>) where [typdef] : "Any \<equiv> (\<lambda>x. True)"

lemma anyI [simp] : "x : Any" unfolding has_ty_def Any_def by auto

definition Bool :: "bool \<Rightarrow> bool" ("\<bool>") where [typdef] : "\<bool> \<equiv> (\<lambda>p. True)"

subsection \<open>Function types\<close>
definition fun_ty :: "('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> bool)" (infixr "\<rightarrow>" 50)
  where [typdef] : "P \<rightarrow> Q \<equiv> \<lambda>f. \<forall>x. P x \<longrightarrow> Q (f x)"
lemma funty_eq : "f : P \<rightarrow> Q \<equiv> \<forall>x. x : P \<longrightarrow> f x : Q"
  unfolding fun_ty_def has_ty_def by auto

lemma funE : "f : P \<rightarrow> Q \<Longrightarrow> x : P \<Longrightarrow> f x : Q"
  unfolding fun_ty_def has_ty_def by auto

lemma funI [typ_intro]: "(\<And>x. x : P \<Longrightarrow> f x : Q) \<Longrightarrow> f : P \<rightarrow> Q"
  unfolding fun_ty_def has_ty_def by auto

subsection \<open>Dependent Function types\<close>

definition depfun_ty :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('b \<Rightarrow> bool)) \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> bool)"
  where [typdef]: "depfun_ty P Q \<equiv> (\<lambda>f. \<forall>x : P. f x : Q x)"
syntax
  "_depfunty" :: "[pttrn, 'a \<Rightarrow> bool, bool] => bool" (\<open>(3\<Pi> _:_./ _)\<close> 10)
translations
  "\<Pi> x:P. B" \<rightleftharpoons> "CONST depfun_ty P (\<lambda>x. B)"

lemma depfunty_eq :
  "f : depfun_ty P Q \<equiv> \<forall>x. x : P \<longrightarrow> f x : Q x"
  unfolding depfun_ty_def tall_def has_ty_def by auto

lemma depfunI [typ_intro] :
  "(\<And>x. x : A \<Longrightarrow> f x : B x) \<Longrightarrow> f : (\<Pi> x : A. B x)"
  unfolding depfun_ty_def tall_def has_ty_def by auto

lemma depfunE :
  assumes "f : (\<Pi> x : A. B x)" "x : A"
  shows "f x : B x"
  using assms unfolding depfun_ty_def tall_def has_ty_def by auto

subsection \<open>Relation types\<close>
definition BinPred where [typdef] : "BinPred \<alpha> \<beta> P \<equiv> (\<forall>x y. x : \<alpha> \<and> P x y \<longrightarrow> y : \<beta>)"

lemma bpredE : "P : BinPred \<alpha> \<beta> \<Longrightarrow> x : \<alpha> \<Longrightarrow> P x y \<Longrightarrow> y : \<beta>"
  unfolding BinPred_def by (drule tyE, auto)
lemma bpredI [typ_intro]: "(\<And>x y. x : \<alpha> \<Longrightarrow> P x y \<Longrightarrow> y : \<beta>) \<Longrightarrow> P : BinPred \<alpha> \<beta>"
  unfolding BinPred_def by (unfold_typs, auto)

subsection \<open>Intersection types\<close>
definition inter_ty :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infix "\<triangle>" 50)
  where [typdef] : "P \<triangle> Q \<equiv> \<lambda>x. P x \<and> Q x"

lemma intE :
  assumes "x : (P \<triangle> Q)"
    shows "x : P \<and> x : Q"
  using assms unfolding inter_ty_def by unfold_typs

lemma intE1 : "x : (P \<triangle> Q) \<Longrightarrow> x : P"
  unfolding inter_ty_def by unfold_typs

lemma intE2 : "x : (P \<triangle> Q) \<Longrightarrow> x : Q"
  unfolding inter_ty_def by unfold_typs

lemma intI [typ_intro] :
  "\<lbrakk> x : P ; x : Q \<rbrakk> \<Longrightarrow> x : (P \<triangle> Q)"
  unfolding inter_ty_def by unfold_typs

subsection \<open>Intersection types\<close>
definition union_ty :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infix "\<mho>" 50)
  where [typdef] : "P \<mho> Q \<equiv> \<lambda>x. x : P \<or> x : Q"

lemma uniI [typ_intro] :
  "\<lbrakk> x : P \<or> x : Q \<rbrakk> \<Longrightarrow> x : (P \<mho> Q)"
  unfolding union_ty_def by unfold_typs

lemma uniE :
  assumes "x : (P \<mho> Q)"
    shows "x : P \<or> x : Q"
  using assms unfolding union_ty_def by unfold_typs

subsection \<open>Subtyping\<close>
definition subtyp :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" (infix "<<" 45)
  where "P << Q \<equiv> \<forall>x. x : P \<longrightarrow> x : Q"

lemma subtypI  : "(\<And>x. x : P \<Longrightarrow> x : Q) \<Longrightarrow> P << Q" unfolding subtyp_def by (auto)
lemma subtypE : "P << Q \<Longrightarrow> x : P \<Longrightarrow> x : Q" unfolding subtyp_def by auto

lemma subtyp_trans :
  assumes "P << Q" "Q << R"
  shows "P << R"
  by (rule subtypI, rule subtypE[OF \<open>Q << R\<close>], rule subtypE[OF \<open>P << Q\<close>], assumption)

lemma int_sub1 : "(P \<triangle> Q) << P" by (rule subtypI, erule intE1)
lemma int_sub2 : "(P \<triangle> Q) << Q" by (rule subtypI, erule intE2)

lemma subtyp_fun_dom : "R << P \<Longrightarrow> f : P \<rightarrow> Q \<Longrightarrow> f : R \<rightarrow> Q"
proof (rule funI)
  assume "f : P \<rightarrow> Q" "R << P"
  fix x assume "x : R" hence "x : P" by (rule subtypE[OF \<open>R << P\<close>])
  thus "f x : Q" by (rule funE[OF \<open>f : P \<rightarrow> Q\<close>])
qed

lemma subtyp_fun_ran : "Q << R \<Longrightarrow> f : P \<rightarrow> Q \<Longrightarrow> f : P \<rightarrow> R"
proof (rule funI)
  assume "f : P \<rightarrow> Q" "Q << R"
  fix x assume "x : P" hence "f x : Q" by (rule funE[OF \<open>f : P \<rightarrow> Q\<close>])
  thus "f x : R" by (rule subtypE[OF \<open>Q << R\<close>])
qed

subsection \<open>Negation type\<close>

definition not_typ :: \<open>('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)\<close> (\<open>\<sim>\<close>)
  where "\<sim> P \<equiv> (\<lambda>x. \<not> P x)"

lemma not_typ_iff :
  "x : \<sim> P \<longleftrightarrow> \<not> x : P"
  unfolding not_typ_def has_ty_def
  by auto

lemmas not_typD = iffD1[OF not_typ_iff]
   and not_typI = iffD2[OF not_typ_iff]

subsection \<open>Empty type\<close>

definition empty_typ :: \<open>('a \<Rightarrow> bool)\<close> (\<open>\<bottom>\<close>)
  where "\<bottom> \<equiv> (\<lambda>x. False)"

lemma empty_typ_iff :
  "x : \<bottom> \<longleftrightarrow> False"
  unfolding empty_typ_def has_ty_def
  by auto

lemmas empty_typD = iffD1[OF empty_typ_iff ]
   and empty_typI = iffD2[OF empty_typ_iff]

lemma neg_empty : "\<not> x : \<bottom>"
  using empty_typD by auto

lemma not_empty : "x : \<sim> \<bottom>"
  using not_typI[OF neg_empty] .

subsection \<open>Difference type constructor\<close>

definition diff_typ :: \<open>('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)\<close> (infixl \<open>\<sslash>\<close> 50)
  where "P \<sslash> Q \<equiv> P \<triangle> \<sim> Q"

lemma diff_typI :
  assumes "x : P" "\<not> x : Q"
    shows "x : P \<sslash> Q"
  unfolding diff_typ_def
  by (rule intI[OF assms(1) not_typI[OF assms(2)]])

lemma diff_typ_iff :
  "x : P \<sslash> Q \<longleftrightarrow> x : P \<and> \<not> x : Q"
  unfolding diff_typ_def inter_ty_def not_typ_def has_ty_def
  by auto

ML \<open>
fun mk_styping_trm trm typ styp =
    ((Const ("Soft_Types.has_ty", typ --> fastype_of styp --> @{typ bool})) $ trm $ styp)

fun unfold_fun_typing k trm =
  let
    fun funE k (f,ty1,ty2) =
      let
        val x_typ = domain_type (fastype_of f)
        val fx_typ = range_type (fastype_of f)
        val x = Free ("x"  ^ Int.toString k, x_typ)
        val typ_trm1 = mk_styping_trm x (x_typ) ty1
        val typ_trm2 = (mk_styping_trm (f $ x) (fx_typ) ty2)
      in
        HOLogic.mk_all ("x" ^ Int.toString k, x_typ,
          HOLogic.mk_imp (unfold_fun_typing (k+1) typ_trm1, unfold_fun_typing (k+1) typ_trm2))
      end
    fun depfunE k (f, ty1, ty2) =
      let
        val x_typ  = domain_type (fastype_of f)
        val fx_typ = range_type (fastype_of f)
        val x = Free ("x" ^ Int.toString k, x_typ)
        val typ_trm1 = mk_styping_trm x x_typ ty1
        val typ_trm2 = mk_styping_trm (f $ x) fx_typ (betapply (ty2, x))
      in
        HOLogic.mk_all ("x"  ^ Int.toString k, x_typ,
          HOLogic.mk_imp (unfold_fun_typing (k+1) typ_trm1, unfold_fun_typing (k+1) typ_trm2))
      end
   in
     case trm of
      ((Const ("Soft_Types.has_ty", _)) $ t $ styp) =>
        (case (t,styp) of
          (f, ((Const ("Soft_Types.fun_ty",_)) $ p $ q)) => funE k (f, p, q)
        | (f, ((Const ("Soft_Types.depfun_ty",_)) $ p $ q)) => depfunE k (f, p, q)
        | _ => trm)
     | _ => trm
   end
\<close>

ML \<open>
fun is_typing ((Const ("Soft_Types.has_ty",_)) $ _ $ _) = true
  | is_typing _ = false

fun is_fun_ty ((Const ("Soft_Types.fun_ty",_)) $ _ $ _) = true
  | is_fun_ty _ = false

fun is_depfun_ty ((Const ("Soft_Types.depfun_ty",_)) $ _ $ _) = true
  | is_depfun_ty _ = false

fun split_typings ((Const ("Soft_Types.has_ty",_)) $ c $ typ) = (c,typ)
  | split_typings _ = error "not a soft typing"

fun split_fun_ty ((Const ("Soft_Types.fun_ty",_)) $ t $ s) = (t,s)
  | split_fun_ty _ = error "not a function soft type"

fun is_fun_typing trm = is_typing trm andalso
    (is_fun_ty (snd (split_typings trm)) orelse is_depfun_ty (snd (split_typings trm)))

fun dest_fun ((Const ("Soft_Types.fun_ty",_)) $ t $ s) = (t,s)
  | dest_fun t = raise TERM ("not a simple fun type", [t])

fun dest_depfun ((Const ("Soft_Types.depfun_ty",_)) $ P $ Qx) =
      (P, snd (Term.strip_abs_eta 1 Qx))
  | dest_depfun t = raise TERM ("not a dependent fun type", [t])

fun get_styps ((Const ("Soft_Types.fun_ty",_)) $ t $ s) = t :: get_styps s
  | get_styps ((Const ("Soft_Types.depfun_ty",_)) $ t $ s) = t :: get_styps s
  | get_styps t = [t]

fun strip_sftyp' sftyp =
  case sftyp of
    ((Const ("Soft_Types.fun_ty",_)) $ _ $ _) =>
      (fn (P,Q) => strip_sftyp' P @ strip_sftyp' Q) (dest_fun sftyp)
  | ((Const ("Soft_Types.depfun_ty",_)) $ _ $ _) =>
      (fn (P,Q) => strip_sftyp' P @ strip_sftyp' Q) (dest_depfun sftyp)
  | _ => [sftyp]

val strip_sftyp = (fn xs => ((rev o tl) xs, hd xs)) o rev o strip_sftyp'

(*Let B be a term, and \<tau> be the type of B, and P be a soft-type on \<tau>:
  Then \<open>mk_styping_trm B \<tau> P\<close> and returns the term \<open>B : P\<close>*)

fun tall_const T =
  Const ("Soft_Types.tall", (T --> @{typ bool}) -->
                 (T --> @{typ bool}) --> @{typ bool});

fun mk_tall (x, T, P, Q) = tall_const T $ P $ absfree (x, T) Q;

 infixr ~>
(* ('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> bool) *)
 fun fun_sty_typ dom ran = (dom --> @{typ bool}) --> (ran --> @{typ bool}) --> ((dom --> ran) --> @{typ bool})
fun t ~> s =
  let val dom = domain_type o fastype_of
  in Const ("Soft_Types.fun_ty", fun_sty_typ (dom t) (dom s)) $ t $ s end

fun mk_styping trm styp = mk_styping_trm trm (fastype_of trm) styp

fun int_ty_const T = Const("Soft_Types.inter_ty",
    (T --> @{typ bool}) --> (T --> @{typ bool}) --> (T --> @{typ bool}))
fun mk_int_ty t1 t2 = (int_ty_const (domain_type (fastype_of t1))) $ t1 $ t2

\<close>

end


theory Derivs
  imports General_Utils
begin

lemma field_simp_has_vector_derivative [derivative_intros]:
  "(f has_field_derivative y) F \<Longrightarrow> (f has_vector_derivative y) F"
  by (simp add: has_real_derivative_iff_has_vector_derivative)

lemma continuous_on_cases_empty [continuous_intros]:
  "\<lbrakk>closed S; continuous_on S f; \<And>x. \<lbrakk>x \<in> S; \<not> P x\<rbrakk> \<Longrightarrow> f x = g x\<rbrakk> \<Longrightarrow>
    continuous_on S (\<lambda>x. if P x then f x else g x)"
  using continuous_on_cases [of _ "{}"] by force

lemma inj_on_cases:
  assumes "inj_on f (Collect P \<inter> S)" "inj_on g (Collect (Not \<circ> P) \<inter> S)"
    "f ` (Collect P \<inter> S) \<inter> g ` (Collect (Not \<circ> P) \<inter> S) = {}"
  shows "inj_on (\<lambda>x. if P x then f x else g x) S"
  using assms by (force simp: inj_on_def)

lemma inj_on_arccos: "S \<subseteq> {-1..1} \<Longrightarrow> inj_on arccos S"
  by (metis atLeastAtMost_iff cos_arccos inj_onI subsetCE)

lemma has_vector_derivative_componentwise_within:
  "(f has_vector_derivative f') (at a within S) \<longleftrightarrow>
    (\<forall>i \<in> Basis. ((\<lambda>x. f x \<bullet> i) has_vector_derivative (f' \<bullet> i)) (at a within S))"
  apply (simp add: has_vector_derivative_def)
  apply (subst has_derivative_componentwise_within)
  apply simp
  done

lemma has_vector_derivative_pair_within:
  fixes f :: "real \<Rightarrow> 'a::euclidean_space" and g :: "real \<Rightarrow> 'b::euclidean_space"
  assumes "\<And>u. u \<in> Basis \<Longrightarrow> ((\<lambda>x. f x \<bullet> u) has_vector_derivative f' \<bullet> u) (at x within S)"
    "\<And>u. u \<in> Basis \<Longrightarrow> ((\<lambda>x. g x \<bullet> u) has_vector_derivative g' \<bullet> u) (at x within S)"
  shows "((\<lambda>x. (f x, g x)) has_vector_derivative (f',g')) (at x within S)"
  apply (subst has_vector_derivative_componentwise_within)
  apply (auto simp: assms Basis_prod_def)
  done

lemma piecewise_C1_differentiable_const:
  shows "(\<lambda>x. c) piecewise_C1_differentiable_on s"
  using continuous_on_const
  by (auto simp add: piecewise_C1_differentiable_on_def)

declare piecewise_C1_differentiable_const [simp, derivative_intros]
declare piecewise_C1_differentiable_neg [simp, derivative_intros]
declare piecewise_C1_differentiable_add [simp, derivative_intros]
declare piecewise_C1_differentiable_diff [simp, derivative_intros]

(*move to Derivative*)

lemma piecewise_C1_differentiable_on_ident [simp, derivative_intros]:
  fixes f :: "real \<Rightarrow> 'a::real_normed_vector"
  shows "(\<lambda>x. x) piecewise_C1_differentiable_on S"
  unfolding piecewise_C1_differentiable_on_def using C1_differentiable_on_ident
  by (blast intro: continuous_on_id C1_differentiable_on_ident)

lemma piecewise_C1_differentiable_on_mult [simp, derivative_intros]:
  fixes f :: "real \<Rightarrow> 'a::real_normed_algebra"
  assumes "f piecewise_C1_differentiable_on S" "g piecewise_C1_differentiable_on S"
  shows "(\<lambda>x. f x * g x) piecewise_C1_differentiable_on S"
  using assms
  unfolding piecewise_C1_differentiable_on_def
  apply safe
   apply (blast intro: continuous_intros)
  apply (rename_tac A B)
  apply (rule_tac x="A \<union> B" in exI)
  apply (auto intro: C1_differentiable_on_mult C1_differentiable_on_subset)
  done

lemma C1_differentiable_on_cdiv [simp, derivative_intros]:
  fixes f :: "real \<Rightarrow> 'a :: real_normed_field"
  shows "f C1_differentiable_on S \<Longrightarrow> (\<lambda>x. f x / c) C1_differentiable_on S"
  by (simp add: divide_inverse)

lemma piecewise_C1_differentiable_on_cdiv [simp, derivative_intros]:
  fixes f :: "real \<Rightarrow> 'a::real_normed_field"
  assumes "f piecewise_C1_differentiable_on S"
  shows "(\<lambda>x. f x / c) piecewise_C1_differentiable_on S"
  by (simp add: divide_inverse piecewise_C1_differentiable_const piecewise_C1_differentiable_on_mult assms)

lemma sqrt_C1_differentiable [simp, derivative_intros]:
  assumes f: "f C1_differentiable_on S" and fim: "f ` S \<subseteq> {0<..}"
  shows "(\<lambda>x. sqrt (f x)) C1_differentiable_on S"
proof -
  have contf: "continuous_on S f"
    by (simp add: C1_differentiable_imp_continuous_on f)
  show ?thesis
    using assms
    unfolding C1_differentiable_on_def has_real_derivative_iff_has_vector_derivative [symmetric]
    by (fastforce intro!: contf continuous_intros derivative_intros)
qed

lemma sqrt_piecewise_C1_differentiable [simp, derivative_intros]:
  assumes f: "f piecewise_C1_differentiable_on S" and fim: "f ` S \<subseteq> {0<..}"
  shows "(\<lambda>x. sqrt (f x)) piecewise_C1_differentiable_on S"
  using assms
  unfolding piecewise_C1_differentiable_on_def
  by (fastforce intro!: continuous_intros derivative_intros)

lemma
  fixes f :: "real \<Rightarrow> 'a::{banach,real_normed_field}"
  assumes f: "f C1_differentiable_on S"
  shows sin_C1_differentiable [simp, derivative_intros]: "(\<lambda>x. sin (f x)) C1_differentiable_on S"
  and   cos_C1_differentiable [simp, derivative_intros]: "(\<lambda>x. cos (f x)) C1_differentiable_on S"
proof -
  have contf: "continuous_on S f"
    by (simp add: C1_differentiable_imp_continuous_on f)
  note df_sin = field_vector_diff_chain_at [where g=sin, unfolded o_def]
  note df_cos = field_vector_diff_chain_at [where g=cos, unfolded o_def]
  show  "(\<lambda>x. sin (f x)) C1_differentiable_on S" "(\<lambda>x. cos (f x)) C1_differentiable_on S"
    using assms
    unfolding C1_differentiable_on_def has_real_derivative_iff_has_vector_derivative [symmetric]
    apply auto
    by (rule contf continuous_intros df_sin df_cos derivative_intros exI conjI ballI | force)+
qed

lemma has_derivative_abs:
  fixes a::real
  assumes "a \<noteq> 0"
  shows "(abs has_derivative ((*) (sgn a))) (at a)"
proof -
  have [simp]: "norm = abs"
    using real_norm_def by force
  show ?thesis
    using has_derivative_norm [where 'a=real, simplified] assms
    by (simp add: mult_commute_abs)
qed

lemma abs_C1_differentiable [simp, derivative_intros]:
  fixes f :: "real \<Rightarrow> real"
  assumes f: "f C1_differentiable_on S" and "0 \<notin> f ` S"
  shows "(\<lambda>x. abs (f x)) C1_differentiable_on S"
proof -
  have contf: "continuous_on S f"
    by (simp add: C1_differentiable_imp_continuous_on f)
  note df = DERIV_chain [where f=abs and g=f, unfolded o_def]
  show ?thesis
    using assms
    unfolding C1_differentiable_on_def has_real_derivative_iff_has_vector_derivative [symmetric]
    apply clarify
    apply (rule df exI conjI ballI)+
      apply (force simp: has_field_derivative_def intro: has_derivative_abs continuous_intros contf)+
    done
qed

lemma C1_differentiable_on_pair [simp, derivative_intros]:
  fixes f :: "real \<Rightarrow> 'a::euclidean_space" and g :: "real \<Rightarrow> 'b::euclidean_space"
  assumes "f C1_differentiable_on S" "g C1_differentiable_on S"
  shows "(\<lambda>x. (f x, g x)) C1_differentiable_on S"
  using assms unfolding C1_differentiable_on_def
  apply safe
  apply (rename_tac A B)
  apply (intro exI ballI conjI)
   apply (rule_tac f'="A x" and g'="B x" in has_vector_derivative_pair_within)
  using  has_vector_derivative_componentwise_within
  by (blast intro: continuous_on_Pair)+

lemma piecewise_C1_differentiable_on_pair [simp, derivative_intros]:
  fixes f :: "real \<Rightarrow> 'a::euclidean_space" and g :: "real \<Rightarrow> 'b::euclidean_space"
  assumes "f piecewise_C1_differentiable_on S" "g piecewise_C1_differentiable_on S"
  shows "(\<lambda>x. (f x, g x)) piecewise_C1_differentiable_on S"
  using assms unfolding piecewise_C1_differentiable_on_def
  by (blast intro!: continuous_intros C1_differentiable_on_pair del: continuous_on_discrete
      intro: C1_differentiable_on_subset)

lemma test2:
  assumes s: "\<And>x. x \<in> {0..1} - s \<Longrightarrow> g differentiable at x"
    and fs: "finite s" and uv: "u \<in> {0..1}" "v \<in> {0..1}" "u \<le> v"
    and "x \<in> {0..1}" "x \<notin> (\<lambda>t. (v-u) *\<^sub>R t + u) -` s"
  shows "vector_derivative (\<lambda>x. g ((v-u) * x + u)) (at x within {0..1}) = (v-u) *\<^sub>R vector_derivative g (at ((v-u) * x + u) within{0..1})"
proof -
  have i:"(g has_vector_derivative vector_derivative g (at ((v - u) * x + u))) (at ((v-u) * x + u))"
    using assms s [of "(v - u) * x + u"] uv mult_left_le [of x "v-u"]
    by (auto simp:  vector_derivative_works)
  have ii:"((\<lambda>x. g ((v - u) * x + u)) has_vector_derivative (v - u) *\<^sub>R vector_derivative g (at ((v - u) * x + u))) (at x)"
    by (intro vector_diff_chain_at [simplified o_def] derivative_eq_intros | simp add: i)+
  have 0: "0 \<le> (v - u) * x + u"
    using assms uv by auto
  have 1: "(v - u) * x + u \<le> 1"
    using assms uv
    by simp (metis add.commute atLeastAtMost_iff atLeastatMost_empty_iff diff_ge_0_iff_ge empty_iff le_diff_eq mult_left_le)
  have iii: "vector_derivative g (at ((v - u) * x + u) within {0..1}) = vector_derivative g (at ((v - u) * x + u))"
    using Derivative.vector_derivative_at_within_ivl[OF i, of "0" "1", OF 0 1]
    by auto
  have iv: "vector_derivative (\<lambda>x. g ((v - u) * x + u)) (at x within {0..1}) = (v - u) *\<^sub>R vector_derivative g (at ((v - u) * x + u))"
    using Derivative.vector_derivative_at_within_ivl[OF ii, of "0" "1"] assms
    by auto
  show ?thesis
    using iii iv by auto
qed

lemma C1_differentiable_on_components:
  assumes "\<And>i. i \<in> Basis \<Longrightarrow> (\<lambda>x. f x \<bullet> i) C1_differentiable_on s"
  shows "f C1_differentiable_on s"
proof (clarsimp simp add: C1_differentiable_on_def has_vector_derivative_def)
  have *:"\<forall>f i x. x *\<^sub>R (f \<bullet> i) = (x *\<^sub>R f) \<bullet> i" by auto
  have "\<exists>f'. \<forall>i\<in>Basis. \<forall>x\<in>s. ((\<lambda>x. f x \<bullet> i) has_derivative (\<lambda>z. z *\<^sub>R f' x \<bullet> i)) (at x) \<and> continuous_on s f'"
    using assms lambda_skolem_euclidean[of "\<lambda>i D. (\<forall>x\<in>s. ((\<lambda>x. f x \<bullet> i) has_derivative (\<lambda>z. z *\<^sub>R D x)) (at x)) \<and> continuous_on s D"]
    apply (simp only: C1_differentiable_on_def has_vector_derivative_def *)
    using continuous_on_componentwise[of "s"]
    by metis
  then obtain f' where f': "\<forall>i\<in>Basis. \<forall>x\<in>s. ((\<lambda>x. f x \<bullet> i) has_derivative (\<lambda>z. z *\<^sub>R f' x \<bullet> i)) (at x) \<and> continuous_on s f'"
    by auto
  then have 0: "(\<forall>x\<in>s. (f has_derivative (\<lambda>z. z *\<^sub>R f' x)) (at x)) \<and> continuous_on s f'"
    using f' has_derivative_componentwise_within[of "f", where S= UNIV]
    by auto
  then show "\<exists>D. (\<forall>x\<in>s. (f has_derivative (\<lambda>z. z *\<^sub>R D x)) (at x)) \<and> continuous_on s D" by metis
qed

lemma piecewise_C1_differentiable_on_components:
  assumes "finite t"
    "\<And>i. i \<in> Basis \<Longrightarrow> (\<lambda>x. f x \<bullet> i) C1_differentiable_on s - t"
    "\<And>i. i \<in> Basis \<Longrightarrow> continuous_on s (\<lambda>x. f x \<bullet> i)"
  shows "f piecewise_C1_differentiable_on s"
  using C1_differentiable_on_components assms continuous_on_componentwise piecewise_C1_differentiable_on_def by blast

lemma all_components_smooth_one_pw_smooth_is_pw_smooth:
  assumes "\<And>i. i \<in> Basis - {j} \<Longrightarrow> (\<lambda>x. f x \<bullet> i) C1_differentiable_on s"
  assumes "(\<lambda>x. f x \<bullet> j) piecewise_C1_differentiable_on s"
  shows "f piecewise_C1_differentiable_on s"
proof -
  have is_cont: "\<forall>i\<in>Basis. continuous_on s (\<lambda>x. f x \<bullet> i)"
    using assms C1_differentiable_imp_continuous_on piecewise_C1_differentiable_on_def
    by fastforce
  obtain t where t:"(finite t \<and> (\<lambda>x. f x \<bullet> j) C1_differentiable_on s - t)" using assms(2) piecewise_C1_differentiable_on_def by auto
  show ?thesis
    using piecewise_C1_differentiable_on_components[where ?f = "f"]
    using assms(2) piecewise_C1_differentiable_on_def
      C1_differentiable_on_subset[OF assms(1) Diff_subset, where ?B1 ="t"] t is_cont
    by fastforce
qed

lemma derivative_component_fun_component:
  fixes i::"'a::euclidean_space"
  assumes "f differentiable (at x)"
  shows "((vector_derivative f (at x)) \<bullet> i) = ((vector_derivative (\<lambda>x. (f x) \<bullet> i) (at x)) )"
proof -
  have "((\<lambda>x. f x \<bullet> i) has_vector_derivative vector_derivative f (at x) \<bullet> i) (at x)"
    using assms and bounded_linear.has_vector_derivative[of "(\<lambda>x. x \<bullet> i)" "f" "(vector_derivative f (at x))" "(at x)"] and
      bounded_linear_inner_left[of "i"] and vector_derivative_works[of "f" "(at x)"]
    by blast
  then show "((vector_derivative f (at x)) \<bullet> i) = ((vector_derivative (\<lambda>x. (f x) \<bullet> i) (at x)) )"
    using vector_derivative_works[of "(\<lambda>x. (f x) \<bullet> i)" "(at x)"] and
      differentiableI_vector[of "(\<lambda>x. (f x) \<bullet> i)" "(vector_derivative f (at x) \<bullet> i)" "(at x)"] and
      Derivative.vector_derivative_at
    by force
qed

lemma gamma_deriv_at_within:
  assumes a_leq_b: "a < b"  and
    x_within_bounds: "x \<in> {a..b}" and
    gamma_differentiable: "\<forall>x \<in> {a .. b}. \<gamma> differentiable at x"
  shows  "vector_derivative \<gamma> (at x within {a..b}) =  vector_derivative \<gamma> (at x)"
  using Derivative.vector_derivative_at_within_ivl[of "\<gamma>" "vector_derivative \<gamma> (at x)" "x" "a" "b"]
    gamma_differentiable x_within_bounds a_leq_b
  by (auto simp add: vector_derivative_works)

lemma islimpt_diff_finite:
  assumes "finite (t::'a::t1_space set)"
  shows "x islimpt s - t = x islimpt s"
proof-
  have iii: "s - t = s - (t \<inter> s)" by auto
  have "(t \<inter> s) \<subseteq> s" by auto
  have ii:"finite (t \<inter> s)" using assms(1) by auto
  have i: "(t \<inter> s) \<union> (s - (t \<inter> s)) = ( s)"
    using assms by auto
  then have "x islimpt s - (t \<inter> s) = x islimpt s"
    using islimpt_Un_finite[OF ii,where ?t = "s - (t \<inter> s)"] i assms(1)
    by force
  then show ?thesis using iii by auto
qed

lemma ivl_limpt_diff:
  assumes "finite s" "a < b"  "(x::real) \<in> {a..b} - s"
  shows "x islimpt {a..b} - s"
proof-
  have "x islimpt {a..b}"
  proof (cases "x \<in>{a,b}")
    have i: "finite {a,b}" and ii:  "{a, b} \<union> {a<..<b} = {a..b}" using assms by auto
    assume "x \<in>{a,b}"
    then show ?thesis
      using islimpt_Un_finite[OF i, where ?t= "{a<..<b}"]
      by (metis assms(2) empty_iff ii insert_iff islimpt_greaterThanLessThan1 islimpt_greaterThanLessThan2)
  next
    assume "x \<notin>{a,b}"
    then show "x islimpt {a..b}" using assms by auto
  qed
  then show "x islimpt {a..b} - s" using islimpt_diff_finite[OF assms(1)] assms
    by fastforce
qed

lemma ivl_closure_diff_del:
  assumes "finite s" "a < b"  "(x::real) \<in> {a..b} - s"
  shows "x \<in> closure (({a..b} - s) - {x})"
  using ivl_limpt_diff islimpt_in_closure assms by blast

lemma ivl_not_trivial_limit_within:
  assumes "finite s"
    "a < b"
    "(x::real) \<in> {a..b} - s"
  shows "at x within {a..b} - s \<noteq> bot"
  using assms ivl_closure_diff_del not_trivial_limit_within
  by blast

lemma vector_derivative_at_within_non_trivial_limit:
  "at x within s \<noteq> bot \<and> (f has_vector_derivative f') (at x) \<Longrightarrow>
     vector_derivative f (at x within s) = f'"
  using has_vector_derivative_at_within vector_derivative_within by fastforce

lemma vector_derivative_at_within_ivl_diff:
  "finite s \<and> a < b \<and> (x::real) \<in> {a..b} - s \<and> (f has_vector_derivative f') (at x) \<Longrightarrow>
     vector_derivative f (at x within {a..b} - s) = f'"
  using vector_derivative_at_within_non_trivial_limit ivl_not_trivial_limit_within by fastforce

lemma gamma_deriv_at_within_diff:
  assumes a_leq_b: "a < b"  and
    x_within_bounds: "x \<in> {a..b} - s" and
    gamma_differentiable: "\<forall>x \<in> {a .. b} - s. \<gamma> differentiable at x" and
    s_subset: "s \<subseteq> {a..b}" and
    finite_s: "finite s"
  shows "vector_derivative \<gamma> (at x within {a..b} - s)
                           =  vector_derivative \<gamma> (at x)"
  using vector_derivative_at_within_ivl_diff [of "s" "a" "b" "x" "\<gamma>" "vector_derivative \<gamma> (at x)"]
    gamma_differentiable
    x_within_bounds a_leq_b s_subset finite_s
  by (auto simp add: vector_derivative_works)

lemma gamma_deriv_at_within_gen:
  assumes a_leq_b: "a < b"  and
    x_within_bounds: "x \<in> s" and
    s_subset: "s \<subseteq> {a..b}" and
    gamma_differentiable: "\<forall>x \<in> s. \<gamma> differentiable at x"
  shows "vector_derivative \<gamma> (at x within ({a..b})) =  vector_derivative \<gamma> (at x)"
  using Derivative.vector_derivative_at_within_ivl[of "\<gamma>" "vector_derivative \<gamma> (at x)" "x" "a" "b"]
    gamma_differentiable  x_within_bounds a_leq_b s_subset
  by (auto simp add: vector_derivative_works)

lemma derivative_component_fun_component_at_within_gen:
  assumes gamma_differentiable: "\<forall>x \<in> s. \<gamma> differentiable at x" and s_subset: "s \<subseteq> {0..1}"
  shows "\<forall>x \<in> s. vector_derivative (\<lambda>x. \<gamma> x) (at x within {0..1}) \<bullet> (i::'a:: euclidean_space)
           =  vector_derivative (\<lambda>x. \<gamma> x \<bullet> i) (at x within {0..1})"
proof -
  have gamma_i_component_smooth:
    "\<forall>x \<in> s. (\<lambda>x. \<gamma> x \<bullet> i) differentiable at x"
    using gamma_differentiable
    by auto
  show "\<forall>x \<in> s. vector_derivative (\<lambda>x. \<gamma> x) (at x within {0..1}) \<bullet> i
                                  =  vector_derivative (\<lambda>x. \<gamma> x \<bullet> i) (at x within {0..1})"
  proof
    fix x::real
    assume x_within_bounds: "x \<in> s"
    have gamma_deriv_at_within:
        "vector_derivative (\<lambda>x. \<gamma> x) (at x within {0..1}) = vector_derivative (\<lambda>x. \<gamma> x) (at x)"
      using gamma_deriv_at_within_gen[of "0" "1"] x_within_bounds
        gamma_differentiable s_subset
      by (auto simp add: vector_derivative_works)
    then have gamma_component_deriv_at_within:
      "vector_derivative (\<lambda>x. \<gamma> x \<bullet> i) (at x)
       = vector_derivative (\<lambda>x. \<gamma> x \<bullet> i) (at x within {0..1})"
      using gamma_deriv_at_within_gen[of "0" "1", where \<gamma> = "(\<lambda>x. \<gamma> x \<bullet> i)"] x_within_bounds
        gamma_i_component_smooth s_subset
      by (auto simp add: vector_derivative_works)
    have gamma_component_deriv_eq_gamma_deriv_component:
      "vector_derivative (\<lambda>x. \<gamma> x \<bullet> i) (at x) = vector_derivative (\<lambda>x. \<gamma> x) (at x) \<bullet> i"
      using derivative_component_fun_component[of "\<gamma>" "x" "i"] gamma_differentiable x_within_bounds
      by auto
    show "vector_derivative \<gamma> (at x within {0..1}) \<bullet> i = vector_derivative (\<lambda>x. \<gamma> x \<bullet> i) (at x within {0..1})"
      using gamma_component_deriv_eq_gamma_deriv_component gamma_component_deriv_at_within gamma_deriv_at_within
      by auto
  qed
qed

lemma derivative_component_fun_component_at_within:
  assumes gamma_differentiable: "\<forall>x \<in> {0 .. 1}. \<gamma> differentiable at x"
  shows "\<forall>x \<in> {0..1}. vector_derivative (\<lambda>x. \<gamma> x) (at x within {0..1}) \<bullet> (i::'a:: euclidean_space)
                                       =  vector_derivative (\<lambda>x. \<gamma> x \<bullet> i) (at x within {0..1})"
proof -
  have gamma_i_component_smooth:
    "\<forall>x \<in> {0 .. 1}. (\<lambda>x. \<gamma> x \<bullet> i) differentiable at x"
    using gamma_differentiable by auto
  show "\<forall>x \<in> {0..1}. vector_derivative (\<lambda>x. \<gamma> x) (at x within {0..1}) \<bullet> i
                                  =  vector_derivative (\<lambda>x. \<gamma> x \<bullet> i) (at x within {0..1})"
  proof
    fix x::real
    assume x_within_bounds: "x \<in> {0..1}"
    have gamma_deriv_at_within:
      "vector_derivative (\<lambda>x. \<gamma> x) (at x within {0..1}) =  vector_derivative (\<lambda>x. \<gamma> x) (at x)"
      using gamma_deriv_at_within[of "0" "1"] x_within_bounds
        gamma_differentiable
      by (auto simp add: vector_derivative_works)
    have gamma_component_deriv_at_within:
      "vector_derivative (\<lambda>x. \<gamma> x \<bullet> i) (at x) = vector_derivative (\<lambda>x. \<gamma> x \<bullet> i) (at x within {0..1})"
      using Derivative.vector_derivative_at_within_ivl[of "(\<lambda>x. (\<gamma> x) \<bullet> i)" "vector_derivative (\<lambda>x. (\<gamma> x)  \<bullet> i) (at x)" "x" "0" "1"]
        has_vector_derivative_at_within[of "(\<lambda>x. \<gamma> x \<bullet> i)" "vector_derivative (\<lambda>x. \<gamma> x \<bullet> i) (at x)" "x" "{0..1}"]
        gamma_i_component_smooth x_within_bounds
      by (simp add: vector_derivative_works)
    have gamma_component_deriv_eq_gamma_deriv_component:
      "vector_derivative (\<lambda>x. \<gamma> x \<bullet> i) (at x) = vector_derivative (\<lambda>x. \<gamma> x) (at x) \<bullet> i"
      using derivative_component_fun_component[of "\<gamma>" "x" "i"] gamma_differentiable x_within_bounds
      by auto
    show "vector_derivative \<gamma> (at x within {0..1}) \<bullet> i = vector_derivative (\<lambda>x. \<gamma> x \<bullet> i) (at x within {0..1})"
      using gamma_component_deriv_eq_gamma_deriv_component gamma_component_deriv_at_within gamma_deriv_at_within
      by auto
  qed
qed

lemma straight_path_diffrentiable_x:
  fixes b :: "real" and y1 ::"real"
  assumes gamma_def: "\<gamma> = (\<lambda>x. (b, y2 + y1 * x))"
  shows "\<forall>x. \<gamma> differentiable at x"
  unfolding gamma_def differentiable_def
  by (fast intro!: derivative_intros)

lemma straight_path_diffrentiable_y:
  fixes b :: "real" and
    y1 y2 ::"real"
  assumes gamma_def: "\<gamma> = (\<lambda>x. (y2 + y1 * x , b))"
  shows "\<forall>x. \<gamma> differentiable at x"
  unfolding gamma_def differentiable_def
  by (fast intro!: derivative_intros)

lemma piecewise_C1_differentiable_on_imp_continuous_on:
  assumes "f piecewise_C1_differentiable_on s"
  shows "continuous_on s f"
  using assms
  by (auto simp add: piecewise_C1_differentiable_on_def)

lemma boring_lemma1:
  fixes f :: "real\<Rightarrow>real"
  assumes "(f has_vector_derivative D) (at x)"
  shows "((\<lambda>x. (f x, 0)) has_vector_derivative ((D,0::real))) (at x)"
proof-
  have *: "((\<lambda>x. (f x) *\<^sub>R (1,0)) has_vector_derivative (D *\<^sub>R (1,0))) (at x)"
    using bounded_linear.has_vector_derivative[OF Real_Vector_Spaces.bounded_linear_scaleR_left assms(1),
        of "(1,0)"] by auto
  have "((\<lambda>x. (f x) *\<^sub>R (1,0)) has_vector_derivative (D,0)) (at x)"
  proof -
    have "(D, 0::'a) = D *\<^sub>R (1, 0)"
      by simp
    then show ?thesis
      by (metis (no_types) *)
  qed
  then show ?thesis by auto
qed

lemma boring_lemma2:
  fixes f :: "real\<Rightarrow>real"
  assumes "(f has_vector_derivative D) (at x)"
  shows "((\<lambda>x. (0, f x)) has_vector_derivative (0, D)) (at x)"
proof-
  have *: "((\<lambda>x. (f x) *\<^sub>R (0,1)) has_vector_derivative (D *\<^sub>R (0,1))) (at x)"
    using bounded_linear.has_vector_derivative[OF Real_Vector_Spaces.bounded_linear_scaleR_left assms(1),
        of "(0,1)"] by auto
  then have "((\<lambda>x. (f x) *\<^sub>R (0,1)) has_vector_derivative ((0,D))) (at x)"
    using scaleR_Pair Real_Vector_Spaces.real_scaleR_def
  proof -
    have "(0::'b, D) = D *\<^sub>R (0, 1)"
      by auto
    then show ?thesis
      by (metis (no_types) *)
  qed
  then show ?thesis by auto
qed

lemma pair_prod_smooth_pw_smooth:
  assumes "(f::real\<Rightarrow>real) C1_differentiable_on s" "(g::real\<Rightarrow>real) piecewise_C1_differentiable_on s"
  shows "(\<lambda>x. (f x, g x)) piecewise_C1_differentiable_on s"
proof -
  have f_cont: "continuous_on s f"
    using assms(1) C1_differentiable_imp_continuous_on
    by fastforce
  have g_cont: "continuous_on s g"
    using assms(2)  by (auto simp add: piecewise_C1_differentiable_on_def)
  obtain t where t:"(finite t \<and> g C1_differentiable_on s - t)" using assms(2) piecewise_C1_differentiable_on_def by auto
  show ?thesis
    using piecewise_C1_differentiable_on_components[where ?f = "(\<lambda>x. (f x, g x))"]
    apply (simp add: real_pair_basis)
    using assms(2) piecewise_C1_differentiable_on_def
      C1_differentiable_on_subset[OF assms(1) Diff_subset, where ?B1 ="t"] t
      f_cont g_cont
    by fastforce
qed

lemma scale_shift_smooth:
  shows "(\<lambda>x. a + b * x) C1_differentiable_on s"
proof -
  show "(\<lambda>x. a + b * x) C1_differentiable_on s"
    using C1_differentiable_on_mult C1_differentiable_on_add C1_differentiable_on_const
          C1_differentiable_on_ident by auto
qed

lemma open_diff:
  assumes "finite (t::'a::t1_space set)"
    "open (s::'a set)"
  shows "open (s -t)"
  using assms
proof(induction "t")
  show "open s \<Longrightarrow> open (s - {})" by auto
next
  fix x::"'a::t1_space"
  fix F::"'a::t1_space set"
  assume step: "finite F " " x \<notin> F" "open s"
  then have i: "(s - insert x F) = (s - F) - {x}" by auto
  assume ind_hyp: " (open s \<Longrightarrow> open (s - F))"
  show "open (s - insert x F)"
    apply (simp only: i)
    using open_delete[of "s -F"] ind_hyp[OF step(3)] by auto
qed

lemma has_derivative_transform_within:
  assumes "0 < d"
    and "x \<in> s"
    and "\<forall>x'\<in>s. dist x' x < d \<longrightarrow> f x' = g x'"
    and "(f has_derivative f') (at x within s)"
  shows "(g has_derivative f') (at x within s)"
  using assms
  unfolding has_derivative_within
  by (force simp add: intro: Lim_transform_within)

lemma has_derivative_transform_within_ivl:
  assumes "(0::real) < b"
    and     "\<forall>x\<in>{a..b} -s. f x = g x"
    and "x \<in> {a..b} -s"
    and "(f has_derivative f') (at x within {a..b} - s)"
  shows "(g has_derivative f') (at x within {a..b} - s)"
  using has_derivative_transform_within[of "b" "x" "{a..b} - s"] assms
  by auto

lemma has_vector_derivative_transform_within_ivl:
  assumes "(0::real) < b"
    and     "\<forall>x\<in>{a..b} -s . f x = g x"
    and "x \<in> {a..b} - s"
    and "(f has_vector_derivative f') (at x within {a..b} - s)"
  shows "(g has_vector_derivative f') (at x within {a..b} - s)"
  using assms has_derivative_transform_within_ivl
  apply (auto simp add: has_vector_derivative_def)
  by blast

lemma has_derivative_transform_at:
  assumes "0 < d"
    and "\<forall>x'. dist x' x < d \<longrightarrow> f x' = g x'"
    and "(f has_derivative f') (at x)"
  shows "(g has_derivative f') (at x)"
  using has_derivative_transform_within [of d x UNIV f g f'] assms
  by simp

lemma has_vector_derivative_transform_at:
  assumes "0 < d"
    and "\<forall>x'. dist x' x < d \<longrightarrow> f x' = g x'"
    and "(f has_vector_derivative f') (at x)"
  shows "(g has_vector_derivative f') (at x)"
  using assms
  unfolding has_vector_derivative_def
  by (rule has_derivative_transform_at)

lemma C1_diff_components_2:
  assumes "b \<in> Basis"
  assumes "f C1_differentiable_on s"
  shows "(\<lambda>x. f x \<bullet> b) C1_differentiable_on s"
proof -
  obtain D where D:"(\<forall>x\<in>s. (f has_derivative (\<lambda>z. z *\<^sub>R D x)) (at x))" "continuous_on s D"
    using assms(2) by (fastforce simp add: C1_differentiable_on_def has_vector_derivative_def)
  show ?thesis
  proof (simp add: C1_differentiable_on_def has_vector_derivative_def, intro exI conjI)
    show "continuous_on s (\<lambda>x. D x \<bullet> b)" using D continuous_on_componentwise assms(1) by fastforce
    show "(\<forall>x\<in>s. ((\<lambda>x. f x \<bullet> b) has_derivative (\<lambda>y. y * (\<lambda>x. D x \<bullet> b) x)) (at x))"
      using has_derivative_inner_left D(1) by fastforce
  qed
qed

lemma eq_smooth:
  assumes "0 < d"
    "\<forall>x\<in>s. \<forall>y. dist x y < d \<longrightarrow> f y = g y" (*This crappy condition cannot be loosened :( *)
    "f C1_differentiable_on s"
  shows "g C1_differentiable_on s"
proof (simp add: C1_differentiable_on_def)
  obtain D where D: "(\<forall>x\<in>s. (f has_vector_derivative D x) (at x)) \<and> continuous_on s D"
    using assms by (auto simp add: C1_differentiable_on_def)
  then have f: "(\<forall>x\<in>s. (g has_vector_derivative D x) (at x))"
    using assms(1-2)
    by (metis dist_commute has_vector_derivative_transform_at)
  have "(\<forall>x\<in>s. (g has_vector_derivative D x) (at x)) \<and> continuous_on s D" using D f by auto
  then show "\<exists>D. (\<forall>x\<in>s. (g has_vector_derivative D x) (at x)) \<and> continuous_on s D" by metis
qed

lemma eq_pw_smooth:
  assumes "0 < d"
    "\<forall>x\<in>s. \<forall>y. dist x y < d \<longrightarrow> f y = g y" (*This crappy condition cannot be loosened :( *)
    "\<forall>x\<in>s. f x = g x"
    "f piecewise_C1_differentiable_on s"
  shows "g piecewise_C1_differentiable_on s"
proof (simp add: piecewise_C1_differentiable_on_def)
  have g_cont: "continuous_on s g" using assms piecewise_C1_differentiable_const
    by (simp add: piecewise_C1_differentiable_on_def)
  obtain t where t: "finite t \<and> f C1_differentiable_on s - t"
    using assms by (auto simp add: piecewise_C1_differentiable_on_def)
  then have "g C1_differentiable_on s - t" using assms eq_smooth by blast
  then show "continuous_on s g \<and> (\<exists>t. finite t \<and> g C1_differentiable_on s - t)"
    using t g_cont by metis
qed

lemma scale_piecewise_C1_differentiable_on:
  assumes "f piecewise_C1_differentiable_on s"
  shows "(\<lambda>x. (c::real) * (f x)) piecewise_C1_differentiable_on s"
proof (simp add: piecewise_C1_differentiable_on_def, intro conjI)
  show "continuous_on s (\<lambda>x. c * f x)"
    using assms continuous_on_mult_left
    by (auto simp add: piecewise_C1_differentiable_on_def)
  show "\<exists>t. finite t \<and> (\<lambda>x. c * f x) C1_differentiable_on s - t"
    using assms continuous_on_mult_left
    by (auto simp add: piecewise_C1_differentiable_on_def)
qed

lemma eq_smooth_gen:
  assumes "f C1_differentiable_on s"
    "\<forall>x. f x = g x"
  shows "g C1_differentiable_on s"
  using assms unfolding C1_differentiable_on_def
  by (metis (no_types, lifting) has_vector_derivative_weaken UNIV_I top_greatest)

lemma subpath_compose:
  shows "(subpath a b \<gamma>) = \<gamma> o (\<lambda>x.  (b - a) * x + a)"
  by (auto simp add: subpath_def)

lemma subpath_smooth:
  assumes "\<gamma> C1_differentiable_on {0..1}" "0 \<le> a" "a < b" "b \<le> 1"
  shows "(subpath a b \<gamma>) C1_differentiable_on {0..1}"
proof-
  have "\<gamma> C1_differentiable_on {a..b}"
    apply (rule C1_differentiable_on_subset)
    using assms by auto
  then have "\<gamma> C1_differentiable_on (\<lambda>x. (b - a) * x + a) ` {0..1}"
    using \<open>a < b\<close> closed_segment_eq_real_ivl closed_segment_real_eq by auto
  moreover have "finite ({0..1} \<inter> (\<lambda>x. (b - a) * x + a) -` {x})" for x
  proof -
    have "((\<lambda>x. (b - a) * x + a) -` {x}) = {(x -a) /(b-a)}"
      using assms by (auto simp add: divide_simps)
    then show ?thesis
      by auto
  qed
  ultimately show ?thesis
    by (force simp add: subpath_compose intro: C1_differentiable_compose derivative_intros)
qed

lemma has_vector_derivative_divide[derivative_intros]:
  fixes a :: "'a::real_normed_field"
  shows "(f has_vector_derivative x) F \<Longrightarrow> ((\<lambda>x. f x / a) has_vector_derivative (x / a)) F"
  unfolding divide_inverse by (fact has_vector_derivative_mult_left)

end


(*  Title:      HOL/Proofs/Extraction/QuotRem.thy
    Author:     Stefan Berghofer, TU Muenchen
*)

section \<open>Quotient and remainder\<close>

theory QuotRem
imports Util "HOL-Library.Realizers"
begin

text \<open>Derivation of quotient and remainder using program extraction.\<close>

theorem division: "\<exists>r q. a = Suc b * q + r \<and> r \<le> b"
proof (induct a)
  case 0
  have "0 = Suc b * 0 + 0 \<and> 0 \<le> b" by simp
  then show ?case by iprover
next
  case (Suc a)
  then obtain r q where I: "a = Suc b * q + r" and "r \<le> b" by iprover
  from nat_eq_dec show ?case
  proof
    assume "r = b"
    with I have "Suc a = Suc b * (Suc q) + 0 \<and> 0 \<le> b" by simp
    then show ?case by iprover
  next
    assume "r \<noteq> b"
    with \<open>r \<le> b\<close> have "r < b" by (simp add: order_less_le)
    with I have "Suc a = Suc b * q + (Suc r) \<and> (Suc r) \<le> b" by simp
    then show ?case by iprover
  qed
qed

extract division

text \<open>
  The program extracted from the above proof looks as follows
  @{thm [display] division_def [no_vars]}
  The corresponding correctness theorem is
  @{thm [display] division_correctness [no_vars]}
\<close>

lemma "division 9 2 = (0, 3)" by eval

end


theory HamiltonianCycle
  imports Main tsp.Misc
begin

section \<open>Hamiltonian cycle\<close>
definition "is_hc E H \<equiv> (H \<noteq> [] \<longrightarrow> (\<exists>v. walk_betw E v H v)) \<and> set (tl H) = Vs E \<and> distinct (tl H)"

lemma is_hcI:
  assumes "H \<noteq> [] \<Longrightarrow> (\<exists>v. walk_betw E v H v)" "Vs E = set (tl H)" "distinct (tl H)"
  shows "is_hc E H"
  unfolding is_hc_def using assms by auto

lemma is_hcE:
  assumes "is_hc E H"
  shows "H \<noteq> [] \<Longrightarrow> (\<exists>v. walk_betw E v H v)" "Vs E = set (tl H)" "distinct (tl H)"
  using assms[unfolded is_hc_def] by auto

lemma is_hcE_nil:
  assumes "is_hc E []"
  shows "Vs E = {}"
  using assms[unfolded is_hc_def] by auto

lemma is_hcE_nonnil:
  assumes "is_hc E H" "H \<noteq> []"
  obtains v where "walk_betw E v H v" "set (tl H) = Vs E" "distinct (tl H)"
  using assms[unfolded is_hc_def] by auto

lemma is_hc_path: "is_hc E H \<Longrightarrow> path E H"
  by (cases H) (auto intro: path.intros elim: is_hcE_nonnil)

lemma hc_vs_set:
  assumes "is_hc E H"
  shows "set H = Vs E"
  using assms
proof cases
  assume "H \<noteq> []"
  hence "hd H \<in> set (tl H)"
    using assms[unfolded is_hc_def walk_betw_def] by (metis hd_in_set mem_path_Vs)
  hence "set H = set (tl H)"
    using hd_Cons_tl[OF \<open>H \<noteq> []\<close>] insert_absorb[of "hd H" "set (tl H)"] set_simps by metis
  also have "... = Vs E"
    using assms \<open>H \<noteq> []\<close> by (auto elim: is_hcE_nonnil[of E H])
  finally show ?thesis .
qed (auto simp: is_hcE_nil)

lemma is_hcI_nil: "Vs E = {} \<Longrightarrow> is_hc E []"
  unfolding is_hc_def by auto

lemma hc_length:
  assumes "is_hc E H" "H \<noteq> []"
  shows "length H = card (Vs E) + 1"
proof -
  have "length H = 1 + length (tl H)"
    using assms hd_Cons_tl[of H] by auto
  also have "... = card (Vs E) + 1"
    using assms distinct_card[of "tl H"] by (auto elim: is_hcE_nonnil)
  finally show ?thesis .
qed

lemma hc_edges_subset:
  assumes "is_hc E H"
  shows "set (edges_of_path H) \<subseteq> E"
proof cases
  assume "H \<noteq> []"
  then obtain v where "walk_betw E v H v"
    using assms by (auto elim: is_hcE_nonnil)
  thus ?thesis
    using walk_edges_subset by fastforce
qed auto

lemma hc_walk_betw1:
  assumes "is_hc E H" "i\<^sub>u < i\<^sub>v" "i\<^sub>v < length H"
  shows "walk_betw E (H ! i\<^sub>u) (drop i\<^sub>u (take (i\<^sub>v+1) H)) (H ! i\<^sub>v)" (is "walk_betw E ?u ?P ?v")
proof (rule walk_subset[OF _ walk_on_path])
  show "i\<^sub>u < i\<^sub>v" "i\<^sub>v < length H"
    using assms by auto
  show "path E H"
    using assms by (auto elim: is_hcE_nonnil walk_between_nonempty_path)
  thus "set (edges_of_path H) \<subseteq> E"
    using path_edges_subset by auto
qed

context graph_abs
begin

lemma hc_nil_iff2:
  assumes hc: "is_hc E H"
  shows "E = {} \<longleftrightarrow> H = []"
  using hc_vs_set[OF hc] Vs_empty_iff[OF graph] by auto

lemma hc_non_nil_length_gr2:
  assumes "is_hc E H" "H \<noteq> []"
  shows "length H > 2"
proof (rule ccontr)
  assume "\<not> length H > 2"
  hence "card (Vs E) < 2"
    using assms card_length[of "tl H"] by (auto simp: is_hcE)
  thus "False"
    using assms hc_nil_iff2[of H] card_Vs_E_ge2 by auto
qed

lemma walk_betw_vv_set_tl_eq:
  assumes "H \<noteq> []" "walk_betw E v H v" "set H = Vs E"
  shows "set (tl H) = Vs E"
proof -
  have "E \<noteq> {}"
    using assms by (auto simp: Vs_def)
  hence "2 \<le> length H"
    using assms card_Vs_E_ge2 card_length[of H] by auto
  hence "hd H \<in> set (tl H)"
    using assms[unfolded walk_betw_def] last_in_set_tl[of H] by auto
  hence "set (tl H) = set H"
    using hd_Cons_tl[OF \<open>H \<noteq> []\<close>] insert_absorb[of "hd H" "set (tl H)"] set_simps by metis
  also have "... = Vs E"
    using assms by (auto elim: is_hcE_nonnil)
  finally show ?thesis .
qed (* TODO: simplify proof with \<open>Misc.set_tl_eq_set\<close> *)

lemma is_hcI_nonnil:
  "H \<noteq> [] \<Longrightarrow> walk_betw E v H v \<Longrightarrow> set H = Vs E \<Longrightarrow> distinct (tl H) \<Longrightarrow> is_hc E H"
  unfolding is_hc_def using walk_betw_vv_set_tl_eq by auto

lemma hc_nil_iff: "E = {} \<longleftrightarrow> is_hc E []"
proof -
  have "E = {} \<longleftrightarrow> path E [] \<and> set [] = Vs E"
    unfolding Vs_def using graph by force
  also have "... \<longleftrightarrow> is_hc E []"
    by (auto intro: is_hcI_nil simp: is_hcE_nil)
  finally show ?thesis .
qed

lemma hc_edges_nil: "is_hc E H \<Longrightarrow> edges_of_path H = [] \<Longrightarrow> H = []"
  using edges_of_path_nil hc_non_nil_length_gr2 by fastforce

lemma hc_edges_length:
  assumes "is_hc E H"
  shows "length (edges_of_path H) = card (Vs E)"
  using assms
proof (induction H)
  case Nil
  thus ?case
    using hc_nil_iff2[of "[]"] by (simp add: Vs_def)
next
  case (Cons v H)
  thus ?case
    apply (subst edges_of_path_length)
    apply (subst hc_length)
    apply auto
    done
qed

lemma is_hc_def2: "is_hc E H \<longleftrightarrow> (H \<noteq> [] \<longrightarrow> is_cycle E H) \<and> set (tl H) = Vs E \<and> distinct (tl H)"
  oops
(* TODO:
  Definition for \<open>is_hc\<close> with \<open>is_cycle\<close>.
  Does not hold! counterexample: graph with 2 vertices
*)

lemma hc_split:
  assumes "is_hc E H"
  obtains "H = []" | v P where "H = v#P @ [v]"
  using that
proof cases
  assume "H \<noteq> []"
  moreover hence "hd H = last H"
    using assms by (auto elim: is_hcE_nonnil simp: walk_between_nonempty_path)
  ultimately consider v where "H = [v]" | v P where "H = v#P @ [v]"
    using hd_last_eq_split[of H] by auto
  thus ?thesis
    using that hc_non_nil_length_gr2[OF assms \<open>H \<noteq> []\<close>] by cases auto
qed auto

lemma hc_distinct_butlast:
  assumes hc: "is_hc E H"
  shows "distinct (butlast H)"
  using hc_split[OF hc] assms by cases (auto elim: is_hcE_nonnil)

lemma hc_set_butlast:
  assumes hc: "is_hc E H" and "H \<noteq> []"
  shows "set (butlast H) = Vs E"
  using hc_split[OF hc] assms is_hcE_nonnil[OF hc] by cases auto

end

section \<open>Hamiltonian path\<close>
definition "is_hp E u P v \<equiv> walk_betw E u P v \<and> set P = Vs E \<and> distinct P"
(* TODO: connect definitions of Hamiltonian Path and Hamiltonian cycle. *)

lemma is_hpI:
  assumes "walk_betw E u P v" "set P = Vs E" "distinct P"
  shows "is_hp E u P v"
  unfolding is_hp_def using assms by auto

lemma is_hpE:
  assumes "is_hp E u P v"
  shows "walk_betw E u P v" "set P = Vs E" "distinct P"
  using assms[unfolded is_hp_def] by auto

lemma hp_subset: "E \<subseteq> E' \<Longrightarrow> Vs E = Vs E' \<Longrightarrow> is_hp E u P v \<Longrightarrow> is_hp E' u P v"
  unfolding is_hp_def using walk_subset by metis

lemma hp_rev: "is_hp E u P v \<Longrightarrow> is_hp E v (rev P) u"
  unfolding is_hp_def using walk_symmetric by fastforce

lemma hp_append:
  assumes "is_hp E\<^sub>1 u P\<^sub>1 v" "is_hp E\<^sub>2 w P\<^sub>2 x" "Vs E\<^sub>1 \<inter> Vs E\<^sub>2 = {}"
  shows "is_hp (insert {v,w} E\<^sub>1 \<union> E\<^sub>2) u (P\<^sub>1 @ P\<^sub>2) x"
proof (intro is_hpI)
  have walk1: "walk_betw E\<^sub>1 u P\<^sub>1 v" and vs1: "set P\<^sub>1 = Vs E\<^sub>1"
    using assms(1) by (elim is_hpE)+
  moreover hence "last P\<^sub>1 = v" "P\<^sub>1 \<noteq> []"
    by (auto elim: walk_between_nonempty_path)
  ultimately have "v \<in> Vs E\<^sub>1"
    using walk_in_Vs by auto

  have walk2: "walk_betw E\<^sub>2 w P\<^sub>2 x" and vs2: "set P\<^sub>2 = Vs E\<^sub>2"
    using assms(2) by (elim is_hpE)+
  moreover hence "hd P\<^sub>2 = w" "P\<^sub>2 \<noteq> []"
    by (auto elim: walk_between_nonempty_path)
  ultimately have [simp]: "w#tl P\<^sub>2 = P\<^sub>2" and "w \<in> Vs E\<^sub>2"
    using walk_in_Vs by auto

  have "Vs (insert {v,w} E\<^sub>1 \<union> E\<^sub>2) = Vs (E\<^sub>1 \<union> E\<^sub>2)"
    using \<open>v \<in> Vs E\<^sub>1\<close> \<open>w \<in> Vs E\<^sub>2\<close> by (auto simp: Vs_def)
  show "set (P\<^sub>1 @ P\<^sub>2) = Vs (insert {v,w} E\<^sub>1 \<union> E\<^sub>2)"
    apply (subst \<open>Vs (insert {v,w} E\<^sub>1 \<union> E\<^sub>2) = Vs (E\<^sub>1 \<union> E\<^sub>2)\<close>)
    apply (subst Vs_union)
    using vs1 vs2 apply auto
    done

  have "walk_betw (insert {v,w} E\<^sub>1 \<union> E\<^sub>2) u P\<^sub>1 v"
    apply (rule walk_subset[of E\<^sub>1])
    using walk1 apply auto
    done
  moreover have "walk_betw (insert {v,w} E\<^sub>1 \<union> E\<^sub>2) v [v,w] w"
    by (intro nonempty_path_walk_between) (auto intro: path.intros)
  ultimately have "walk_betw (insert {v,w} E\<^sub>1 \<union> E\<^sub>2) u (P\<^sub>1 @ tl [v,w]) w"
    by (rule walk_transitive)
  moreover have "walk_betw (insert {v,w} E\<^sub>1 \<union> E\<^sub>2) w P\<^sub>2 x"
    apply (rule walk_subset[of E\<^sub>2])
    using walk2 apply auto
    done
  ultimately have "walk_betw (insert {v,w} E\<^sub>1 \<union> E\<^sub>2) u ((P\<^sub>1 @ tl [v,w]) @ tl P\<^sub>2) x"
    by (rule walk_transitive)
  thus "walk_betw (insert {v,w} E\<^sub>1 \<union> E\<^sub>2) u ((P\<^sub>1 @ P\<^sub>2)) x"
    by auto

  have "set P\<^sub>1 \<inter> set P\<^sub>2 = {}"
    using vs1 vs2 assms(3) by auto
  moreover have "distinct P\<^sub>1" "distinct P\<^sub>2"
    using assms(1,2) by (auto elim: is_hpE)
  ultimately show "distinct (P\<^sub>1 @ P\<^sub>2)"
    by auto
qed (* TODO: clean up! *)

lemma hc_of_hp:
  assumes "is_hp E u P v" "{u,v} \<in> E"
  shows "is_hc E (v#P)" (is "is_hc E ?P'")
proof (intro is_hcI)
  have "walk_betw E u P v"
    using assms by (elim is_hpE)
  moreover have "walk_betw E v [v,u] u"
    using assms by (intro nonempty_path_walk_between) (auto simp: insert_commute)
  ultimately have "walk_betw E v (butlast [v,u] @ P) v"
    by (intro walk_transitive2)
  thus "?P' \<noteq> [] \<Longrightarrow> \<exists>w. walk_betw E w ?P' w"
    by auto

  have "set P = Vs E" "distinct P"
    using assms by (elim is_hpE)+
  thus "Vs E = set (tl ?P')" "distinct (tl ?P')"
    by auto
qed

end


section "Simple Examples"

theory Amortized_Examples
imports Amortized_Framework
begin

text\<open>
This theory applies the amortized analysis framework to a number
of simple classical examples.\<close>

subsection "Binary Counter"

locale Bin_Counter
begin

datatype op = Empty | Incr

fun arity :: "op \<Rightarrow> nat" where
"arity Empty = 0" |
"arity Incr = 1"

fun incr :: "bool list \<Rightarrow> bool list" where
"incr [] = [True]" |
"incr (False#bs) = True # bs" |
"incr (True#bs) = False # incr bs"

fun t\<^sub>i\<^sub>n\<^sub>c\<^sub>r :: "bool list \<Rightarrow> nat" where
"t\<^sub>i\<^sub>n\<^sub>c\<^sub>r [] = 1" |
"t\<^sub>i\<^sub>n\<^sub>c\<^sub>r (False#bs) = 1" |
"t\<^sub>i\<^sub>n\<^sub>c\<^sub>r (True#bs) = t\<^sub>i\<^sub>n\<^sub>c\<^sub>r bs + 1"

definition \<Phi> :: "bool list \<Rightarrow> real" where
"\<Phi> bs = length(filter id bs)"

lemma a_incr: "t\<^sub>i\<^sub>n\<^sub>c\<^sub>r bs + \<Phi>(incr bs) - \<Phi> bs = 2"
apply(induction bs rule: incr.induct)
apply (simp_all add: \<Phi>_def)
done

fun exec :: "op \<Rightarrow> bool list list \<Rightarrow> bool list" where
"exec Empty [] = []" |
"exec Incr [bs] = incr bs"

fun cost :: "op \<Rightarrow> bool list list \<Rightarrow> nat" where
"cost Empty _ = 1" |
"cost Incr [bs] = t\<^sub>i\<^sub>n\<^sub>c\<^sub>r bs"

interpretation Amortized
where exec = exec and arity = arity and inv = "\<lambda>_. True"
and cost = cost and \<Phi> = \<Phi> and U = "\<lambda>f _. case f of Empty \<Rightarrow> 1 | Incr \<Rightarrow> 2"
proof (standard, goal_cases)
  case 1 show ?case by simp
next
  case 2 show ?case by(simp add: \<Phi>_def)
next
  case 3 thus ?case using a_incr by(auto simp: \<Phi>_def split: op.split)
qed

end (* Bin_Counter *)

subsection "Stack with multipop"

locale Multipop
begin

datatype 'a op = Empty | Push 'a | Pop nat

fun arity :: "'a op \<Rightarrow> nat" where
"arity Empty = 0" |
"arity (Push _) = 1" |
"arity (Pop _) = 1"

fun exec :: "'a op \<Rightarrow> 'a list list \<Rightarrow> 'a list" where
"exec Empty [] = []" |
"exec (Push x) [xs] = x # xs" |
"exec (Pop n) [xs] = drop n xs"

fun cost :: "'a op \<Rightarrow> 'a list list \<Rightarrow> nat" where
"cost Empty _ = 1" |
"cost (Push x) _ = 1" |
"cost (Pop n) [xs] = min n (length xs)"

interpretation Amortized
where arity = arity and exec = exec and inv = "\<lambda>_. True"
and cost = cost and \<Phi> = "length"
and U = "\<lambda>f _. case f of Empty \<Rightarrow> 1 | Push _ \<Rightarrow> 2 | Pop _ \<Rightarrow> 0"
proof (standard, goal_cases)
  case 1 show ?case by simp
next
  case 2 thus ?case by simp
next
  case 3 thus ?case by (auto split: op.split)
qed

end (* Multipop *)

subsection "Dynamic tables: insert only"

locale Dyn_Tab1
begin

type_synonym tab = "nat \<times> nat"

datatype op = Empty | Ins

fun arity :: "op \<Rightarrow> nat" where
"arity Empty = 0" |
"arity Ins = 1"

fun exec :: "op \<Rightarrow> tab list \<Rightarrow> tab" where
"exec Empty [] = (0::nat,0::nat)" |
"exec Ins [(n,l)] = (n+1, if n<l then l else if l=0 then 1 else 2*l)"

fun cost :: "op \<Rightarrow> tab list \<Rightarrow> nat" where
"cost Empty _ = 1" |
"cost Ins [(n,l)] = (if n<l then 1 else n+1)"

interpretation Amortized
where exec = exec and arity = arity
and inv = "\<lambda>(n,l). if l=0 then n=0 else n \<le> l \<and> l < 2*n"
and cost = cost and \<Phi> = "\<lambda>(n,l). 2*n - l"
and U = "\<lambda>f _. case f of Empty \<Rightarrow> 1 | Ins \<Rightarrow> 3"
proof (standard, goal_cases)
  case (1 _ f) thus ?case by(cases f) (auto split: if_splits)
next
  case 2 thus ?case by(auto split: prod.splits)
next
  case 3 thus ?case by (auto split: op.split) linarith
qed

end (* Dyn_Tab1 *)

locale Dyn_Tab2 =
fixes a :: real
fixes c :: real
assumes c1[arith]: "c > 1"
assumes ac2: "a \<ge> c/(c - 1)"
begin

lemma ac: "a \<ge> 1/(c - 1)"
using ac2 by(simp add: field_simps)

lemma a0[arith]: "a>0"
proof-
  have "1/(c - 1) > 0" using ac by simp
  thus ?thesis by (metis ac dual_order.strict_trans1)
qed

definition "b = 1/(c - 1)"

lemma b0[arith]: "b > 0"
using ac by (simp add: b_def)

type_synonym tab = "nat \<times> nat"

datatype op = Empty | Ins

fun arity :: "op \<Rightarrow> nat" where
"arity Empty = 0" |
"arity Ins = 1"

fun "ins" :: "tab \<Rightarrow> tab" where
"ins(n,l) = (n+1, if n<l then l else if l=0 then 1 else nat(ceiling(c*l)))"

fun exec :: "op \<Rightarrow> tab list \<Rightarrow> tab" where
"exec Empty [] = (0::nat,0::nat)" |
"exec Ins [s] = ins s" |
"exec _ _ = (0,0)" (* otherwise fun goes wrong with odd error msg *)

fun cost :: "op \<Rightarrow> tab list \<Rightarrow> nat" where
"cost Empty _ = 1" |
"cost Ins [(n,l)] = (if n<l then 1 else n+1)"

fun \<Phi> :: "tab \<Rightarrow> real" where
"\<Phi>(n,l) = a*n - b*l"

interpretation Amortized
where exec = exec and arity = arity
and inv = "\<lambda>(n,l). if l=0 then n=0 else n \<le> l \<and> (b/a)*l \<le> n"
and cost = cost and \<Phi> = \<Phi> and U = "\<lambda>f _. case f of Empty \<Rightarrow> 1 | Ins \<Rightarrow> a + 1"
proof (standard, goal_cases)
  case (1 ss f)
  show ?case
  proof (cases f)
    case Empty thus ?thesis using 1 by auto
  next
    case [simp]: Ins
    obtain n l where [simp]: "ss = [(n,l)]" using 1(2) by (auto)
    show ?thesis
    proof cases
      assume "l=0" thus ?thesis using 1 ac
        by (simp add: b_def field_simps)
    next
      assume "l\<noteq>0"
      show ?thesis
      proof cases
        assume "n<l"
        thus ?thesis using 1 by(simp add: algebra_simps)
      next
        assume "\<not> n<l"
        hence [simp]: "n=l" using 1 \<open>l\<noteq>0\<close> by simp
        have 1: "(b/a) * ceiling(c * l) \<le> real l + 1"
        proof-
          have "(b/a) * ceiling(c * l) = ceiling(c * l)/(a*(c - 1))"
            by(simp add: b_def)
          also have "ceiling(c * l) \<le> c*l + 1" by simp
          also have "\<dots> \<le> c*(real l+1)" by (simp add: algebra_simps)
          also have "\<dots> / (a*(c - 1)) = (c/(a*(c - 1))) * (real l + 1)" by simp
          also have "c/(a*(c - 1)) \<le> 1" using ac2 by (simp add: field_simps)
          finally show ?thesis by (simp add: divide_right_mono)
        qed
        have 2: "real l + 1 \<le> ceiling(c * real l)"
        proof-
          have "real l + 1 = of_int(int(l)) + 1" by simp
          also have "... \<le> ceiling(c * real l)" using \<open>l \<noteq> 0\<close>
            by(simp only: int_less_real_le[symmetric] less_ceiling_iff)
              (simp add: mult_less_cancel_right1)
          finally show ?thesis .
        qed
        from \<open>l\<noteq>0\<close> 1 2 show ?thesis by simp (simp add: not_le zero_less_mult_iff)
      qed
    qed
  qed
next
  case 2 thus ?case by(auto simp: field_simps split: if_splits prod.splits)
next
  case (3 ss f)
  show ?case
  proof (cases f)
    case Empty thus ?thesis using 3(2) by simp
  next
    case [simp]: Ins
    obtain n l where [simp]: "ss = [(n,l)]" using 3(2) by (auto)
    show ?thesis
    proof cases
      assume "l=0" thus ?thesis using 3 by (simp)
    next
      assume [arith]: "l\<noteq>0"
      show ?thesis
      proof cases
        assume "n<l"
        thus ?thesis using 3 ac by(simp add: algebra_simps b_def)
      next
        assume "\<not> n<l"
        hence [simp]: "n=l" using 3 by simp
        have "cost Ins [(n,l)] + \<Phi> (ins (n,l)) - \<Phi>(n,l) = l + a + 1 + (- b*ceiling(c*l)) + b*l"
          using \<open>l\<noteq>0\<close>
          by(simp add: algebra_simps less_trans[of "-1::real" 0])
        also have "- b * ceiling(c*l) \<le> - b * (c*l)" by (simp add: ceiling_correct)
        also have "l + a + 1 + - b*(c*l) + b*l = a + 1 + l*(1 - b*(c - 1))"
          by (simp add: algebra_simps)
        also have "b*(c - 1) = 1" by(simp add: b_def)
        also have "a + 1 + (real l)*(1 - 1) = a+1" by simp
        finally show ?thesis by simp
      qed
    qed
  qed
qed

end (* Dyn_Tab2 *)

subsection "Dynamic tables: insert and delete"

locale Dyn_Tab3
begin

type_synonym tab = "nat \<times> nat"

datatype op = Empty | Ins | Del

fun arity :: "op \<Rightarrow> nat" where
"arity Empty = 0" |
"arity Ins = 1" |
"arity Del = 1"

fun exec :: "op \<Rightarrow> tab list \<Rightarrow> tab" where
"exec Empty [] = (0::nat,0::nat)" |
"exec Ins [(n,l)] = (n+1, if n<l then l else if l=0 then 1 else 2*l)" |
"exec Del [(n,l)] = (n-1, if n\<le>1 then 0 else if 4*(n - 1)<l then l div 2 else l)"

fun cost :: "op \<Rightarrow> tab list \<Rightarrow> nat" where
"cost Empty _ = 1" |
"cost Ins [(n,l)] = (if n<l then 1 else n+1)" |
"cost Del [(n,l)] = (if n\<le>1 then 1 else if 4*(n - 1)<l then n else 1)"

interpretation Amortized
where arity = arity and exec = exec
and inv = "\<lambda>(n,l). if l=0 then n=0 else n \<le> l \<and> l \<le> 4*n"
and cost = cost and \<Phi> = "(\<lambda>(n,l). if 2*n < l then l/2 - n else 2*n - l)"
and U = "\<lambda>f _. case f of Empty \<Rightarrow> 1 | Ins \<Rightarrow> 3 | Del \<Rightarrow> 2"
proof (standard, goal_cases)
  case (1 _ f) thus ?case by (cases f) (auto split: if_splits)
next
  case 2 thus ?case by(auto split: prod.splits)
next
  case (3 _ f) thus ?case
    by (cases f)(auto simp: field_simps split: prod.splits)
qed

end (* Dyn_Tab3 *)

subsection "Queue"

text\<open>See, for example, the book by Okasaki~\cite{Okasaki}.\<close>

locale Queue
begin

datatype 'a op = Empty | Enq 'a | Deq

type_synonym 'a queue = "'a list * 'a list"

fun arity :: "'a op \<Rightarrow> nat" where
"arity Empty = 0" |
"arity (Enq _) = 1" |
"arity Deq = 1"

fun exec :: "'a op \<Rightarrow> 'a queue list \<Rightarrow> 'a queue" where
"exec Empty [] = ([],[])" |
"exec (Enq x) [(xs,ys)] = (x#xs,ys)" |
"exec Deq [(xs,ys)] = (if ys = [] then ([], tl(rev xs)) else (xs,tl ys))"

fun cost :: "'a op \<Rightarrow> 'a queue list \<Rightarrow> nat" where
"cost Empty _ = 0" |
"cost (Enq x) [(xs,ys)] = 1" |
"cost Deq [(xs,ys)] = (if ys = [] then length xs else 0)"

interpretation Amortized
where arity = arity and exec = exec and inv = "\<lambda>_. True"
and cost = cost and \<Phi> = "\<lambda>(xs,ys). length xs"
and U = "\<lambda>f _. case f of Empty \<Rightarrow> 0 | Enq _ \<Rightarrow> 2 | Deq \<Rightarrow> 0"
proof (standard, goal_cases)
  case 1 show ?case by simp
next
  case 2 thus ?case by (auto split: prod.splits)
next
  case 3 thus ?case by(auto split: op.split)
qed

end (* Queue *)

locale Queue2
begin

datatype 'a op = Empty | Enq 'a | Deq

type_synonym 'a queue = "'a list * 'a list"

fun arity :: "'a op \<Rightarrow> nat" where
"arity Empty = 0" |
"arity (Enq _) = 1" |
"arity Deq = 1"

fun adjust :: "'a queue \<Rightarrow> 'a queue" where
"adjust(xs,ys) = (if ys = [] then ([], rev xs) else (xs,ys))"

fun exec :: "'a op \<Rightarrow> 'a queue list \<Rightarrow> 'a queue" where
"exec Empty [] = ([],[])" |
"exec (Enq x) [(xs,ys)] = adjust(x#xs,ys)" |
"exec Deq [(xs,ys)] = adjust (xs, tl ys)"

fun cost :: "'a op \<Rightarrow> 'a queue list \<Rightarrow> nat" where
"cost Empty _ = 0" |
"cost (Enq x) [(xs,ys)] = 1 + (if ys = [] then size xs + 1 else 0)" |
"cost Deq [(xs,ys)] = (if tl ys = [] then size xs else 0)"

interpretation Amortized
where arity = arity and exec = exec
and inv = "\<lambda>_. True"
and cost = cost and \<Phi> = "\<lambda>(xs,ys). size xs"
and U = "\<lambda>f _. case f of Empty \<Rightarrow> 0 | Enq _ \<Rightarrow> 2 | Deq \<Rightarrow> 0"
proof (standard, goal_cases)
  case (1 _ f) thus ?case by (cases f) (auto split: if_splits)
next
  case 2 thus ?case by (auto)
next
  case (3 _ f) thus ?case by(cases f) (auto split: if_splits)
qed

end (* Queue2 *)

locale Queue3
begin

datatype 'a op = Empty | Enq 'a | Deq

type_synonym 'a queue = "'a list * 'a list"

fun arity :: "'a op \<Rightarrow> nat" where
"arity Empty = 0" |
"arity (Enq _) = 1" |
"arity Deq = 1"

fun balance :: "'a queue \<Rightarrow> 'a queue" where
"balance(xs,ys) = (if size xs \<le> size ys then (xs,ys) else ([], ys @ rev xs))"

fun exec :: "'a op \<Rightarrow> 'a queue list \<Rightarrow> 'a queue" where
"exec Empty [] = ([],[])" |
"exec (Enq x) [(xs,ys)] = balance(x#xs,ys)" |
"exec Deq [(xs,ys)] = balance (xs, tl ys)"

fun cost :: "'a op \<Rightarrow> 'a queue list \<Rightarrow> nat" where
"cost Empty _ = 0" |
"cost (Enq x) [(xs,ys)] = 1 + (if size xs + 1 \<le> size ys then 0 else size xs + 1 + size ys)" |
"cost Deq [(xs,ys)] = (if size xs \<le> size ys - 1 then 0 else size xs + (size ys - 1))"

interpretation Amortized
where arity = arity and exec = exec
and inv = "\<lambda>(xs,ys). size xs \<le> size ys"
and cost = cost and \<Phi> = "\<lambda>(xs,ys). 2 * size xs"
and U = "\<lambda>f _. case f of Empty \<Rightarrow> 0 | Enq _ \<Rightarrow> 3 | Deq \<Rightarrow> 0"
proof (standard, goal_cases)
  case (1 _ f) thus ?case by (cases f) (auto split: if_splits)
next
  case 2 thus ?case by (auto)
next
  case (3 _ f) thus ?case by(cases f) (auto split: prod.splits)
qed

end (* Queue3 *)

end


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

section {* Example definitions using the CCPO structure on terminated lazy lists *}

theory TLList_CCPO_Examples imports
   "../TLList_CCPO"
begin

context fixes b :: 'b begin
interpretation tllist_pf b .

context fixes P :: "'a \<Rightarrow> bool"
  notes [[function_internals]]
begin

partial_function (tllist) tfilter :: "('a, 'b) tllist \<Rightarrow> ('a, 'b) tllist"
where
  "tfilter xs = (case xs of TNil b' \<Rightarrow> TNil b' | TCons x xs' \<Rightarrow> if P x then TCons x (tfilter xs') else tfilter xs')"

end

simps_of_case tfilter_simps [simp]: tfilter.simps

lemma is_TNil_tfilter: "is_TNil (tfilter P xs) \<longleftrightarrow> (\<forall>x \<in> tset xs. \<not> P x)" (is "?lhs \<longleftrightarrow> ?rhs")
proof(rule iffI ballI)+
  fix x
  assume "x \<in> tset xs" ?lhs
  thus "\<not> P x"
  proof(induct rule: tllist_set_induct)
    case (find xs)
    thus ?case by(cases xs)(simp_all split: if_split_asm)
  next
    case (step xs x)
    thus ?case by(cases xs)(simp_all split: if_split_asm)
  qed
next
  assume ?rhs
  thus ?lhs
    by(induct arbitrary: xs rule: tfilter.fixp_induct)(simp_all split: tllist.split)
qed

end

lemma mcont2mcont_tfilter[THEN tllist.mcont2mcont, simp, cont_intro]:
  shows mcont_tfilter: "mcont (tSup b) (tllist_ord b) (tSup b) (tllist_ord b) (tfilter b P)"
apply(rule tllist.fixp_preserves_mcont1[OF tfilter.mono tfilter_def])
apply(rule mcont_lprefix_case_aux)
apply simp_all
done

lemma tfilter_tfilter:
  "tfilter b P (tfilter b Q xs) = tfilter b (\<lambda>x. P x \<and> Q x) xs" (is "?lhs xs = ?rhs xs")
proof(rule tllist.leq_antisym)
  have "\<forall>xs. tllist_ord b (?lhs xs) (?rhs xs)"
    by(rule tfilter.fixp_induct[where Pa="\<lambda>f. \<forall>xs. tllist_ord b (tfilter b P (f xs)) (?rhs xs)"])(auto split: tllist.split)
  thus "tllist_ord b (?lhs xs) (?rhs xs)" ..

  have "\<forall>xs. tllist_ord b (?rhs xs) (?lhs xs)"
    by(rule tfilter.fixp_induct[where Pa="\<lambda>f. \<forall>xs. tllist_ord b (f xs) (?lhs xs)"])(auto split: tllist.split)
  thus "tllist_ord b (?rhs xs) (?lhs xs)" ..
qed

declare ccpo.admissible_leI[OF complete_lattice_ccpo, cont_intro, simp]

lemma tset_tfilter: "tset (tfilter b P xs) = {x\<in>tset xs. P x}"
proof(rule equalityI[OF _ subsetI])
  show "tset (tfilter b P xs) \<subseteq> {x \<in> tset xs. P x}"
    by(induct arbitrary: xs rule: tfilter.fixp_induct)(auto split: tllist.split)
  fix x
  assume "x \<in> {x \<in> tset xs. P x}"
  hence "x \<in> tset xs" "P x" by simp_all
  thus "x \<in> tset (tfilter b P xs)"
    by(induct rule: tset_induct) simp_all
qed

context fixes b :: 'b begin
interpretation tllist_pf b .

partial_function (tllist) tconcat :: "('a llist, 'b) tllist \<Rightarrow> ('a, 'b) tllist"
where
  "tconcat xs = (case xs of TNil b \<Rightarrow> TNil b | TCons x xs' \<Rightarrow> lappendt x (tconcat xs'))"

end

simps_of_case tconcat2_simps [simp]: tconcat.simps

end


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