(*  Title:      HOL/ZF/LProd.thy
    Author:     Steven Obua

    Introduces the lprod relation.
    See "Partizan Games in Isabelle/HOLZF", available from http://www4.in.tum.de/~obua/partizan
*)

theory LProd
imports "HOL-Library.Multiset"
begin

inductive_set
  lprod :: "('a * 'a) set \<Rightarrow> ('a list * 'a list) set"
  for R :: "('a * 'a) set"
where
  lprod_single[intro!]: "(a, b) \<in> R \<Longrightarrow> ([a], [b]) \<in> lprod R"
| lprod_list[intro!]: "(ah@at, bh@bt) \<in> lprod R \<Longrightarrow> (a,b) \<in> R \<or> a = b \<Longrightarrow> (ah@a#at, bh@b#bt) \<in> lprod R"

lemma "(as,bs) \<in> lprod R \<Longrightarrow> length as = length bs"
  apply (induct as bs rule: lprod.induct)
  apply auto
  done

lemma "(as, bs) \<in> lprod R \<Longrightarrow> 1 \<le> length as \<and> 1 \<le> length bs"
  apply (induct as bs rule: lprod.induct)
  apply auto
  done

lemma lprod_subset_elem: "(as, bs) \<in> lprod S \<Longrightarrow> S \<subseteq> R \<Longrightarrow> (as, bs) \<in> lprod R"
  apply (induct as bs rule: lprod.induct)
  apply (auto)
  done

lemma lprod_subset: "S \<subseteq> R \<Longrightarrow> lprod S \<subseteq> lprod R"
  by (auto intro: lprod_subset_elem)

lemma lprod_implies_mult: "(as, bs) \<in> lprod R \<Longrightarrow> trans R \<Longrightarrow> (mset as, mset bs) \<in> mult R"
proof (induct as bs rule: lprod.induct)
  case (lprod_single a b)
  note step = one_step_implies_mult[
    where r=R and I="{#}" and K="{#a#}" and J="{#b#}", simplified]
  show ?case by (auto intro: lprod_single step)
next
  case (lprod_list ah at bh bt a b)
  then have transR: "trans R" by auto
  have as: "mset (ah @ a # at) = mset (ah @ at) + {#a#}" (is "_ = ?ma + _")
    by (simp add: algebra_simps)
  have bs: "mset (bh @ b # bt) = mset (bh @ bt) + {#b#}" (is "_ = ?mb + _")
    by (simp add: algebra_simps)
  from lprod_list have "(?ma, ?mb) \<in> mult R"
    by auto
  with mult_implies_one_step[OF transR] have
    "\<exists>I J K. ?mb = I + J \<and> ?ma = I + K \<and> J \<noteq> {#} \<and> (\<forall>k\<in>set_mset K. \<exists>j\<in>set_mset J. (k, j) \<in> R)"
    by blast
  then obtain I J K where
    decomposed: "?mb = I + J \<and> ?ma = I + K \<and> J \<noteq> {#} \<and> (\<forall>k\<in>set_mset K. \<exists>j\<in>set_mset J. (k, j) \<in> R)"
    by blast
  show ?case
  proof (cases "a = b")
    case True
    have "((I + {#b#}) + K, (I + {#b#}) + J) \<in> mult R"
      apply (rule one_step_implies_mult)
      apply (auto simp add: decomposed)
      done
    then show ?thesis
      apply (simp only: as bs)
      apply (simp only: decomposed True)
      apply (simp add: algebra_simps)
      done
  next
    case False
    from False lprod_list have False: "(a, b) \<in> R" by blast
    have "(I + (K + {#a#}), I + (J + {#b#})) \<in> mult R"
      apply (rule one_step_implies_mult)
      apply (auto simp add: False decomposed)
      done
    then show ?thesis
      apply (simp only: as bs)
      apply (simp only: decomposed)
      apply (simp add: algebra_simps)
      done
  qed
qed

lemma wf_lprod[simp,intro]:
  assumes wf_R: "wf R"
  shows "wf (lprod R)"
proof -
  have subset: "lprod (R\<^sup>+) \<subseteq> inv_image (mult (R\<^sup>+)) mset"
    by (auto simp add: lprod_implies_mult trans_trancl)
  note lprodtrancl = wf_subset[OF wf_inv_image[where r="mult (R\<^sup>+)" and f="mset",
    OF wf_mult[OF wf_trancl[OF wf_R]]], OF subset]
  note lprod = wf_subset[OF lprodtrancl, where p="lprod R", OF lprod_subset, simplified]
  show ?thesis by (auto intro: lprod)
qed

definition gprod_2_2 :: "('a * 'a) set \<Rightarrow> (('a * 'a) * ('a * 'a)) set" where
  "gprod_2_2 R \<equiv> { ((a,b), (c,d)) . (a = c \<and> (b,d) \<in> R) \<or> (b = d \<and> (a,c) \<in> R) }"

definition gprod_2_1 :: "('a * 'a) set \<Rightarrow> (('a * 'a) * ('a * 'a)) set" where
  "gprod_2_1 R \<equiv>  { ((a,b), (c,d)) . (a = d \<and> (b,c) \<in> R) \<or> (b = c \<and> (a,d) \<in> R) }"

lemma lprod_2_3: "(a, b) \<in> R \<Longrightarrow> ([a, c], [b, c]) \<in> lprod R"
  by (auto intro: lprod_list[where a=c and b=c and
    ah = "[a]" and at = "[]" and bh="[b]" and bt="[]", simplified])

lemma lprod_2_4: "(a, b) \<in> R \<Longrightarrow> ([c, a], [c, b]) \<in> lprod R"
  by (auto intro: lprod_list[where a=c and b=c and
    ah = "[]" and at = "[a]" and bh="[]" and bt="[b]", simplified])

lemma lprod_2_1: "(a, b) \<in> R \<Longrightarrow> ([c, a], [b, c]) \<in> lprod R"
  by (auto intro: lprod_list[where a=c and b=c and
    ah = "[]" and at = "[a]" and bh="[b]" and bt="[]", simplified])

lemma lprod_2_2: "(a, b) \<in> R \<Longrightarrow> ([a, c], [c, b]) \<in> lprod R"
  by (auto intro: lprod_list[where a=c and b=c and
    ah = "[a]" and at = "[]" and bh="[]" and bt="[b]", simplified])

lemma [simp, intro]:
  assumes wfR: "wf R" shows "wf (gprod_2_1 R)"
proof -
  have "gprod_2_1 R \<subseteq> inv_image (lprod R) (\<lambda> (a,b). [a,b])"
    by (auto simp add: gprod_2_1_def lprod_2_1 lprod_2_2)
  with wfR show ?thesis
    by (rule_tac wf_subset, auto)
qed

lemma [simp, intro]:
  assumes wfR: "wf R" shows "wf (gprod_2_2 R)"
proof -
  have "gprod_2_2 R \<subseteq> inv_image (lprod R) (\<lambda> (a,b). [a,b])"
    by (auto simp add: gprod_2_2_def lprod_2_3 lprod_2_4)
  with wfR show ?thesis
    by (rule_tac wf_subset, auto)
qed

lemma lprod_3_1: assumes "(x', x) \<in> R" shows "([y, z, x'], [x, y, z]) \<in> lprod R"
  apply (rule lprod_list[where a="y" and b="y" and ah="[]" and at="[z,x']" and bh="[x]" and bt="[z]", simplified])
  apply (auto simp add: lprod_2_1 assms)
  done

lemma lprod_3_2: assumes "(z',z) \<in> R" shows "([z', x, y], [x,y,z]) \<in> lprod R"
  apply (rule lprod_list[where a="y" and b="y" and ah="[z',x]" and at="[]" and bh="[x]" and bt="[z]", simplified])
  apply (auto simp add: lprod_2_2 assms)
  done

lemma lprod_3_3: assumes xr: "(xr, x) \<in> R" shows "([xr, y, z], [x, y, z]) \<in> lprod R"
  apply (rule lprod_list[where a="y" and b="y" and ah="[xr]" and at="[z]" and bh="[x]" and bt="[z]", simplified])
  apply (simp add: xr lprod_2_3)
  done

lemma lprod_3_4: assumes yr: "(yr, y) \<in> R" shows "([x, yr, z], [x, y, z]) \<in> lprod R"
  apply (rule lprod_list[where a="x" and b="x" and ah="[]" and at="[yr,z]" and bh="[]" and bt="[y,z]", simplified])
  apply (simp add: yr lprod_2_3)
  done

lemma lprod_3_5: assumes zr: "(zr, z) \<in> R" shows "([x, y, zr], [x, y, z]) \<in> lprod R"
  apply (rule lprod_list[where a="x" and b="x" and ah="[]" and at="[y,zr]" and bh="[]" and bt="[y,z]", simplified])
  apply (simp add: zr lprod_2_4)
  done

lemma lprod_3_6: assumes y': "(y', y) \<in> R" shows "([x, z, y'], [x, y, z]) \<in> lprod R"
  apply (rule lprod_list[where a="z" and b="z" and ah="[x]" and at="[y']" and bh="[x,y]" and bt="[]", simplified])
  apply (simp add: y' lprod_2_4)
  done

lemma lprod_3_7: assumes z': "(z',z) \<in> R" shows "([x, z', y], [x, y, z]) \<in> lprod R"
  apply (rule lprod_list[where a="y" and b="y" and ah="[x, z']" and at="[]" and bh="[x]" and bt="[z]", simplified])
  apply (simp add: z' lprod_2_4)
  done

definition perm :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a set \<Rightarrow> bool" where
   "perm f A \<equiv> inj_on f A \<and> f ` A = A"

lemma "((as,bs) \<in> lprod R) =
  (\<exists> f. perm f {0 ..< (length as)} \<and>
  (\<forall> j. j < length as \<longrightarrow> ((nth as j, nth bs (f j)) \<in> R \<or> (nth as j = nth bs (f j)))) \<and>
  (\<exists> i. i < length as \<and> (nth as i, nth bs (f i)) \<in> R))"
oops

lemma "trans R \<Longrightarrow> (ah@a#at, bh@b#bt) \<in> lprod R \<Longrightarrow> (b, a) \<in> R \<or> a = b \<Longrightarrow> (ah@at, bh@bt) \<in> lprod R"
oops

end


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

theory StaticFun
imports
  Main
begin

datatype ('a, 'b) Tree = Node 'a 'b "('a, 'b) Tree" "('a, 'b) Tree" | Leaf

primrec
  lookup_tree :: "('a, 'b) Tree \<Rightarrow> ('a \<Rightarrow> 'c :: linorder) \<Rightarrow> 'a \<Rightarrow> 'b option"
where
  "lookup_tree Leaf fn x = None"
| "lookup_tree (Node y v l r) fn x = (if fn x = fn y then Some v
                                      else if fn x < fn y then lookup_tree l fn x
                                      else lookup_tree r fn x)"

definition optional_strict_range :: "('a :: linorder) option \<Rightarrow> 'a option \<Rightarrow> 'a set"
where
  "optional_strict_range x y = {z. (x = None \<or> the x < z) \<and> (y = None \<or> z < the y)}"

lemma optional_strict_range_split:
  "z \<in> optional_strict_range x y
    \<Longrightarrow> optional_strict_range x (Some z) = ({..< z} \<inter> optional_strict_range x y)
        \<and> optional_strict_range (Some z) y = ({z <..} \<inter> optional_strict_range x y)"
  by (auto simp add: optional_strict_range_def)

lemma optional_strict_rangeI:
  "z \<in> optional_strict_range None None"
  "z < y \<Longrightarrow> z \<in> optional_strict_range None (Some y)"
  "x < z \<Longrightarrow> z \<in> optional_strict_range (Some x) None"
  "x < z \<Longrightarrow> z < y \<Longrightarrow> z \<in> optional_strict_range (Some x) (Some y)"
  by (simp_all add: optional_strict_range_def)

definition
  tree_eq_fun_in_range :: "('a, 'b) Tree \<Rightarrow> ('a \<Rightarrow> 'c :: linorder) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> 'c set \<Rightarrow> bool"
where
 "tree_eq_fun_in_range T ord f S \<equiv> \<forall>x. (ord x \<in> S) \<longrightarrow> f x = lookup_tree T ord x"

lemma tree_eq_fun_in_range_from_def:
  "\<lbrakk> f \<equiv> lookup_tree T ord \<rbrakk>
    \<Longrightarrow> tree_eq_fun_in_range T ord f (optional_strict_range None None)"
  by (simp add: tree_eq_fun_in_range_def)

lemma tree_eq_fun_in_range_split:
  "tree_eq_fun_in_range (Node z v l r) ord f (optional_strict_range x y)
    \<Longrightarrow> ord z \<in> optional_strict_range x y
    \<Longrightarrow> tree_eq_fun_in_range l ord f (optional_strict_range x (Some (ord z)))
        \<and> f z = Some v
        \<and> tree_eq_fun_in_range r ord f (optional_strict_range (Some (ord z)) y)"
  apply (simp add: tree_eq_fun_in_range_def optional_strict_range_split)
  apply fastforce
  done

ML \<open>

structure StaticFun = struct

(* Actually build the tree -- theta (n lg(n)) *)
fun build_tree' _ mk_leaf [] = mk_leaf
  | build_tree' mk_node mk_leaf xs = let
    val len = length xs
    val (ys, zs) = chop (len div 2) xs
  in case zs of [] => error "build_tree': impossible"
    | ((a, b) :: zs) => mk_node a b (build_tree' mk_node mk_leaf ys)
        (build_tree' mk_node mk_leaf zs)
  end

fun build_tree ord xs = case xs of [] => error "build_tree : empty"
  | (idx, v) :: _ => let
    val idxT = fastype_of idx
    val vT = fastype_of v
    val treeT = Type (@{type_name StaticFun.Tree}, [idxT, vT])
    val mk_leaf = Const (@{const_name StaticFun.Leaf}, treeT)
    val node = Const (@{const_name StaticFun.Node},
        idxT --> vT --> treeT --> treeT --> treeT)
    fun mk_node a b l r = node $ a $ b $ l $ r
    val lookup = Const (@{const_name StaticFun.lookup_tree},
        treeT --> fastype_of ord --> idxT
            --> Type (@{type_name option}, [vT]))
  in
    lookup $ (build_tree' mk_node mk_leaf xs) $ ord
  end

fun define_partial_map_tree name mappings ord ctxt = let
    val tree = build_tree ord mappings
  in Local_Theory.define
    ((name, NoSyn), ((Thm.def_binding name, []), tree)) ctxt
    |> apfst (apsnd snd)
  end

fun prove_partial_map_thms thm ctxt = let
    val init = thm RS @{thm tree_eq_fun_in_range_from_def}
    fun rec_tree thm = case Thm.concl_of thm of
    @{term Trueprop} $ (Const (@{const_name tree_eq_fun_in_range}, _)
        $ (Const (@{const_name Node}, _) $ z $ v $ _ $ _) $ _ $ _ $ _) => let
        val t' = thm RS @{thm tree_eq_fun_in_range_split}
        val solve_simp_tac = SUBGOAL (fn (t, i) =>
            (simp_tac ctxt THEN_ALL_NEW SUBGOAL (fn (t', _) =>
                raise TERM ("prove_partial_map_thms: unsolved", [t, t']))) i)
        val r = t' |> (resolve_tac ctxt @{thms optional_strict_rangeI}
            THEN_ALL_NEW solve_simp_tac) 1 |> Seq.hd
        val l = r RS @{thm conjunct1}
        val kr = r RS @{thm conjunct2}
        val k = kr RS @{thm conjunct1}
        val r = kr RS @{thm conjunct2}
      in rec_tree l @ [((z, v), k)] @ rec_tree r end
    | _ => []
  in rec_tree init end

fun define_tree_and_save_thms name names mappings ord exsimps ctxt = let
    val ((tree, def_thm), ctxt) = define_partial_map_tree name mappings ord ctxt
    val thms = prove_partial_map_thms def_thm (ctxt addsimps exsimps)
    val (idents, thms) = map_split I thms
    val _ = map (fn ((x, y), (x', y')) => (x aconv x' andalso y aconv y')
        orelse raise TERM ("define_tree_and_thms: different", [x, y, x', y']))
        (mappings ~~ idents)
    val (_, ctxt) = Local_Theory.notes
        (map (fn (s, t) => ((Binding.name s, []), [([t], [])]))
        (names ~~ thms)) ctxt
  in (tree, ctxt) end

fun define_tree_and_thms_with_defs name names key_defs opt_values ord ctxt = let
    val data = names ~~ (key_defs ~~ opt_values)
        |> map_filter (fn (_, (_, NONE)) => NONE | (nm, (thm, SOME v))
            => SOME (nm, (fst (Logic.dest_equals (Thm.concl_of thm)), v)))
    val (names, mappings) = map_split I data
  in define_tree_and_save_thms name names mappings ord key_defs ctxt end

end

\<close>

(* testing

local_setup {* StaticFun.define_tree_and_save_thms @{binding tree}
  ["one", "two", "three"]
  [(@{term "Suc 0"}, @{term "Suc 0"}),
    (@{term "2 :: nat"}, @{term "15 :: nat"}),
    (@{term "3 :: nat"}, @{term "1 :: nat"})]
  @{term "id :: nat \<Rightarrow> nat"}
  #> snd
*}
print_theorems

*)

end


theory TypeSchemes1
imports "../Nominal2"
begin

section {* Type Schemes defined as two separate nominal datatypes *}

atom_decl name

nominal_datatype ty =
  Var "name"
| Fun "ty" "ty" ("_ \<rightarrow> _")

nominal_datatype tys =
  All xs::"name fset" ty::"ty" binds (set+) xs in ty ("All [_]._")

thm tys.distinct
thm tys.induct tys.strong_induct
thm tys.exhaust tys.strong_exhaust
thm tys.fv_defs
thm tys.bn_defs
thm tys.perm_simps
thm tys.eq_iff
thm tys.fv_bn_eqvt
thm tys.size_eqvt
thm tys.supports
thm tys.supp
thm tys.fresh

subsection {* Some Tests about Alpha-Equality *}

lemma
  shows "All [{|a, b|}].((Var a) \<rightarrow> (Var b)) = All [{|b, a|}]. ((Var a) \<rightarrow> (Var b))"
  apply(simp add: Abs_eq_iff)
  apply(rule_tac x="0::perm" in exI)
  apply(simp add: alphas fresh_star_def ty.supp supp_at_base)
  done

lemma
  shows "All [{|a, b|}].((Var a) \<rightarrow> (Var b)) = All [{|a, b|}].((Var b) \<rightarrow> (Var a))"
  apply(simp add: Abs_eq_iff)
  apply(rule_tac x="(atom a \<rightleftharpoons> atom b)" in exI)
  apply(simp add: alphas fresh_star_def supp_at_base ty.supp)
  done

lemma
  shows "All [{|a, b, c|}].((Var a) \<rightarrow> (Var b)) = All [{|a, b|}].((Var a) \<rightarrow> (Var b))"
  apply(simp add: Abs_eq_iff)
  apply(rule_tac x="0::perm" in exI)
  apply(simp add: alphas fresh_star_def ty.supp supp_at_base)
done

lemma
  assumes a: "a \<noteq> b"
  shows "\<not>(All [{|a, b|}].((Var a) \<rightarrow> (Var b)) = All [{|c|}].((Var c) \<rightarrow> (Var c)))"
  using a
  apply(simp add: Abs_eq_iff)
  apply(clarify)
  apply(simp add: alphas fresh_star_def ty.supp supp_at_base)
  apply auto
  done

subsection {* Substitution function for types and type schemes *}

type_synonym
  Subst = "(name \<times> ty) list"

fun
  lookup :: "Subst \<Rightarrow> name \<Rightarrow> ty"
where
  "lookup [] Y = Var Y"
| "lookup ((X, T) # Ts) Y = (if X = Y then T else lookup Ts Y)"

lemma lookup_eqvt[eqvt]:
  shows "(p \<bullet> lookup Ts T) = lookup (p \<bullet> Ts) (p \<bullet> T)"
  by (induct Ts T rule: lookup.induct) (simp_all)

nominal_function
  subst  :: "Subst \<Rightarrow> ty \<Rightarrow> ty" ("_<_>" [100,60] 120)
where
  "\<theta><Var X> = lookup \<theta> X"
| "\<theta><T1 \<rightarrow> T2> = (\<theta><T1>) \<rightarrow> (\<theta><T2>)"
  apply(simp add: eqvt_def subst_graph_aux_def)
  apply(rule TrueI)
  apply(case_tac x)
  apply(rule_tac y="b" in ty.exhaust)
  apply(blast)
  apply(blast)
  apply(simp_all)
  done

nominal_termination (eqvt)
  by lexicographic_order

lemma subst_id1:
  fixes T::"ty"
  shows "[]<T> = T"
by (induct T rule: ty.induct) (simp_all)

lemma subst_id2:
  fixes T::"ty"
  shows "[(X, Var X)]<T> = T"
by (induct T rule: ty.induct) (simp_all)

lemma supp_fun_app_eqvt:
  assumes e: "eqvt f"
  shows "supp (f a b) \<subseteq> supp a \<union> supp b"
  using supp_fun_app_eqvt[OF e] supp_fun_app
  by blast

lemma supp_subst:
  "supp (subst \<theta> t) \<subseteq> supp \<theta> \<union> supp t"
  apply (rule supp_fun_app_eqvt)
  unfolding eqvt_def
  by (simp add: permute_fun_def subst.eqvt)

nominal_function
  substs :: "(name \<times> ty) list \<Rightarrow> tys \<Rightarrow> tys" ("_<_>" [100,60] 120)
where
  "fset (map_fset atom Xs) \<sharp>* \<theta> \<Longrightarrow> \<theta><All [Xs].T> = All [Xs].(\<theta><T>)"
  apply(simp add: eqvt_def substs_graph_aux_def)
  apply auto[2]
  apply (rule_tac y="b" and c="a" in tys.strong_exhaust)
  apply auto[1]
  apply(simp)
  apply(erule conjE)
  apply (erule Abs_res_fcb)
  apply (simp add: Abs_fresh_iff)
  apply(simp add: fresh_def)
  apply(simp add: supp_Abs)
  apply(rule impI)
  apply(subgoal_tac "x \<notin> supp \<theta>")
  prefer 2
  apply(auto simp add: fresh_star_def fresh_def)[1]
  apply(subgoal_tac "x \<in> supp T")
  using supp_subst
  apply(blast)
  using supp_subst
  apply(blast)
  apply clarify
  apply (simp add: subst.eqvt)
  apply (subst Abs_eq_iff)
  apply (rule_tac x="0::perm" in exI)
  apply (subgoal_tac "p \<bullet> \<theta>' = \<theta>'")
  apply (simp add: alphas fresh_star_zero)
  apply (subgoal_tac "\<And>x. x \<in> supp (subst \<theta>' (p \<bullet> T)) \<Longrightarrow> x \<in> p \<bullet> atom ` fset Xs \<longleftrightarrow> x \<in> atom ` fset Xsa")
  apply(simp)
  apply blast
  apply (subgoal_tac "x \<in> supp(p \<bullet> \<theta>', p \<bullet> T)")
  apply (simp add: supp_Pair eqvts eqvts_raw)
  apply auto[1]
  apply (subgoal_tac "(atom ` fset (p \<bullet> Xs)) \<sharp>* \<theta>'")
  apply (simp add: fresh_star_def fresh_def)
  apply(drule_tac p1="p" in iffD2[OF fresh_star_permute_iff])
  apply (simp add: eqvts eqvts_raw)
  apply (simp add: fresh_star_def fresh_def)
  apply (drule subsetD[OF supp_subst])
  apply (simp add: supp_Pair)
  apply (rule perm_supp_eq)
  apply (simp add: fresh_def fresh_star_def)
  apply blast
  done

nominal_termination (eqvt)
  by (lexicographic_order)

subsection {* Generalisation of types and type-schemes*}

fun
  subst_Dom_pi :: "Subst \<Rightarrow> perm \<Rightarrow> Subst" ("_|_")
where
  "[]|p = []"
| "((X,T)#\<theta>)|p = (p \<bullet> X, T)#(\<theta>|p)"

fun
  subst_subst :: "Subst \<Rightarrow> Subst \<Rightarrow> Subst" ("_<_>"  [100,60] 120)
where
  "\<theta><[]> = []"
| "\<theta> <((X,T)#\<theta>')> = (X,\<theta><T>)#(\<theta><\<theta>'>)"

fun
  Dom :: "Subst \<Rightarrow> name set"
where
  "Dom [] = {}"
| "Dom ((X,T)#\<theta>) = {X} \<union> Dom \<theta>"

lemma Dom_eqvt[eqvt]:
  shows "p \<bullet> (Dom \<theta>) = Dom (p \<bullet> \<theta>)"
apply (induct \<theta> rule: Dom.induct)
apply (simp_all add: permute_set_def)
apply (auto)
done

lemma Dom_subst:
  fixes \<theta>1 \<theta>2::"Subst"
  shows "Dom (\<theta>2<\<theta>1>) = (Dom \<theta>1)"
by (induct \<theta>1) (auto)

lemma Dom_pi:
  shows "Dom (\<theta>|p) = Dom (p \<bullet> \<theta>)"
by (induct \<theta>) (auto)

lemma Dom_fresh_lookup:
  fixes \<theta>::"Subst"
  assumes "\<forall>Y \<in> Dom \<theta>. atom Y \<sharp> X"
  shows "lookup \<theta> X = Var X"
using assms
by (induct \<theta>) (auto simp add: fresh_at_base)

lemma Dom_fresh_ty:
  fixes \<theta>::"Subst"
  and   T::"ty"
  assumes "\<forall>X \<in> Dom \<theta>. atom X \<sharp> T"
  shows "\<theta><T> = T"
using assms
by (induct T rule: ty.induct) (auto simp add: ty.fresh Dom_fresh_lookup)

lemma Dom_fresh_subst:
  fixes \<theta> \<theta>'::"Subst"
  assumes "\<forall>X \<in> Dom \<theta>. atom X \<sharp> \<theta>'"
  shows "\<theta><\<theta>'> = \<theta>'"
using assms
by (induct \<theta>') (auto simp add: fresh_Pair fresh_Cons Dom_fresh_ty)

lemma s1:
  assumes "name \<in> Dom \<theta>"
  shows "lookup \<theta> name = lookup \<theta>|p (p \<bullet> name)"
using assms
apply(induct \<theta>)
apply(auto)
done

lemma lookup_fresh:
  fixes X::"name"
  assumes a: "atom X \<sharp> \<theta>"
  shows "lookup \<theta> X = Var X"
  using a
  by (induct \<theta>) (auto simp add: fresh_Cons fresh_Pair fresh_at_base)

lemma lookup_Dom:
  fixes X::"name"
  assumes "X \<notin> Dom \<theta>"
  shows "lookup \<theta> X = Var X"
  using assms
  by (induct \<theta>) (auto)

lemma t:
  fixes T::"ty"
  assumes a: "(supp T - atom ` Dom \<theta>) \<sharp>* p"
  shows "\<theta><T> = \<theta>|p<p \<bullet> T>"
using a
apply(induct T rule: ty.induct)
defer
apply(simp add: ty.supp fresh_star_def)
apply(simp)
apply(case_tac "name \<in> Dom \<theta>")
apply(rule s1)
apply(assumption)
apply(subst lookup_Dom)
apply(assumption)
apply(subst lookup_Dom)
apply(simp add: Dom_pi)
apply(rule_tac p="- p" in permute_boolE)
apply(perm_simp add: permute_minus_cancel)
apply(simp)
apply(simp)
apply(simp add: ty.supp supp_at_base)
apply(simp add: fresh_star_def)
apply(drule_tac x="atom name" in bspec)
apply(auto)[1]
apply(simp add: fresh_def supp_perm)
done

nominal_function
  generalises :: "ty \<Rightarrow> tys \<Rightarrow> bool" ("_ \<prec>\<prec> _")
where
  "atom ` (fset Xs) \<sharp>* T \<Longrightarrow>
     T \<prec>\<prec> All [Xs].T' \<longleftrightarrow> (\<exists>\<theta>. T = \<theta><T'> \<and> atom ` Dom \<theta> = atom ` fset Xs \<inter> supp T')"
apply(simp add: generalises_graph_aux_def eqvt_def)
apply(rule TrueI)
apply(case_tac x)
apply(simp)
apply(rule_tac y="b" and c="a" in tys.strong_exhaust)
apply(simp)
apply(clarify)
apply(simp only: tys.eq_iff map_fset_image)
apply(erule_tac c="Ta" in Abs_res_fcb2)
apply(simp)
apply(simp)
apply(simp add: fresh_star_def pure_fresh)
apply(simp add: fresh_star_def pure_fresh)
apply(simp add: fresh_star_def pure_fresh)
apply(perm_simp)
apply(subst perm_supp_eq)
apply(simp)
apply(simp)
apply(perm_simp)
apply(subst perm_supp_eq)
apply(simp)
apply(simp)
done

nominal_termination (eqvt)
  by lexicographic_order

lemma better:
  "T \<prec>\<prec> All [Xs].T' \<longleftrightarrow> (\<exists>\<theta>. T = \<theta><T'> \<and> atom ` Dom \<theta> = atom ` fset Xs \<inter> supp T')"
using at_set_avoiding3
apply -
apply(drule_tac x="atom ` fset Xs" in meta_spec)
apply(drule_tac x="T" in meta_spec)
apply(drule_tac x="All [Xs].T'" in meta_spec)
apply(drule meta_mp)
apply(simp)
apply(drule meta_mp)
apply(simp add: finite_supp)
apply(drule meta_mp)
apply(simp add: finite_supp)
apply(drule_tac meta_mp)
apply(simp add: fresh_star_def tys.fresh)
apply(clarify)
apply(rule_tac t="All [Xs].T'" and s="p \<bullet> All [Xs].T'" in subst)
apply(rule supp_perm_eq)
apply(assumption)
apply(perm_simp)
apply(subst generalises.simps)
apply(assumption)
apply(rule iffI)
defer
apply(clarify)
apply(rule_tac x="\<theta>|p" in exI)
apply(rule conjI)
apply(rule t)
apply(simp add: tys.supp)
apply (metis Diff_Int_distrib Int_Diff Int_commute inf_sup_absorb)
apply(simp add: Dom_pi)
apply(rotate_tac 3)
apply(drule_tac p="p" in permute_boolI)
apply(perm_simp)
apply(assumption)
apply(clarify)
apply(rule_tac x="\<theta>|- p" in exI)
apply(rule conjI)
apply(subst t[where p="- p"])
apply(simp add: tys.supp)
apply(rotate_tac 1)
apply(drule_tac p="p" in permute_boolI)
apply(perm_simp)
apply(simp add: permute_self)
apply(simp add: fresh_star_def)
apply(simp add: fresh_minus_perm)
apply (metis Diff_Int_distrib Int_Diff Int_commute inf_sup_absorb)
apply(simp)
apply(simp add: Dom_pi)
apply(rule_tac p="p" in permute_boolE)
apply(perm_simp add: permute_minus_cancel)
apply(assumption)
done

(* Tests *)

fun
  compose::"Subst \<Rightarrow> Subst \<Rightarrow> Subst" ("_ \<circ> _" [100,100] 100)
where
  "\<theta>1 \<circ> [] = \<theta>1"
| "\<theta>1 \<circ> ((X,T)#\<theta>2) = (X,\<theta>1<T>)#(\<theta>1 \<circ> \<theta>2)"

lemma compose_ty:
  fixes  \<theta>1 \<theta>2 :: "Subst"
  and    T :: "ty"
  shows "\<theta>1<\<theta>2<T>> = (\<theta>1\<circ>\<theta>2)<T>"
proof (induct T rule: ty.induct)
  case (Var X)
  have "\<theta>1<lookup \<theta>2 X> = lookup (\<theta>1\<circ>\<theta>2) X"
    by (induct \<theta>2) (auto)
  then show ?case by simp
next
  case (Fun T1 T2)
  then show ?case by simp
qed

lemma compose_Dom:
  shows "Dom (\<theta>1 \<circ> \<theta>2) = Dom \<theta>1 \<union> Dom \<theta>2"
apply(induct \<theta>2)
apply(auto)
done

lemma t1:
  fixes T::"ty"
  and Xs::"name fset"
  shows "\<exists>\<theta>. atom ` Dom \<theta> = atom ` fset Xs \<and> \<theta><T> = T"
apply(induct Xs)
apply(rule_tac x="[]" in exI)
apply(simp add: subst_id1)
apply(clarify)
apply(rule_tac x="[(x, Var x)] \<circ> \<theta>" in exI)
apply(simp add: compose_ty[symmetric] subst_id2 compose_Dom)
done

nominal_function
  ftv  :: "ty \<Rightarrow> name fset"
where
  "ftv (Var X) = {|X|}"
| "ftv (T1 \<rightarrow> T2) = (ftv T1) |\<union>| (ftv T2)"
  apply(simp add: eqvt_def ftv_graph_aux_def)
  apply(rule TrueI)
  apply(rule_tac y="x" in ty.exhaust)
  apply(blast)
  apply(blast)
  apply(simp_all)
  done

nominal_termination (eqvt)
  by lexicographic_order

lemma tt:
  shows "supp T = atom ` fset (ftv T)"
apply(induct T rule: ty.induct)
apply(simp_all add: ty.supp supp_at_base)
apply(auto)
done

lemma t2:
  shows "T \<prec>\<prec> All [Xs].T"
unfolding better
using t1
apply -
apply(drule_tac x="Xs |\<inter>| ftv T" in meta_spec)
apply(drule_tac x="T" in meta_spec)
apply(clarify)
apply(rule_tac x="\<theta>" in exI)
apply(simp add: tt)
apply(auto)
done

(* HERE *)

lemma w1:
  shows "\<theta><\<theta>'|p> = (\<theta><\<theta>'>)|p"
  by (induct \<theta>')(auto)

(*
lemma w2:
  assumes "name |\<in>| Dom \<theta>'"
  shows "\<theta><lookup \<theta>' name> = lookup (\<theta><\<theta>'>) name"
using assms
apply(induct \<theta>')
apply(auto simp add: notin_empty_fset)
done

lemma w3:
  assumes "name |\<in>| Dom \<theta>"
  shows "lookup \<theta> name = lookup (\<theta>|p) (p \<bullet> name)"
using assms
apply(induct \<theta>)
apply(auto simp add: notin_empty_fset)
done

lemma fresh_lookup:
  fixes X Y::"name"
  and   \<theta>::"Subst"
  assumes asms: "atom X \<sharp> Y" "atom X \<sharp> \<theta>"
  shows "atom X \<sharp> (lookup \<theta> Y)"
  using assms
  apply (induct \<theta>)
  apply (auto simp add: fresh_Cons fresh_Pair fresh_at_base ty.fresh)
  done

lemma test:
  fixes \<theta> \<theta>'::"Subst"
  and T::"ty"
  assumes "(p \<bullet> atom ` fset (Dom \<theta>')) \<sharp>* \<theta>" "supp All [Dom \<theta>'].T \<sharp>* p"
  shows "\<theta><\<theta>'<T>> = \<theta><\<theta>'|p><\<theta><p \<bullet> T>>"
using assms
apply(induct T rule: ty.induct)
defer
apply(auto simp add: tys.supp ty.supp fresh_star_def)[1]
apply(auto simp add: tys.supp ty.supp fresh_star_def supp_at_base)[1]
apply(case_tac "name |\<in>| Dom \<theta>'")
apply(subgoal_tac "atom (p \<bullet> name) \<sharp> \<theta>")
apply(subst (2) lookup_fresh)
apply(perm_simp)
apply(auto simp add: fresh_star_def)[1]
apply(simp)
apply(simp add: w1)
apply(simp add: w2)
apply(subst w3[symmetric])
apply(simp add: Dom_subst)
apply(simp)
apply(perm_simp)
apply(rotate_tac 2)
apply(drule_tac p="p" in permute_boolI)
apply(perm_simp)
apply(auto simp add: fresh_star_def)[1]
apply(metis notin_fset)
apply(simp add: lookup_Dom)
apply(perm_simp)
apply(subst Dom_fresh_ty)
apply(auto)[1]
apply(rule fresh_lookup)
apply(simp add: Dom_subst)
apply(simp add: Dom_pi)
apply(perm_simp)
apply(rotate_tac 2)
apply(drule_tac p="p" in permute_boolI)
apply(perm_simp)
apply(simp add: fresh_at_base)
apply (metis in_fset)
apply(simp add: Dom_subst)
apply(simp add: Dom_pi[symmetric])
apply(perm_simp)
apply(subst supp_perm_eq)
apply(simp add: supp_at_base fresh_star_def)
apply (smt Diff_iff atom_eq_iff image_iff insertI1 notin_fset)
apply(simp)
done

lemma generalises_subst:
  shows "T \<prec>\<prec> All [Xs].T' \<Longrightarrow> \<theta><T> \<prec>\<prec> \<theta><All [Xs].T'>"
using at_set_avoiding3
apply -
apply(drule_tac x="fset (map_fset atom Xs)" in meta_spec)
apply(drule_tac x="\<theta>" in meta_spec)
apply(drule_tac x="All [Xs].T'" in meta_spec)
apply(drule meta_mp)
apply(simp)
apply(drule meta_mp)
apply(simp add: finite_supp)
apply(drule meta_mp)
apply(simp add: finite_supp)
apply(drule meta_mp)
apply(simp add: tys.fresh fresh_star_def)
apply(erule exE)
apply(erule conjE)+
apply(rule_tac t="All[Xs].T'" and s="p \<bullet> (All [Xs].T')" in subst)
apply(rule supp_perm_eq)
apply(assumption)
apply(perm_simp)
apply(subst substs.simps)
apply(simp)
apply(simp add: better)
apply(erule exE)
apply(simp)
apply(rule_tac x="\<theta><\<theta>'|p>" in exI)
apply(rule conjI)
apply(rule test)
apply(simp)
apply(perm_simp)
apply(simp add: fresh_star_def)
apply(auto)[1]
apply(simp add: tys.supp)
apply(simp add: fresh_star_def)
apply(auto)[1]
oops

lemma generalises_subst:
  shows "T \<prec>\<prec> S \<Longrightarrow> \<theta><T> \<prec>\<prec> \<theta><S>"
unfolding generalises_def
apply(erule exE)+
apply(erule conjE)+
apply(rule_tac t="S" and s="All [Xs].T'" in subst)
apply(simp)
using at_set_avoiding3
apply -
apply(drule_tac x="fset (map_fset atom Xs)" in meta_spec)
apply(drule_tac x="\<theta>" in meta_spec)
apply(drule_tac x="All [Xs].T'" in meta_spec)
apply(drule meta_mp)
apply(simp)
apply(drule meta_mp)
apply(simp add: finite_supp)
apply(drule meta_mp)
apply(simp add: finite_supp)
apply(drule meta_mp)
apply(simp add: tys.fresh fresh_star_def)
apply(erule exE)
apply(erule conjE)+
apply(rule_tac t="All[Xs].T'" and s="p \<bullet> (All [Xs].T')" in subst)
apply(rule supp_perm_eq)
apply(assumption)
apply(perm_simp)
apply(subst substs.simps)
apply(perm_simp)
apply(simp)
apply(rule_tac x="\<theta><\<theta>'|p>" in exI)
apply(rule_tac x="p \<bullet> Xs" in exI)
apply(rule_tac x="\<theta><p \<bullet> T'>" in exI)
apply(rule conjI)
apply(simp)
apply(rule conjI)
defer
apply(simp add: Dom_subst)
apply(simp add: Dom_pi Dom_eqvt[symmetric])
apply(rule_tac t="T" and s="\<theta>'<T'>" in subst)
apply(simp)
apply(simp)
apply(rule test)
apply(perm_simp)
apply(rotate_tac 2)
apply(drule_tac p="p" in permute_boolI)
apply(perm_simp)
apply(auto simp add: fresh_star_def)
done

lemma r:
  "A - (B \<inter> A) = A - B"
by (metis Diff_Int Diff_cancel sup_bot_right)

lemma t3:
  "T \<prec>\<prec>  All [Xs].T' \<longleftrightarrow> (\<exists>\<theta>. T = \<theta><T'> \<and> Dom \<theta> = Xs)"
apply(auto)
defer
apply(simp add: generalises_def)
apply(auto)[1]
unfolding generalises_def
apply(auto)[1]
apply(simp add:  Abs_eq_res_set)
apply(simp add: Abs_eq_iff2)
apply(simp add: alphas)
apply(perm_simp)
apply(clarify)
apply(simp add: r)
apply(drule sym)
apply(simp)
apply(rule_tac x="\<theta>|p" in exI)
sorry

definition
  generalises_tys :: "tys \<Rightarrow> tys \<Rightarrow> bool" ("_ \<prec>\<prec> _")
where
  "S1 \<prec>\<prec> S2 = (\<forall>T::ty. T \<prec>\<prec> S1 \<longrightarrow> T \<prec>\<prec> S2)"

lemma
  "All [Xs1].T1 \<prec>\<prec> All [Xs2].T2
     \<longleftrightarrow> (\<exists>\<theta>. Dom \<theta> = Xs2 \<and> T1 = \<theta><T2> \<and> (\<forall>X \<in> fset Xs1. atom X \<sharp> All [Xs2].T2))"
apply(rule iffI)
apply(simp add: generalises_tys_def)
apply(drule_tac x="T1" in spec)
apply(drule mp)
apply(rule t2)
apply(simp add: t3)
apply(clarify)
apply(rule_tac x="\<theta>" in exI)
apply(simp)
apply(rule ballI)
defer
apply(simp add: generalises_tys_def)
apply(clarify)
apply(simp add: t3)
apply(clarify)

lemma
  "T \<prec>\<prec>  All [Xs].T' \<longleftrightarrow> (\<exists>\<theta>. T = \<theta><T'> \<and> Dom \<theta> = Xs)"
apply(auto)
defer
apply(simp add: generalises_def)
apply(auto)[1]
apply(auto)[1]
apply(drule sym)
apply(simp add: Abs_eq_iff2)
apply(simp add: alphas)
apply(auto)
apply(rule_tac x="map (\<lambda>(X, T). (p \<bullet> X, T)) \<theta>" in exI)
apply(auto)
oops

*)

end


theory Ex022
  imports Main
begin

lemma "(A \<longrightarrow> B) \<longrightarrow> (A \<longrightarrow> B \<longrightarrow> C) \<longrightarrow> (A \<longrightarrow> C)"
proof -
  {
    assume "A \<longrightarrow> B"
    {
      assume "A \<longrightarrow> B \<longrightarrow> C"
      {
        assume A
        with \<open>A \<longrightarrow> B\<close> have B by (rule mp)
        from \<open>A \<longrightarrow> B \<longrightarrow> C\<close> and \<open>A\<close> have "B \<longrightarrow> C" by (rule mp)
        from \<open>B \<longrightarrow> C\<close> and \<open>B\<close> have C by (rule mp)
      }
      hence "A \<longrightarrow> C" by (rule impI)
    }
    hence "(A \<longrightarrow> B \<longrightarrow> C) \<longrightarrow> A \<longrightarrow> C" by (rule impI)
  }
  thus ?thesis by (rule impI)
qed


section \<open>Lens Instances\<close>

theory Lens_Instances
  imports Lens_Order
  keywords "alphabet" :: "thy_decl_block"
begin

text \<open>In this section we define a number of concrete instantiations of the lens locales, including
  functions lenses, list lenses, and record lenses.\<close>

subsection \<open>Function Lens\<close>

text \<open>A function lens views the valuation associated with a particular domain element @{typ "'a"}.
      We require that range type of a lens function has cardinality of at least 2; this ensures
      that properties of independence are provable.\<close>

definition fun_lens :: "'a \<Rightarrow> ('b::two \<Longrightarrow> ('a \<Rightarrow> 'b))" where
[lens_defs]: "fun_lens x = \<lparr> lens_get = (\<lambda> f. f x), lens_put = (\<lambda> f u. f(x := u)) \<rparr>"

lemma fun_wb_lens: "wb_lens (fun_lens x)"
  by (unfold_locales, simp_all add: fun_lens_def)

text \<open>Two function lenses are independent if and only if the domain elements are different.\<close>

lemma fun_lens_indep:
  "fun_lens x \<bowtie> fun_lens y \<longleftrightarrow> x \<noteq> y"
proof -
  obtain u v :: "'a::two" where "u \<noteq> v"
    using two_diff by auto
  thus ?thesis
    by (auto simp add: fun_lens_def lens_indep_def)
qed

subsection \<open>Function Range Lens\<close>

text \<open>The function range lens allows us to focus on a particular region of a function's range.\<close>

definition fun_ran_lens :: "('c \<Longrightarrow> 'b) \<Rightarrow> (('a \<Rightarrow> 'b) \<Longrightarrow> '\<alpha>) \<Rightarrow> (('a \<Rightarrow> 'c) \<Longrightarrow> '\<alpha>)" where
[lens_defs]: "fun_ran_lens X Y = \<lparr> lens_get = \<lambda> s. get\<^bsub>X\<^esub> \<circ> get\<^bsub>Y\<^esub> s
                                 , lens_put = \<lambda> s v. put\<^bsub>Y\<^esub> s (\<lambda> x::'a. put\<^bsub>X\<^esub> (get\<^bsub>Y\<^esub> s x) (v x)) \<rparr>"

lemma fun_ran_mwb_lens: "\<lbrakk> mwb_lens X; mwb_lens Y \<rbrakk> \<Longrightarrow> mwb_lens (fun_ran_lens X Y)"
  by (unfold_locales, auto simp add: fun_ran_lens_def)

lemma fun_ran_wb_lens: "\<lbrakk> wb_lens X; wb_lens Y \<rbrakk> \<Longrightarrow> wb_lens (fun_ran_lens X Y)"
  by (unfold_locales, auto simp add: fun_ran_lens_def)

lemma fun_ran_vwb_lens: "\<lbrakk> vwb_lens X; vwb_lens Y \<rbrakk> \<Longrightarrow> vwb_lens (fun_ran_lens X Y)"
  by (unfold_locales, auto simp add: fun_ran_lens_def)

subsection \<open>Map Lens\<close>

text \<open>The map lens allows us to focus on a particular region of a partial function's range. It
  is only a mainly well-behaved lens because it does not satisfy the PutGet law when the view
  is not in the domain.\<close>

definition map_lens :: "'a \<Rightarrow> ('b \<Longrightarrow> ('a \<rightharpoonup> 'b))" where
[lens_defs]: "map_lens x = \<lparr> lens_get = (\<lambda> f. the (f x)), lens_put = (\<lambda> f u. f(x \<mapsto> u)) \<rparr>"

lemma map_mwb_lens: "mwb_lens (map_lens x)"
  by (unfold_locales, simp_all add: map_lens_def)

subsection \<open>List Lens\<close>

text \<open>The list lens allows us to view a particular element of a list. In order to show it is mainly
  well-behaved we need to define to additional list functions. The following function adds
  a number undefined elements to the end of a list.\<close>

definition list_pad_out :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list" where
"list_pad_out xs k = xs @ replicate (k + 1 - length xs) undefined"

text \<open>The following function is like @{term "list_update"} but it adds additional elements to the
  list if the list isn't long enough first.\<close>

definition list_augment :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a list" where
"list_augment xs k v = (list_pad_out xs k)[k := v]"

text \<open>The following function is like @{term nth} but it expressly returns @{term undefined} when
  the list isn't long enough.\<close>

definition nth' :: "'a list \<Rightarrow> nat \<Rightarrow> 'a" where
"nth' xs i = (if (length xs > i) then xs ! i else undefined)"

text \<open>We can prove some additional laws about list update and append.\<close>

lemma list_update_append_lemma1: "i < length xs \<Longrightarrow> xs[i := v] @ ys = (xs @ ys)[i := v]"
  by (simp add: list_update_append)

lemma list_update_append_lemma2: "i < length ys \<Longrightarrow> xs @ ys[i := v] = (xs @ ys)[i + length xs := v]"
  by (simp add: list_update_append)

text \<open>We can also prove some laws about our new operators.\<close>

lemma nth'_0 [simp]: "nth' (x # xs) 0 = x"
  by (simp add: nth'_def)

lemma nth'_Suc [simp]: "nth' (x # xs) (Suc n) = nth' xs n"
  by (simp add: nth'_def)

lemma list_augment_0 [simp]:
  "list_augment (x # xs) 0 y = y # xs"
  by (simp add: list_augment_def list_pad_out_def)

lemma list_augment_Suc [simp]:
  "list_augment (x # xs) (Suc n) y = x # list_augment xs n y"
  by (simp add: list_augment_def list_pad_out_def)

lemma list_augment_twice:
  "list_augment (list_augment xs i u) j v = list_pad_out xs (max i j)[i := u, j := v]"
  apply (auto simp add: list_augment_def list_pad_out_def list_update_append_lemma1 replicate_add[THEN sym] max_def)
  apply (metis Suc_le_mono add.commute diff_diff_add diff_le_mono le_add_diff_inverse2)
done

text \<open>We can now prove that @{term list_augment} is commutative for different (arbitrary) indices.\<close>

lemma list_augment_commute:
  "i \<noteq> j \<Longrightarrow> list_augment (list_augment \<sigma> j v) i u = list_augment (list_augment \<sigma> i u) j v"
  by (simp add: list_augment_twice list_update_swap max.commute)

text \<open>We can also prove that we can always retrieve an element we have added to the list, since
  @{term list_augment} extends the list when necessary. This isn't true of @{term list_update}. \<close>

lemma nth_list_augment: "list_augment xs k v ! k = v"
  by (simp add: list_augment_def list_pad_out_def)

lemma nth'_list_augment: "nth' (list_augment xs k v) k = v"
  by (auto simp add: nth'_def nth_list_augment list_augment_def list_pad_out_def)

text \<open>We also have it that @{term list_augment} cancels itself.\<close>

lemma list_augment_same_twice: "list_augment (list_augment xs k u) k v = list_augment xs k v"
  by (simp add: list_augment_def list_pad_out_def)

lemma nth'_list_augment_diff: "i \<noteq> j \<Longrightarrow> nth' (list_augment \<sigma> i v) j = nth' \<sigma> j"
  by (auto simp add: list_augment_def list_pad_out_def nth_append nth'_def)

text \<open>Finally we can create the list lenses, of which there are three varieties. One that allows
  us to view an index, one that allows us to view the head, and one that allows us to view the tail.
  They are all mainly well-behaved lenses.\<close>

definition list_lens :: "nat \<Rightarrow> ('a::two \<Longrightarrow> 'a list)" where
[lens_defs]: "list_lens i = \<lparr> lens_get = (\<lambda> xs. nth' xs i)
                            , lens_put = (\<lambda> xs x. list_augment xs i x) \<rparr>"

abbreviation "hd_lens \<equiv> list_lens 0"

definition tl_lens :: "'a list \<Longrightarrow> 'a list" where
[lens_defs]: "tl_lens = \<lparr> lens_get = (\<lambda> xs. tl xs)
                        , lens_put = (\<lambda> xs xs'. hd xs # xs') \<rparr>"

lemma list_mwb_lens: "mwb_lens (list_lens x)"
  by (unfold_locales, simp_all add: list_lens_def nth'_list_augment list_augment_same_twice)

lemma tail_lens_mwb:
  "mwb_lens tl_lens"
  by (unfold_locales, simp_all add: tl_lens_def)

text \<open>Independence of list lenses follows when the two indices are different.\<close>

lemma list_lens_indep:
  "i \<noteq> j \<Longrightarrow> list_lens i \<bowtie> list_lens j"
  by (simp add: list_lens_def lens_indep_def list_augment_commute nth'_list_augment_diff)

lemma hd_tl_lens_indep [simp]:
  "hd_lens \<bowtie> tl_lens"
  apply (rule lens_indepI)
    apply (simp_all add: list_lens_def tl_lens_def)
    apply (metis hd_conv_nth hd_def length_greater_0_conv list.case(1) nth'_def nth'_list_augment)
   apply (metis (full_types) hd_conv_nth hd_def length_greater_0_conv list.case(1) nth'_def)
  apply (metis Nitpick.size_list_simp(2) One_nat_def add_Suc_right append.simps(1) append_Nil2 diff_Suc_Suc diff_zero hd_Cons_tl list.inject list.size(4) list_augment_0 list_augment_def list_augment_same_twice list_pad_out_def nth_list_augment replicate.simps(1) replicate.simps(2) tl_Nil)
done

subsection \<open>Record Field Lenses\<close>

text \<open>We also add support for record lenses. Every record created can yield a lens for each field.
  These cannot be created generically and thus must be defined case by case as new records are
  created. We thus create a new Isabelle outer syntax command \textbf{alphabet} which enables this.
  We first create syntax that allows us to obtain a lens from a given field using the internal
  record syntax translations.\<close>

abbreviation (input) "fld_put f \<equiv> (\<lambda> \<sigma> u. f (\<lambda>_. u) \<sigma>)"

syntax "_FLDLENS" :: "id \<Rightarrow> ('a \<Longrightarrow> 'r)"  ("FLDLENS _")
translations "FLDLENS x" => "\<lparr> lens_get = x, lens_put = CONST fld_put (_update_name x) \<rparr>"

text \<open>We also introduce the \textbf{alphabet} command that creates a record with lenses for each field.
  For each field a lens is created together with a proof that it is very well-behaved, and for each
  pair of lenses an independence theorem is generated. Alphabets can also be extended which yields
  sublens proofs between the extension field lens and record extension lenses. \<close>

ML_file "Lens_Record.ML"

text \<open>The following theorem attribute stores splitting theorems for alphabet types which which is useful
  for proof automation.\<close>

named_theorems alpha_splits

text \<open>The alphabet command supports syntax illustrated in the following comments.\<close>

(*
alphabet mylens =
  x :: nat
  y :: string

lemma mylens_bij_lens:
  "bij_lens (x +\<^sub>L y +\<^sub>L mylens_child_lens)"
  by (unfold_locales, simp_all add: lens_plus_def x_def y_def mylens_child_lens_def id_lens_def sublens_def lens_comp_def prod.case_eq_if)

alphabet mylens_2 = mylens +
  z :: int
  k :: "string list"

alphabet mylens_3 = mylens_2 +
  n :: real
  h :: nat
*)

subsection \<open>Mapper Lenses\<close>

definition lmap_lens ::
  "(('\<alpha> \<Rightarrow> '\<beta>) \<Rightarrow> ('\<gamma> \<Rightarrow> '\<delta>)) \<Rightarrow>
   (('\<beta> \<Rightarrow> '\<alpha>) \<Rightarrow> '\<delta> \<Rightarrow> '\<gamma>) \<Rightarrow>
   ('\<gamma> \<Rightarrow> '\<alpha>) \<Rightarrow>
   ('\<beta> \<Longrightarrow> '\<alpha>) \<Rightarrow>
   ('\<delta> \<Longrightarrow> '\<gamma>)" where
  [lens_defs]:
  "lmap_lens f g h l = \<lparr>
  lens_get = f (get\<^bsub>l\<^esub>),
  lens_put = g o (put\<^bsub>l\<^esub>) o h \<rparr>"

text \<open>
  The parse translation below yields a heterogeneous mapping lens for any
  record type. This achieved through the utility function above that
  constructs a functorial lens. This takes as input a heterogeneous mapping
  function that lifts a function on a record's extension type to an update
  on the entire record, and also the record's ``more'' function. The first input
  is given twice as it has different polymorphic types, being effectively
  a type functor construction which are not explicitly supported by HOL. We note
  that the \<open>more_update\<close> function does something similar to the extension lifting,
  but is not precisely suitable here since it only considers homogeneous functions,
  namely of type \<open>'a \<Rightarrow> 'a\<close> rather than \<open>'a \<Rightarrow> 'b\<close>.
\<close>

syntax
  "_lmap" :: "id \<Rightarrow> logic" ("lmap[_]")

ML \<open>
  fun lmap_tr [Free (name, _)] =
    let
      val extend = Free (name ^ ".extend", dummyT);
      val truncate = Free (name ^ ".truncate", dummyT);
      val more = Free (name ^ ".more", dummyT);
      val map_ext = Abs ("f", dummyT,
                    Abs ("r", dummyT,
                      extend $ (truncate $ Bound 0) $ (Bound 1 $ (more $ (Bound 0)))))

    in
      Const (@{const_syntax "lmap_lens"}, dummyT) $ map_ext $ map_ext $ more
    end
  | lmap_tr _ = raise Match;
\<close>

parse_translation \<open>[(@{syntax_const "_lmap"}, K lmap_tr)]\<close>

subsection \<open>Lens Interpretation\<close>

named_theorems lens_interp_laws

locale lens_interp = interp
begin
declare meta_interp_law [lens_interp_laws]
declare all_interp_law [lens_interp_laws]
declare exists_interp_law [lens_interp_laws]
end
end


theory Samplers
imports Main
begin

section {* Utility Lemmas *}

text {*
  The following lemmas about strictly monotonic functions could go
  to the standard library of Isabelle/HOL.
*}

text {*
  Strongly monotonic functions over the integers grow without bound.
*}
lemma strict_mono_exceeds:
  assumes f: "strict_mono (f::nat \<Rightarrow> nat)"
  shows "\<exists>k. n < f k"
proof (induct n)
  from f have "f 0 < f 1" by (rule strict_monoD) simp
  hence "0 < f 1" by simp
  thus "\<exists>k. 0 < f k" ..
next
  fix n
  assume "\<exists>k. n < f k"
  then obtain k where "n < f k" ..
  hence "Suc n \<le> f k" by simp
  also from f have "f k < f (Suc k)" by (rule strict_monoD) simp
  finally show "\<exists>k. Suc n < f k" ..
qed

text {*
  More precisely, any natural number @{text "n \<ge> f 0"} lies in the interval
  between @{text "f k"} and @{text "f (Suc k)"}, for some @{text k}.
*}
lemma strict_mono_interval:
  assumes f: "strict_mono (f::nat \<Rightarrow> nat)" and n: "f 0 \<le> n"
  obtains k where "f k \<le> n" and "n < f (Suc k)"
proof -
  from f[THEN strict_mono_exceeds] obtain m where m: "n < f m" ..
  have "m \<noteq> 0"
  proof
    assume "m = 0"
    with m n show "False" by simp
  qed
  with m obtain m' where m': "n < f (Suc m')" by (auto simp: gr0_conv_Suc)
  let ?k = "LEAST k. n < f (Suc k)"
  from m' have 1: "n < f (Suc ?k)" by (rule LeastI)
  have "f ?k \<le> n"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    hence k: "n < f ?k" by simp
    show "False"
    proof (cases "?k")
      case 0 with k n show "False" by simp
    next
      case Suc with k show "False" by (auto dest: Least_le)
    qed
  qed
  with 1 that show ?thesis by simp
qed

lemma strict_mono_comp:
  assumes g: "strict_mono (g::'a::order \<Rightarrow> 'b::order)"
      and f: "strict_mono (f::'b::order \<Rightarrow> 'c::order)"
  shows "strict_mono (f \<circ> g)"
  using assms by (auto simp: strict_mono_def)

text {*
  We represent @{text \<omega>}-words as functions of type @{text "nat \<Rightarrow> 'a"}.
  Suffixes of @{text \<omega>}-words are simply obtained by index shifting,
  and we introduce a convenient notation.
*}

definition suffix :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> 'a)"   ("_[_ ..]" [80, 15] 80) where
  "\<sigma>[n..] \<equiv> \<lambda>i. \<sigma> (n + i)"

lemma suffix_elt [simp]: "(\<sigma>[n..]) i = \<sigma> (n+i)"
  by (simp add: suffix_def)

lemma suffix_0 [simp]: "\<sigma>[0..] = \<sigma>"
  by (simp add: suffix_def)

lemma suffix_suffix [simp]: "\<sigma>[n..][m..] = \<sigma>[n+m ..]"
  by (simp add: suffix_def add.assoc)

section {* Stuttering Sampling Functions *}

text {*
  Given an @{text \<omega>}-sequence @{text "\<sigma>"}, a stuttering sampling function
  is a strictly monotonic function @{text "f::nat \<Rightarrow> nat"} such that
  @{text "f 0 = 0"} and for all @{text i} and all @{text "f i \<le> k < f (i+1)"},
  the elements @{text "\<sigma> k"} are the same. In other words, @{text f} skips some
  (but not necessarily all) stuttering steps, but never skips a non-stuttering step.
  Given such @{text "\<sigma>"} and @{text f}, the (stuttering-)sampled
  reduction of @{text "\<sigma>"} is the sequence of elements of @{text "\<sigma>"} at the
  indices @{text "f i"}, which can simply be written as @{text "\<sigma> \<circ> f"}.
*}

subsection {* Definition and elementary properties *}

definition stutter_sampler where
  -- {* f is a stuttering sampling function for @{text "\<sigma>"} *}
  "stutter_sampler (f::nat \<Rightarrow> nat) \<sigma> \<equiv>
     f 0 = 0
   \<and> strict_mono f
   \<and> (\<forall>k n. f k < n \<and> n < f (Suc k) \<longrightarrow> \<sigma> n = \<sigma> (f k))"

lemma stutter_sampler_0: "stutter_sampler f \<sigma> \<Longrightarrow> f 0 = 0"
  by (simp add: stutter_sampler_def)

lemma stutter_sampler_mono: "stutter_sampler f \<sigma> \<Longrightarrow> strict_mono f"
  by (simp add: stutter_sampler_def)

lemma stutter_sampler_between:
  assumes f: "stutter_sampler f \<sigma>"
      and lo: "f k \<le> n" and hi: "n < f (Suc k)"
    shows "\<sigma> n = \<sigma> (f k)"
  using assms by (auto simp: stutter_sampler_def less_le)

lemma stutter_sampler_interval:
  assumes f: "stutter_sampler f \<sigma>"
  obtains k where "f k \<le> n" and "n < f (Suc k)"
using f[THEN stutter_sampler_mono] proof (rule strict_mono_interval)
  from f show "f 0 \<le> n" by (simp add: stutter_sampler_0)
qed

text {*
  The identity function is a stuttering sampling function for any @{text "\<sigma>"}.
*}
lemma id_stutter_sampler [iff]: "stutter_sampler id \<sigma>"
  by (auto simp: stutter_sampler_def strict_mono_def)

text {*
  Stuttering sampling functions compose, sort of.
*}
lemma stutter_sampler_comp:
  assumes f: "stutter_sampler f \<sigma>"
      and g: "stutter_sampler g (\<sigma> \<circ> f)"
  shows "stutter_sampler (f \<circ> g) \<sigma>"
proof (auto simp: stutter_sampler_def)
  from f g show "f (g 0) = 0" by (simp add: stutter_sampler_0)
next
  from g[THEN stutter_sampler_mono] f[THEN stutter_sampler_mono]
  show "strict_mono (f \<circ> g)" by (rule strict_mono_comp)
next
  fix i k
  assume lo: "f (g i) < k" and hi: "k < f (g (Suc i))"
  from f obtain m where 1: "f m \<le> k" and 2: "k < f (Suc m)"
    by (rule stutter_sampler_interval)
  with f have 3: "\<sigma> k = \<sigma> (f m)" by (rule stutter_sampler_between)
  from lo 2 have "f (g i) < f (Suc m)" by simp
  with f[THEN stutter_sampler_mono] have 4: "g i \<le> m" by (simp add: strict_mono_less)
  from 1 hi have "f m < f (g (Suc i))" by simp
  with f[THEN stutter_sampler_mono] have 5: "m < g (Suc i)"by (simp add: strict_mono_less)
  from g 4 5 have "(\<sigma> \<circ> f) m = (\<sigma> \<circ> f) (g i)" by (rule stutter_sampler_between)
  with 3 show "\<sigma> k = \<sigma> (f (g i))" by simp
qed

text {*
  Stuttering sampling functions can be extended to suffixes.
*}
lemma stutter_sampler_suffix:
  assumes f: "stutter_sampler f \<sigma>"
  shows "stutter_sampler (\<lambda>k. f (n+k) - f n) (\<sigma>[f n ..])"
proof (auto simp: stutter_sampler_def strict_mono_def)
  fix i j
  assume ij: "(i::nat) < j"
  from f have mono: "strict_mono f" by (rule stutter_sampler_mono)

  from mono[THEN strict_mono_mono] have "f n \<le> f (n+i)"
    by (rule monoD) simp
  moreover
  from mono[THEN strict_mono_mono] have "f n \<le> f (n+j)"
    by (rule monoD) simp
  moreover
  from mono ij have "f (n+i) < f (n+j)" by (auto intro: strict_monoD)
  ultimately
  show "f (n+i) - f n < f (n+j) - f n" by simp
next
  fix i k
  assume lo: "f (n+i) - f n < k" and hi: "k < f (Suc (n+i)) - f n"
  from lo have "f (n+i) \<le> f n + k" by simp
  moreover
  from hi have "f n + k < f (Suc (n + i))" by simp
  moreover
  from f[THEN stutter_sampler_mono, THEN strict_mono_mono]
  have "f n \<le> f (n+i)" by (rule monoD) simp
  ultimately show "\<sigma> (f n + k) = \<sigma> (f n + (f (n+i) - f n))"
    by (auto dest: stutter_sampler_between[OF f])
qed

subsection {* Preservation of properties through stuttering sampling *}

text {*
  Stuttering sampling preserves the initial element of the sequence, as well as
  the presence and relative ordering of different elements.
*}

lemma stutter_sampled_0:
  assumes "stutter_sampler f \<sigma>"
  shows "\<sigma> (f 0) = \<sigma> 0"
  using assms[THEN stutter_sampler_0] by simp

lemma stutter_sampled_in_range:
  assumes f: "stutter_sampler f \<sigma>" and s: "s \<in> range \<sigma>"
  shows "s \<in> range (\<sigma> \<circ> f)"
proof -
  from s obtain n where n: "\<sigma> n = s" by auto
  from f obtain k where "f k \<le> n" "n < f (Suc k)" by (rule stutter_sampler_interval)
  with f have "\<sigma> n = \<sigma> (f k)" by (rule stutter_sampler_between)
  with n show ?thesis by auto
qed

lemma stutter_sampled_range:
  assumes "stutter_sampler f \<sigma>"
  shows "range (\<sigma> \<circ> f) = range \<sigma>"
  using assms by (auto intro: stutter_sampled_in_range)

lemma stutter_sampled_precedence:
  assumes f: "stutter_sampler f \<sigma>" and ij: "i \<le> j"
  obtains k l where "k \<le> l" "\<sigma> (f k) = \<sigma> i" "\<sigma> (f l) = \<sigma> j"
proof -
  from f obtain k where k: "f k \<le> i" "i < f (Suc k)" by (rule stutter_sampler_interval)
  with f have 1: "\<sigma> i = \<sigma> (f k)" by (rule stutter_sampler_between)
  from f obtain l where l: "f l \<le> j" "j < f (Suc l)" by (rule stutter_sampler_interval)
  with f have 2: "\<sigma> j = \<sigma> (f l)" by (rule stutter_sampler_between)
  from k l ij have "f k < f (Suc l)" by simp
  with f[THEN stutter_sampler_mono] have "k \<le> l" by (simp add: strict_mono_less)
  with 1 2 that show ?thesis by simp
qed

subsection {* Maximal stuttering sampling *}

text {*
  We define a particular sampling function that is maximal in the sense that it
  eliminates all finite stuttering. If a sequence ends with infinite stuttering
  then it behaves as the identity over the (maximal such) suffix.
*}

fun max_stutter_sampler where
  "max_stutter_sampler \<sigma> 0 = 0"
| "max_stutter_sampler \<sigma> (Suc n) =
    (let prev = max_stutter_sampler \<sigma> n
     in  if (\<forall>k > prev. \<sigma> k = \<sigma> prev)
         then Suc prev
         else (LEAST k. prev < k \<and> \<sigma> k \<noteq> \<sigma> prev))"

text {*
  @{text max_stutter_sampler} is indeed a stuttering sampling function.
*}
lemma max_stutter_sampler:
  "stutter_sampler (max_stutter_sampler \<sigma>) \<sigma>" (is "stutter_sampler ?ms _")
proof -
  have "?ms 0 = 0" by simp
  moreover
  have "\<forall>n. ?ms n < ?ms (Suc n)"
  proof
    fix n
    show "?ms n < ?ms (Suc n)" (is "?prev < ?next")
    proof (cases "\<forall>k > ?prev. \<sigma> k = \<sigma> ?prev")
      case True thus ?thesis by (simp add: Let_def)
    next
      case False
      hence "\<exists>k. ?prev < k \<and> \<sigma> k \<noteq> \<sigma> ?prev" by simp
      from this[THEN LeastI_ex]
      have "?prev < (LEAST k. ?prev < k \<and> \<sigma> k \<noteq> \<sigma> ?prev)" ..
      with False show ?thesis by (simp add: Let_def)
    qed
  qed
  hence "strict_mono ?ms"
    unfolding strict_mono_def by (blast intro: lift_Suc_mono_less)
  moreover
  have "\<forall>n k. ?ms n < k \<and> k < ?ms (Suc n) \<longrightarrow> \<sigma> k = \<sigma> (?ms n)"
  proof (clarify)
    fix n k
    assume lo: "?ms n < k" (is "?prev < k")
       and hi: "k < ?ms (Suc n)" (is "k < ?next")
    show "\<sigma> k = \<sigma> ?prev"
    proof (cases "\<forall>k > ?prev. \<sigma> k = \<sigma> ?prev")
      case True
      hence "?next = Suc ?prev" by (simp add: Let_def)
      with lo hi show ?thesis by simp  -- {* no room for intermediate index *}
    next
      case False
      hence "?next = (LEAST k. ?prev < k \<and> \<sigma> k \<noteq> \<sigma> ?prev)"
        by (auto simp add: Let_def)
      with lo hi show ?thesis by (auto dest: not_less_Least)
    qed
  qed
  ultimately show ?thesis unfolding stutter_sampler_def by blast
qed

text {*
  We write @{text "\<natural>\<sigma>"} for the sequence @{text "\<sigma>"} sampled by the
  maximal stuttering sampler. Also, a sequence is \emph{stutter free}
  if it contains no finite stuttering: whenever two subsequent
  elements are equal then all subsequent elements are the same.
*}
definition stutter_reduced ("\<natural>_" [100] 100) where
  "\<natural>\<sigma> = \<sigma> \<circ> (max_stutter_sampler \<sigma>)"

definition stutter_free where
  "stutter_free \<sigma> \<equiv> \<forall>k. \<sigma> (Suc k) = \<sigma> k \<longrightarrow> (\<forall>n>k. \<sigma> n = \<sigma> k)"

lemma stutter_freeI:
  assumes "\<And>k n. \<lbrakk>\<sigma> (Suc k) = \<sigma> k; n>k\<rbrakk> \<Longrightarrow> \<sigma> n = \<sigma> k"
  shows "stutter_free \<sigma>"
  using assms unfolding stutter_free_def by blast

lemma stutter_freeD:
  assumes "stutter_free \<sigma>" and "\<sigma> (Suc k) = \<sigma> k" and "n>k"
  shows "\<sigma> n = \<sigma> k"
  using assms unfolding stutter_free_def by blast

text {*
  Any suffix of a stutter free sequence is itself stutter free.
*}
lemma stutter_free_suffix:
  assumes sigma: "stutter_free \<sigma>"
  shows "stutter_free (\<sigma>[k..])"
proof (rule stutter_freeI)
  fix j n
  assume j: "(\<sigma>[k..]) (Suc j) = (\<sigma>[k..]) j" and n: "j < n"
  from j have "\<sigma> (Suc (k+j)) = \<sigma> (k+j)" by simp
  moreover from n have "k+n > k+j" by simp
  ultimately have "\<sigma> (k+n) = \<sigma> (k+j)" by (rule stutter_freeD[OF sigma])
  thus "(\<sigma>[k..]) n = (\<sigma>[k..]) j" by simp
qed

lemma stutter_reduced_0: "(\<natural>\<sigma>) 0 = \<sigma> 0"
  by (simp add: stutter_reduced_def stutter_sampled_0 max_stutter_sampler)

lemma stutter_free_reduced:
  assumes sigma: "stutter_free \<sigma>"
  shows "\<natural>\<sigma> = \<sigma>"
proof -
  {
    fix n
    have "max_stutter_sampler \<sigma> n = n" (is "?ms n = n")
    proof (induct n)
      show "?ms 0 = 0" by simp
    next
      fix n
      assume ih: "?ms n = n"
      show "?ms (Suc n) = Suc n"
      proof (cases "\<sigma> (Suc n) = \<sigma> (?ms n)")
        case True
        with ih have "\<sigma> (Suc n) = \<sigma> n" by simp
        with sigma have "\<forall>k > n. \<sigma> k = \<sigma> n"
          unfolding stutter_free_def by blast
        with ih show ?thesis by (simp add: Let_def)
      next
        case False
        with ih have "(LEAST k. k>n \<and> \<sigma> k \<noteq> \<sigma> (?ms n)) = Suc n"
          by (auto intro: Least_equality)
        with ih False show ?thesis by (simp add: Let_def)
      qed
    qed
  }
  thus ?thesis by (auto simp: stutter_reduced_def)
qed

text {*
  Whenever two sequence elements at two consecutive sampling points of the
  maximal stuttering sampler are equal then the sequence stutters infinitely
  from the first sampling point onwards. In particular, @{text "\<natural>\<sigma>"} is
  stutter free.
*}
lemma max_stutter_sampler_nostuttering:
  assumes stut: "\<sigma> (max_stutter_sampler \<sigma> (Suc k)) = \<sigma> (max_stutter_sampler \<sigma> k)"
      and n: "n > max_stutter_sampler \<sigma> k" (is "_ > ?ms k")
  shows "\<sigma> n = \<sigma> (?ms k)"
proof (rule ccontr)
  assume contr: "\<not> ?thesis"
  with n have "?ms k < n \<and> \<sigma> n \<noteq> \<sigma> (?ms k)" (is "?diff n") ..
  hence "?diff (LEAST n. ?diff n)" by (rule LeastI)
  with contr have "\<sigma> (?ms (Suc k)) \<noteq> \<sigma> (?ms k)" by (auto simp add: Let_def)
  from this stut show "False" ..
qed

lemma stutter_reduced_stutter_free: "stutter_free (\<natural>\<sigma>)"
proof (rule stutter_freeI)
  fix k n
  assume k: "(\<natural>\<sigma>) (Suc k) = (\<natural>\<sigma>) k" and n: "k < n"
  from n have "max_stutter_sampler \<sigma> k < max_stutter_sampler \<sigma> n"
    using max_stutter_sampler[THEN stutter_sampler_mono, THEN strict_monoD]
    by blast
  with k show "(\<natural>\<sigma>) n = (\<natural>\<sigma>) k"
    unfolding stutter_reduced_def
    by (auto elim: max_stutter_sampler_nostuttering
             simp del: max_stutter_sampler.simps)
qed

lemma stutter_reduced_suffix: "\<natural>((\<natural>\<sigma>)[k..]) = (\<natural>\<sigma>)[k..]"
proof (rule stutter_free_reduced)
  have "stutter_free (\<natural>\<sigma>)" by (rule stutter_reduced_stutter_free)
  thus "stutter_free ((\<natural>\<sigma>)[k..])" by (rule stutter_free_suffix)
qed

lemma stutter_reduced_reduced: "\<natural>\<natural>\<sigma> = \<natural>\<sigma>"
  by (rule stutter_reduced_suffix[of "\<sigma>" "0", simplified])

text {*
  One can define a partial order on sampling functions for a given sequence
  @{text "\<sigma>"} by saying that function @{text g} is better than function @{text f}
  if the reduced sequence induced by @{text f} can be further reduced to obtain
  the reduced sequence corresponding to @{text g}, i.e. if there exists a
  stuttering sampling function @{text h} for the reduced sequence @{text "\<sigma> \<circ> f"}
  such that @{text "\<sigma> \<circ> f \<circ> h = \<sigma> \<circ> g"}. (Note that @{text "f \<circ> h"} is indeed a stuttering
  sampling function for @{text "\<sigma>"}, by theorem @{text "stutter_sampler_comp"}.)

  We do not formalize this notion but prove that @{text "max_stutter_sampler \<sigma>"}
  is the best sampling function according to this order.
*}

theorem sample_max_sample:
  assumes f: "stutter_sampler f \<sigma>"
  shows "\<natural>(\<sigma> \<circ> f) = \<natural>\<sigma>"
proof -
  let ?mss = "max_stutter_sampler \<sigma>"
  let ?mssf = "max_stutter_sampler (\<sigma> \<circ> f)"
  from f have mssf: "stutter_sampler (f \<circ> ?mssf) \<sigma>"
    by (blast intro: stutter_sampler_comp max_stutter_sampler)
  txt {*
    The following is the core invariant of the proof: the sampling functions
    @{text "max_stutter_sampler \<sigma>"} and @{text "f \<circ> (max_stutter_sampler (\<sigma> \<circ> f))"}
    work in lock-step (i.e., sample the same points), except if @{text "\<sigma>"} ends
    in infinite stuttering, at which point function @{text f} may make larger
    steps than the maximal sampling functions.
  *}
  {
    fix k
    have "  ?mss k = f (?mssf k)
          \<or> ?mss k \<le> f (?mssf k) \<and> (\<forall>n \<ge> ?mss k. \<sigma> (?mss k) = \<sigma> n)"
          (is "?P k" is "?A k \<or> ?B k")
    proof (induct k)
      from f mssf have "?mss 0 = f (?mssf 0)"
        by (simp add: max_stutter_sampler stutter_sampler_0)
      thus "?P 0" ..
    next
      fix k
      assume ih: "?P k"
      have b: "?B k \<longrightarrow> ?B (Suc k)"
      proof
        assume 0: "?B k" hence 1: "?mss k \<le> f (?mssf k)" ..
        (* NB: For some reason "... hence 1: ... and 2: ..." cannot be proved *)
        from 0 have 2: "\<forall>n \<ge> ?mss k. \<sigma> (?mss k) = \<sigma> n" ..
        hence "\<forall>n > ?mss k. \<sigma> (?mss k) = \<sigma> n" by auto
        hence "\<forall>n > ?mss k. \<sigma> n = \<sigma> (?mss k)" by auto
        hence 3: "?mss (Suc k) = Suc (?mss k)" by (simp add: Let_def)
        with 2 have "\<sigma> (?mss k) = \<sigma> (?mss (Suc k))"
          by (auto simp del: max_stutter_sampler.simps)
        from sym[OF this] 2 3 have "\<forall>n \<ge> ?mss (Suc k). \<sigma> (?mss (Suc k)) = \<sigma> n"
          by (auto simp del: max_stutter_sampler.simps)
        moreover
        from mssf[THEN stutter_sampler_mono, THEN strict_monoD]
        have "f (?mssf k) < f (?mssf (Suc k))"
          by (simp del: max_stutter_sampler.simps)
        with 1 3 have "?mss (Suc k) \<le> f (?mssf (Suc k))"
          by (simp del: max_stutter_sampler.simps)
        ultimately show "?B (Suc k)" by blast
      qed
      from ih show "?P (Suc k)"
      proof
        assume a: "?A k"
        show ?thesis
        proof (cases "\<forall>n > ?mss k. \<sigma> n = \<sigma> (?mss k)")
          case True
          hence "\<forall>n \<ge> ?mss k. \<sigma> (?mss k) = \<sigma> n" by (auto simp: le_less)
          with a have "?B k" by simp
          with b show ?thesis by (simp del: max_stutter_sampler.simps)
        next
          case False
          hence diff: "\<sigma> (?mss (Suc k)) \<noteq> \<sigma> (?mss k)"
            by (blast dest: max_stutter_sampler_nostuttering)
          have "?A (Suc k)"
          proof (rule antisym)
            show "f (?mssf (Suc k)) \<le> ?mss (Suc k)"
            proof (rule ccontr)
              assume "\<not> ?thesis"
              hence contr: "?mss (Suc k) < f (?mssf (Suc k))" by simp
              from mssf have "\<sigma> (?mss (Suc k)) = \<sigma> ((f \<circ> ?mssf) k)"
              proof (rule stutter_sampler_between)
                from max_stutter_sampler[of "\<sigma>", THEN stutter_sampler_mono]
                have "?mss k < ?mss (Suc k)" by (rule strict_monoD) simp
                with a show "(f \<circ> ?mssf) k \<le> ?mss (Suc k)"
                  by (simp add: o_def del: max_stutter_sampler.simps)
              next
                from contr show "?mss (Suc k) < (f \<circ> ?mssf) (Suc k)" by simp
              qed
              with a have "\<sigma> (?mss (Suc k)) = \<sigma> (?mss k)"
                by (simp add: o_def del: max_stutter_sampler.simps)
              with diff show "False" ..
            qed
          next
            have "\<exists>m > ?mssf k. f m = ?mss (Suc k)"
            proof (rule ccontr)
              assume "\<not> ?thesis"
              hence contr: "\<forall>i. f ((?mssf k) + Suc i) \<noteq> ?mss (Suc k)" by simp
              {
                fix i
                have "f (?mssf k + i) < ?mss (Suc k)" (is "?F i")
                proof (induct i)
                  from a have "f (?mssf k + 0) = ?mss k" by (simp add: o_def)
                  also from max_stutter_sampler[of "\<sigma>", THEN stutter_sampler_mono]
                       have "... < ?mss (Suc k)"
                         by (rule strict_monoD) simp
                  finally show "?F 0" .
                next
                  fix i
                  assume ih: "?F i"
                  show "?F (Suc i)"
                  proof (rule ccontr)
                    assume "\<not> ?thesis"
                    then have "?mss (Suc k) \<le> f (?mssf k + Suc i)"
                      by (simp add: o_def)
                    moreover from contr have "f (?mssf k + Suc i) \<noteq> ?mss (Suc k)"
                      by blast
                    ultimately have i: "?mss (Suc k) < f (?mssf k + Suc i)"
                      by (simp add: less_le)
                    from f have "\<sigma> (?mss (Suc k)) = \<sigma> (f (?mssf k + i))"
                    proof (rule stutter_sampler_between)
                      from ih show "f (?mssf k + i) \<le> ?mss (Suc k)"
                        by (simp add: o_def)
                    next
                      from i show "?mss (Suc k) < f (Suc (?mssf k + i))"
                        by simp
                    qed
                    also from max_stutter_sampler have "... = \<sigma> (?mss k)"
                    proof (rule stutter_sampler_between)
                      from f[THEN stutter_sampler_mono, THEN strict_mono_mono]
                      have "f (?mssf k) \<le> f (?mssf k + i)" by (rule monoD) simp
                      with a show "?mss k \<le> f (?mssf k + i)" by (simp add: o_def)
                    qed (rule ih)
                    also note diff
                    finally show "False" by simp
                  qed
                qed
              } note bounded = this
              from f[THEN stutter_sampler_mono]
              have "strict_mono (\<lambda>i. f (?mssf k + i))"
                by (auto simp: strict_mono_def)
              then obtain i where i: "?mss (Suc k) < f (?mssf k + i)"
                by (blast dest: strict_mono_exceeds)
              from bounded have "f (?mssf k + i) < ?mss (Suc k)" .
              with i show "False" by (simp del: max_stutter_sampler.simps)
            qed
            then obtain m where m: "m > ?mssf k" and m': "f m = ?mss (Suc k)"
              by blast
            show "?mss (Suc k) \<le> f (?mssf (Suc k))"
            proof (rule ccontr)
              assume "\<not> ?thesis"
              hence contr: "f (?mssf (Suc k)) < ?mss (Suc k)" by simp
              from mssf[THEN stutter_sampler_mono]
              have "(f \<circ> ?mssf) k < (f \<circ> ?mssf) (Suc k)"
                by (rule strict_monoD) simp
              with a have "?mss k \<le> f (?mssf (Suc k))"
                by (simp add: o_def)
              from this contr have "\<sigma> (f (?mssf (Suc k))) = \<sigma> (?mss k)"
                by (rule stutter_sampler_between[OF max_stutter_sampler])
              with a have stut: "(\<sigma> \<circ> f) (?mssf (Suc k)) = (\<sigma> \<circ> f) (?mssf k)"
                by (simp add: o_def)
              from this m have "(\<sigma> \<circ> f) m = (\<sigma> \<circ> f) (?mssf k)"
                by (blast intro: max_stutter_sampler_nostuttering)
              with diff m' a show "False"
                by (simp add: o_def)
            qed
          qed
          thus ?thesis ..
        qed
      next
        assume "?B k" with b show ?thesis by (simp del: max_stutter_sampler.simps)
      qed
    qed
  }
  hence "\<natural>\<sigma> = \<natural>(\<sigma> \<circ> f)" unfolding stutter_reduced_def by force
  thus ?thesis by (rule sym)
qed

end  (* theory Samplers *)


section\<open>Lemmas possibly destined for future Isabelle releases\<close>

theory Fourier_Aux2
  imports "HOL-Analysis.Analysis"
begin

lemma integral_sin_Z [simp]:
  assumes "n \<in> \<int>"
  shows "integral\<^sup>L (lebesgue_on {-pi..pi}) (\<lambda>x. sin(x * n)) = 0"
  proof (subst lebesgue_integral_eq_integral)
  show "integrable (lebesgue_on {-pi..pi}) (\<lambda>x. sin (x * n))"
    by (intro continuous_imp_integrable_real continuous_intros)
  show "integral {-pi..pi} (\<lambda>x. sin (x * n)) = 0"
    using assms Ints_cases integral_sin_nx by blast
qed auto

lemma integral_cos_Z' [simp]:
  assumes "n \<in> \<int>"
  shows "integral\<^sup>L (lebesgue_on {-pi..pi}) (\<lambda>x. cos(n * x)) = (if n = 0 then 2 * pi else 0)"
  by (metis assms integral_cos_Z mult_commute_abs)

lemma odd_even_cases [case_names 0 odd even]:
  assumes "P 0" and odd: "\<And>n. P(Suc (2 * n))" and even: "\<And>n. P(2 * n + 2)"
  shows "P n"
  by (metis nat_induct2 One_nat_def Suc_1 add_Suc_right assms(1) dvdE even odd oddE)

end


theory Exercise3
  imports Main
begin

fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
  "count x Nil = 0"
  | "count x (Cons y xs) =
      (if x=y
        then Suc (count x xs)
        else (count x xs))"

theorem count_less_than_size [simp]: "count x xs \<le> length xs"
  apply (induction xs)
  apply (auto)
done

end


section \<open>The Ford-Fulkerson Theorem\<close>
theory Ford_Fulkerson
imports Augmenting_Flow Augmenting_Path
begin
text \<open>In this theory, we prove the Ford-Fulkerson theorem,
  and its well-known corollary, the min-cut max-flow theorem.
\<close>

text \<open>We fix a network with a flow and a cut\<close>
locale NFlowCut = NFlow c s t f + NCut c s t k
  for c :: "'capacity::linordered_idom graph" and s t f k
begin

lemma finite_k[simp, intro!]: "finite k"
  using cut_ss_V finite_V finite_subset[of k V] by blast

subsection \<open>Net Flow\<close>
text \<open>We define the \emph{net flow} to be the amount of flow effectively
  passed over the cut from the source to the sink:\<close>
definition netFlow :: "'capacity"
  where "netFlow \<equiv> (\<Sum>e \<in> outgoing' k. f e) - (\<Sum>e \<in> incoming' k. f e)"

text \<open>We can show that the net flow equals the value of the flow.
  Note: Cormen et al.~\<^cite>\<open>"CLRS09"\<close> present a whole page full of
  summation calculations for this proof, and our formal proof also
  looks quite complicated.
\<close>
lemma flow_value: "netFlow = val"
proof -
  let ?LCL = "{(u, v). u \<in> k \<and> v \<in> k \<and> (u, v) \<in> E}"
  let ?AOG = "{(u, v). u \<in> k \<and> (u, v) \<in> E}"
  let ?AIN = "{(v, u) | u v. u \<in> k \<and> (v, u) \<in> E}"
  let ?SOG = "\<lambda>u. (\<Sum>e \<in> outgoing u. f e)"
  let ?SIN = "\<lambda>u. (\<Sum>e \<in> incoming u. f e)"
  let ?SOG' = "(\<Sum>e \<in> outgoing' k. f e)"
  let ?SIN' = "(\<Sum>e \<in> incoming' k. f e)"

  text \<open>Some setup to make finiteness reasoning implicit\<close>
  note [[simproc finite_Collect]]

  have
    "netFlow = ?SOG' + (\<Sum>e \<in> ?LCL. f e) - (?SIN' + (\<Sum>e \<in> ?LCL. f e))"
    (is "_   =        ?SAOG              -          ?SAIN")
    using netFlow_def by auto
  also have "?SAOG = (\<Sum>y \<in> k - {s}. ?SOG y) + ?SOG s"
  proof -
    have "?SAOG = (\<Sum>e\<in>(outgoing' k \<union> ?LCL). f e)"
      by (rule sum.union_disjoint[symmetric]) (auto simp: outgoing'_def)
    also have "outgoing' k \<union> ?LCL = (\<Union>y\<in>k-{s}. outgoing y) \<union> outgoing s"
      by (auto simp: outgoing_def outgoing'_def s_in_cut)
    also have "(\<Sum>e\<in>(\<Union>(outgoing ` (k - {s})) \<union> outgoing s). f e)
      = (\<Sum>e\<in>(\<Union>(outgoing ` (k - {s}))). f e) + (\<Sum>e\<in>outgoing s. f e)"
      by (rule sum.union_disjoint)
         (auto simp: outgoing_def intro: finite_Image)
    also have "(\<Sum>e\<in>(\<Union>(outgoing ` (k - {s}))). f e)
      = (\<Sum>y \<in> k - {s}. ?SOG y)"
      by (rule sum.UNION_disjoint)
         (auto simp: outgoing_def intro: finite_Image)
    finally show ?thesis .
  qed
  also have "?SAIN = (\<Sum>y \<in> k - {s}. ?SIN y) + ?SIN s"
  proof -
    have "?SAIN = (\<Sum>e\<in>(incoming' k \<union> ?LCL). f e)"
      by (rule sum.union_disjoint[symmetric]) (auto simp: incoming'_def)
    also have "incoming' k \<union> ?LCL = (\<Union>y\<in>k-{s}. incoming y) \<union> incoming s"
      by (auto simp: incoming_def incoming'_def s_in_cut)
    also have "(\<Sum>e\<in>(\<Union>(incoming ` (k - {s})) \<union> incoming s). f e)
      = (\<Sum>e\<in>(\<Union>(incoming ` (k - {s}))). f e) + (\<Sum>e\<in>incoming s. f e)"
      by (rule sum.union_disjoint)
         (auto simp: incoming_def intro: finite_Image)
    also have "(\<Sum>e\<in>(\<Union>(incoming ` (k - {s}))). f e)
      = (\<Sum>y \<in> k - {s}. ?SIN y)"
      by (rule sum.UNION_disjoint)
         (auto simp: incoming_def intro: finite_Image)
    finally show ?thesis .
  qed
  finally have "netFlow =
      ((\<Sum>y \<in> k - {s}. ?SOG y) + ?SOG s)
    - ((\<Sum>y \<in> k - {s}. ?SIN y) + ?SIN s)"
    (is "netFlow = ?R") .
  also have "?R = ?SOG s - ?SIN s"
  proof -
    have "(\<And>u. u \<in> k - {s} \<Longrightarrow> ?SOG u = ?SIN u)"
      using conservation_const cut_ss_V t_ni_cut by force
    thus ?thesis by auto
  qed
  finally show ?thesis unfolding val_def by simp
qed

text \<open>The value of any flow is bounded by the capacity of any cut.
  This is intuitively clear, as all flow from the source to the sink has to go
  over the cut.\<close>
corollary weak_duality: "val \<le> cap"
proof -
  have "(\<Sum>e \<in> outgoing' k. f e) \<le> (\<Sum>e \<in> outgoing' k. c e)" (is "?L \<le> ?R")
    using capacity_const by (metis sum_mono)
  then have "(\<Sum>e \<in> outgoing' k. f e) \<le> cap" unfolding cap_def  by simp
  moreover have "val \<le> (\<Sum>e \<in> outgoing' k. f e)" using netFlow_def
    by (simp add: capacity_const flow_value sum_nonneg)
  ultimately show ?thesis by simp
qed

end \<comment> \<open>Cut\<close>

subsection \<open>Ford-Fulkerson Theorem\<close>
context NFlow begin

text \<open>We prove three auxiliary lemmas first, and the state the theorem as a corollary\<close>
lemma fofu_I_II: "isMaxFlow f \<Longrightarrow> \<not> (\<exists> p. isAugmentingPath p)"
unfolding isMaxFlow_alt
proof (rule ccontr)
  assume asm: "NFlow c s t f
    \<and> (\<forall>f'. NFlow c s t f' \<longrightarrow> Flow.val c s f' \<le> Flow.val c s f)"
  assume asm_c: "\<not> \<not> (\<exists> p. isAugmentingPath p)"
  then obtain p where obt: "isAugmentingPath p" by blast
  have fct1: "Flow cf s t (augmentingFlow p)" using obt augFlow_resFlow by auto
  have fct2: "Flow.val cf s (augmentingFlow p) > 0" using obt augFlow_val
    resCap_gzero isAugmentingPath_def cf.isSimplePath_def by auto
  have "NFlow c s t (augment (augmentingFlow p))"
    using fct1 augment_flow_presv Network_axioms
    unfolding Flow_def NFlow_def NPreflow_def
    by auto
  moreover have "Flow.val c s (augment (augmentingFlow p)) > val"
    using fct1 fct2 augment_flow_value by auto
  ultimately show "False" using asm by auto
qed

lemma fofu_II_III:
  "\<not> (\<exists> p. isAugmentingPath p) \<Longrightarrow> \<exists>k'. NCut c s t k' \<and> val = NCut.cap c k'"
proof (intro exI conjI)
  let ?S = "cf.reachableNodes s"
  assume asm: "\<not> (\<exists> p. isAugmentingPath p)"
  hence "t\<notin>?S"
    unfolding isAugmentingPath_def cf.reachableNodes_def cf.connected_def
    by (auto dest: cf.isSPath_pathLE)
  then show CUT: "NCut c s t ?S"
  proof unfold_locales
    show "Graph.reachableNodes cf s \<subseteq> V"
      using cf.reachable_ss_V s_node resV_netV by auto
    show "s \<in> Graph.reachableNodes cf s"
      unfolding Graph.reachableNodes_def Graph.connected_def
      by (metis Graph.isPath.simps(1) mem_Collect_eq)
  qed
  then interpret NCut c s t ?S .
  interpret NFlowCut c s t f ?S by intro_locales

  have "\<forall>(u,v)\<in>outgoing' ?S. f (u,v) = c (u,v)"
  proof (rule ballI, rule ccontr, clarify) \<comment> \<open>Proof by contradiction\<close>
    fix u v
    assume "(u,v)\<in>outgoing' ?S"
    hence "(u,v)\<in>E" "u\<in>?S" "v\<notin>?S"
      by (auto simp: outgoing'_def)
    assume "f (u,v) \<noteq> c (u,v)"
    hence "f (u,v) < c (u,v)"
      using capacity_const by (metis (no_types) eq_iff not_le)
    hence "cf (u, v) \<noteq> 0"
      unfolding residualGraph_def using \<open>(u,v)\<in>E\<close> by auto
    hence "(u, v) \<in> cf.E" unfolding cf.E_def by simp
    hence "v\<in>?S" using \<open>u\<in>?S\<close> by (auto intro: cf.reachableNodes_append_edge)
    thus False using \<open>v\<notin>?S\<close> by auto
  qed
  hence "(\<Sum>e \<in> outgoing' ?S. f e) = cap"
    unfolding cap_def by auto
  moreover
  have "\<forall>(u,v)\<in>incoming' ?S. f (u,v) = 0"
  proof (rule ballI, rule ccontr, clarify) \<comment> \<open>Proof by contradiction\<close>
    fix u v
    assume "(u,v)\<in>incoming' ?S"
    hence "(u,v)\<in>E" "u\<notin>?S" "v\<in>?S" by (auto simp: incoming'_def)
    hence "(v,u)\<notin>E" using no_parallel_edge by auto

    assume "f (u,v) \<noteq> 0"
    hence "cf (v, u) \<noteq> 0"
      unfolding residualGraph_def using \<open>(u,v)\<in>E\<close> \<open>(v,u)\<notin>E\<close> by auto
    hence "(v, u) \<in> cf.E" unfolding cf.E_def by simp
    hence "u\<in>?S" using \<open>v\<in>?S\<close> cf.reachableNodes_append_edge by auto
    thus False using \<open>u\<notin>?S\<close> by auto
  qed
  hence "(\<Sum>e \<in> incoming' ?S. f e) = 0"
    unfolding cap_def by auto
  ultimately show "val = cap"
    unfolding flow_value[symmetric] netFlow_def by simp
qed

lemma fofu_III_I:
  "\<exists>k. NCut c s t k \<and> val = NCut.cap c k \<Longrightarrow> isMaxFlow f"
proof clarify
  fix k
  assume "NCut c s t k"
  then interpret NCut c s t k .
  interpret NFlowCut c s t f k by intro_locales

  assume "val = cap"
  {
    fix f'
    assume "Flow c s t f'"
    then interpret fc': Flow c s t f' .
    interpret fc': NFlowCut c s t f' k by intro_locales

    have "fc'.val \<le> cap" using fc'.weak_duality .
    also note \<open>val = cap\<close>[symmetric]
    finally have "fc'.val \<le> val" .
  }
  thus "isMaxFlow f" unfolding isMaxFlow_def
    by simp unfold_locales
qed

text \<open>Finally we can state the Ford-Fulkerson theorem: \<close>
theorem ford_fulkerson: shows
  "isMaxFlow f \<longleftrightarrow>
  \<not> Ex isAugmentingPath" and "\<not> Ex isAugmentingPath \<longleftrightarrow>
  (\<exists>k. NCut c s t k \<and> val = NCut.cap c k)"
  using fofu_I_II fofu_II_III fofu_III_I by auto

subsection \<open>Corollaries\<close>

text \<open>In this subsection we present a few corollaries of the
  flow-cut relation and the Ford-Fulkerson theorem.
\<close>

text \<open>The outgoing flow of the source is the same as the incoming flow of
  the sink. Intuitively, this means that no flow is generated or lost in the
  network, except at the source and sink.\<close>
corollary inflow_t_outflow_s:
  "(\<Sum>e \<in> incoming t. f e) = (\<Sum>e \<in> outgoing s. f e)"
proof -
  txt \<open>We choose a cut between the sink and all other nodes\<close>
  let ?K = "V - {t}"
  interpret NFlowCut c s t f ?K
    using s_node s_not_t by unfold_locales auto

  txt \<open>The cut is chosen such that its outgoing edges are the incoming edges
    to the sink, and its incoming edges are the outgoing edges from the sink.
    Note that the sink has no outgoing edges.\<close>
  have "outgoing' ?K = incoming t"
   and "incoming' ?K = {}"
    using no_self_loop no_outgoing_t
    unfolding outgoing'_def incoming_def incoming'_def outgoing_def V_def
    by auto
  hence "(\<Sum>e \<in> incoming t. f e) = netFlow" unfolding netFlow_def by auto
  also have "netFlow = val" by (rule flow_value)
  also have "val = (\<Sum>e \<in> outgoing s. f e)" by (auto simp: val_alt)
  finally show ?thesis .
qed

text \<open>As an immediate consequence of the Ford-Fulkerson theorem, we get that
  there is no augmenting path if and only if the flow is maximal.\<close>
corollary noAugPath_iff_maxFlow: "(\<nexists>p. isAugmentingPath p) \<longleftrightarrow> isMaxFlow f"
  using ford_fulkerson by blast

end \<comment> \<open>Network with flow\<close>

text \<open>The value of the maximum flow equals the capacity of the minimum cut\<close>
corollary (in Network) maxFlow_minCut: "\<lbrakk>isMaxFlow f; isMinCut c s t k\<rbrakk>
  \<Longrightarrow> Flow.val c s f = NCut.cap c k"
proof -
  assume "isMaxFlow f" "isMinCut c s t k"
  then interpret Flow c s t f + NCut c s t k
    unfolding isMaxFlow_def isMinCut_def by simp_all
  interpret NFlowCut c s t f k by intro_locales

  from ford_fulkerson \<open>isMaxFlow f\<close>
  obtain k' where "NCut c s t k'" and "val = NCut.cap c k'"
    by blast
  thus "val = cap"
    using \<open>isMinCut c s t k\<close> weak_duality
    unfolding isMinCut_def by auto
qed

end \<comment> \<open>Theory\<close>


(*
  File:     Fishburn_Impossibility.thy
  Author:   Manuel Eberl, TU München
  Author:   Christian Saile, TU München

  Incompatibility of Pareto Optimality and Fishburn-Strategy-Proofness
*)
section \<open>Main impossibility result\<close>

theory Fishburn_Impossibility
imports
  Social_Choice_Functions
begin

subsection \<open>Setting of the base case\<close>

text \<open>
  Suppose we have an anonymous, Fishburn-strategyproof, and Pareto-efficient SCF
  for three agents $A1$ to $A3$ and three alternatives $a$, $b$, and $c$. We will derive
  a contradiction from this.
\<close>
locale fb_impossibility_3_3 =
  strategyproof_anonymous_scf agents alts scf Fishb +
  pareto_efficient_scf agents alts scf
  for agents :: "'agent set" and alts :: "'alt set" and scf A1 A2 A3 a b c +
  assumes agents_eq: "agents = {A1, A2, A3}"
  assumes alts_eq:    "alts = {a, b, c}"
  assumes distinct_agents: "distinct [A1, A2, A3]"
  assumes distinct_alts: "distinct [a, b, c]"
begin

text \<open>
  We first give some simple rules that will allow us to break down the strategyproofness
  and support conditions more easily later.
\<close>
lemma agents_neq [simp]: "A1 \<noteq> A2" "A2 \<noteq> A1" "A1 \<noteq> A3" "A3 \<noteq> A1" "A2 \<noteq> A3" "A3 \<noteq> A2"
  using distinct_agents by auto

lemma alts_neq [simp]: "a \<noteq> b" "a \<noteq> c" "b \<noteq> c" "b \<noteq> a" "c \<noteq> a" "c \<noteq> b"
  using distinct_alts by auto

lemma agent_in_agents [simp]: "A1 \<in> agents" "A2 \<in> agents" "A3 \<in> agents"
  by (simp_all add: agents_eq)

lemma alt_in_alts [simp]: "a \<in> alts" "b \<in> alts" "c \<in> alts"
  by (simp_all add: alts_eq)

lemma Bex_alts: "(\<exists>x\<in>alts. P x) \<longleftrightarrow> P a \<or> P b \<or> P c"
  by (simp add: alts_eq)

lemma eval_pareto_loser_aux:
  assumes "is_pref_profile R"
  shows   "x \<in> pareto_losers R \<longleftrightarrow> (\<exists>y\<in>{a,b,c}. x \<prec>[Pareto(R)] y)"
proof -
  interpret pref_profile_wf agents alts R by fact
  have *: "y \<in> {a,b,c}" if "x \<prec>[Pareto(R)] y" for y
    using Pareto.strict_not_outside[of x y] that by (simp add: alts_eq)
  show ?thesis by (auto simp: pareto_losers_def dest: *)
qed

lemma eval_Pareto:
  assumes "is_pref_profile R"
  shows   "x \<prec>[Pareto(R)] y \<longleftrightarrow> (\<forall>i\<in>{A1,A2,A3}. x \<preceq>[R i] y) \<and> (\<exists>i\<in>{A1,A2,A3}. \<not>x \<succeq>[R i] y)"
proof -
  interpret R: pref_profile_wf agents alts by fact
  show ?thesis unfolding R.Pareto_strict_iff by (auto simp: strongly_preferred_def agents_eq)
qed

lemmas eval_pareto = eval_pareto_loser_aux eval_Pareto
lemma pareto_efficiency: "is_pref_profile R \<Longrightarrow> x \<in> pareto_losers R \<Longrightarrow> x \<notin> scf R"
  using pareto_efficient[of R] by blast

lemma Ball_scf:
  assumes "is_pref_profile R"
  shows   "(\<forall>x\<in>scf R. P x) \<longleftrightarrow> (a \<notin> scf R \<or> P a) \<and> (b \<notin> scf R \<or> P b) \<and> (c \<notin> scf R \<or> P c)"
  using scf_alts[OF assms] unfolding alts_eq by blast

lemma Ball_scf_diff:
  assumes "is_pref_profile R1" "is_pref_profile R2"
  shows   "(\<forall>x\<in>scf R1 - scf R2. P x) \<longleftrightarrow>
             (a \<in> scf R2 \<or> a \<notin> scf R1 \<or> P a) \<and> (b \<in> scf R2 \<or> b \<notin> scf R1 \<or> P b) \<and>
             (c \<in> scf R2 \<or> c \<notin> scf R1 \<or> P c)"
  using assms[THEN scf_alts] unfolding alts_eq by blast

lemma scf_nonempty':
  assumes "is_pref_profile R"
  shows   "\<exists>x\<in>alts. x \<in> scf R"
  using scf_nonempty[OF assms] scf_alts[OF assms] by blast

subsection \<open>Definition of Preference Profiles and Fact Gathering\<close>

text \<open>
  We now define the 21 preference profile that will lead to the impossibility result.
\<close>
preference_profile
  agents: agents
  alts:   alts
where R1   = A1: [a, c], b    A2: [a, c], b     A3: b, c, a
  and R2   = A1: c, [a, b]    A2: b, c, a       A3: c, b, a
  and R3   = A1: [a, c], b    A2: b, c, a       A3: c, b, a
  and R4   = A1: [a, c], b    A2:  a, b, c      A3: b, c, a
  and R5   = A1: c, [a, b]    A2:  a, b, c      A3: b, c, a
  and R6   = A1: b, [a, c]    A2: c, [a, b]     A3:  b, c, a
  and R7   = A1: [a, c], b    A2: b, [a, c]     A3: b, c, a
  and R8   = A1: [b, c], a    A2: a, [b, c]     A3: a, c, b
  and R9   = A1: [b, c], a    A2: b, [a, c]     A3: a, b, c
  and R10  = A1: c, [a, b]    A2: a, b, c       A3: c, b, a
  and R11  = A1: [a, c], b    A2: a, b, c       A3: c, b, a
  and R12  = A1: c, [a, b]    A2: b, a, c       A3: c, b, a
  and R13  = A1: [a, c], b    A2: b, a, c       A3: c, b, a
  and R14  = A1: a, [b, c]    A2: c, [a, b]     A3: a, c, b
  and R15  = A1: [b, c], a    A2: a, [b, c]     A3: a, b, c
  and R16  = A1: [a, b], c    A2: c, [a, b]     A3: a, b, c
  and R17  = A1: a, [b, c]    A2: a, b, c       A3: b, c, a
  and R18  = A1: [a, c], b    A2: b, [a, c]     A3: b, a, c
  and R19  = A1: a, [b, c]    A2: c, [a, b]     A3: a, b, c
  and R20  = A1: b, [a, c]    A2: a, b, c       A3: b, a, c
  and R21  = A1: [b, c], a    A2: a, b, c       A3: b, c, a
  by (simp_all add: agents_eq alts_eq)

lemmas R_wfs =
  R1.wf R2.wf R3.wf R4.wf R5.wf R6.wf R7.wf R8.wf R9.wf R10.wf R11.wf R12.wf R13.wf R14.wf R15.wf
  R16.wf R17.wf R18.wf R19.wf R20.wf R21.wf

lemmas R_evals =
  R1.eval R2.eval R3.eval R4.eval R5.eval R6.eval R7.eval R8.eval R9.eval R10.eval R11.eval R12.eval  R13.eval
  R14.eval R15.eval R16.eval R17.eval R18.eval R19.eval R20.eval R21.eval

lemmas nonemptiness = R_wfs [THEN scf_nonempty', unfolded Bex_alts]

text \<open>
  We show the support conditions from Pareto efficiency
\<close>

text \<open>
  We derive the strategyproofness conditions:
\<close>
lemma s41: "\<not> scf R4 \<succ>[Fishb(R1 A2)] scf R1"
    by (intro strategyproof'[where j = A2]) (simp_all add: R4.eval R1.eval)

lemma s32: "\<not> scf R3 \<succ>[Fishb(R2 A1)] scf R2"
    by (intro strategyproof'[where j = A1]) (simp_all add: R3.eval R2.eval)

lemma s122: "\<not> scf R12 \<succ>[Fishb(R2 A2)] scf R2"
    by (intro strategyproof'[where j = A2]) (simp_all add: R12.eval R2.eval)

lemma s133: "\<not> scf R13 \<succ>[Fishb(R3 A2)] scf R3"
    by (intro strategyproof'[where j = A2]) (simp_all add: R13.eval R3.eval)

lemma s102: "\<not> scf R10 \<succ>[Fishb(R2 A2)] scf R2"
    by (intro strategyproof'[where j = A2]) (simp_all add: R10.eval R2.eval)

lemma s13: "\<not> scf R1 \<succ>[Fishb(R3 A3)] scf R3"
    by (intro strategyproof'[where j = A2]) (simp_all add: R1.eval R3.eval)

lemma s54: "\<not> scf R5 \<succ>[Fishb(R4 A1)] scf R4"
    by (intro strategyproof'[where j = A1]) (simp_all add: R5.eval R4.eval)

lemma s174: "\<not> scf R17 \<succ>[Fishb(R4 A1)] scf R4"
    by (intro strategyproof'[where j = A1]) (simp_all add: R17.eval R4.eval)

lemma s74: "\<not> scf R7 \<succ>[Fishb(R4 A2)] scf R4"
    by (intro strategyproof'[where j = A2]) (simp_all add: R7.eval R4.eval)

lemma s114: "\<not> scf R11 \<succ>[Fishb(R4 A3)] scf R4"
    by (intro strategyproof'[where j = A3]) (simp_all add: R11.eval R4.eval)

lemma s45: "\<not> scf R4 \<succ>[Fishb(R5 A1)] scf R5"
    by (intro strategyproof'[where j = A1]) (simp_all add: R4.eval R5.eval)

lemma s65: "\<not> scf R6 \<succ>[Fishb(R5 A2)] scf R5"
    by (intro strategyproof'[where j = A1]) (simp_all add: insert_commute R5.eval R6.eval)

lemma s105: "\<not> scf R10 \<succ>[Fishb(R5 A3)] scf R5"
    by (intro strategyproof'[where j = A3]) (simp_all add:  R10.eval R5.eval)

lemma s67: "\<not> scf R6 \<succ>[Fishb(R7 A1)] scf R7"
    by (intro strategyproof'[where j = A2]) (simp_all add: insert_commute  R6.eval R7.eval)

lemma s187: "\<not> scf R18 \<succ>[Fishb(R7 A3)] scf R7"
    by (intro strategyproof'[where j = A3]) (simp_all add: insert_commute R7.eval R18.eval)

lemma s219: "\<not> scf R21 \<succ>[Fishb(R9 A2)] scf R9"
    by (intro strategyproof'[where j = A3]) (simp_all add: insert_commute R9.eval R21.eval)

lemma s1011: "\<not> scf R10 \<succ>[Fishb(R11 A1)] scf R11"
    by (intro strategyproof'[where j = A1]) (simp_all add: insert_commute R10.eval R11.eval)

lemma s1012: "\<not> scf R10 \<succ>[Fishb(R12 A2)] scf R12"
    by (intro strategyproof'[where j = A2]) (simp_all add: insert_commute R10.eval R12.eval)

lemma s1213: "\<not> scf R12 \<succ>[Fishb(R13 A1)] scf R13"
    by (intro strategyproof'[where j = A1]) (simp_all add: insert_commute R12.eval R13.eval)

lemma s1113: "\<not> scf R11 \<succ>[Fishb(R13 A2)] scf R13"
    by (intro strategyproof'[where j = A2]) (simp_all add: insert_commute R11.eval R13.eval)

lemma s1813: "\<not> scf R18 \<succ>[Fishb(R13 A3)] scf R13"
    by (intro strategyproof'[where j = A2]) (simp_all add: insert_commute R18.eval R13.eval)

lemma s814: "\<not> scf R8 \<succ>[Fishb(R14 A2)] scf R14"
    by (intro strategyproof'[where j = A1]) (simp_all add: insert_commute R8.eval R14.eval)

lemma s1914: "\<not> scf R19 \<succ>[Fishb(R14 A3)] scf R14"
    by (intro strategyproof'[where j = A3]) (simp_all add: insert_commute R19.eval R14.eval)

lemma s1715: "\<not> scf R17 \<succ>[Fishb(R15 A1)] scf R15"
    by (intro strategyproof'[where j = A3]) (simp_all add: insert_commute R17.eval R15.eval)

lemma s815: "\<not> scf R8 \<succ>[Fishb(R15 A3)] scf R15"
    by (intro strategyproof'[where j = A3]) (simp_all add: insert_commute R8.eval R15.eval)

lemma s516: "\<not> scf R5 \<succ>[Fishb(R16 A1)] scf R16"
    by (intro strategyproof'[where j = A3]) (simp_all add: insert_commute R5.eval R16.eval)

lemma s517: "\<not> scf R5 \<succ>[Fishb(R17 A1)] scf R17"
    by (intro strategyproof'[where j = A1]) (simp_all add: insert_commute R5.eval R17.eval)

lemma s1619: "\<not> scf R16 \<succ>[Fishb(R19 A1)] scf R19"
     by (intro strategyproof'[where j = A1]) (simp_all add: insert_commute  R16.eval R19.eval)

lemma s1820: "\<not> scf R18 \<succ>[Fishb(R20 A2)] scf R20"
    by (intro strategyproof'[where j = A1]) (simp_all add: insert_commute  R18.eval R20.eval)

lemma s920: "\<not> scf R9 \<succ>[Fishb(R20 A3)] scf R20"
    by (intro strategyproof'[where j = A1]) (simp_all add: insert_commute  R20.eval R9.eval)

lemma s521: "\<not> scf R5 \<succ>[Fishb(R21 A1)] scf R21"
    by (intro strategyproof'[where j = A1]) (simp_all add: insert_commute  R21.eval R5.eval)

lemma s421: "\<not> scf R4 \<succ>[Fishb(R21 A1)] scf R21"
    by (intro strategyproof'[where j = A1]) (simp_all add: insert_commute  R21.eval R4.eval)

lemmas sp = s41 s32 s122 s102 s133 s13 s54 s174 s54 s74 s114 s45 s65 s105 s67
            s187 s219 s1011 s1012 s1213 s1113 s1813 s814 s1914 s1715 s815 s516
            s517 s1619 s1820 s920 s521 s421

text \<open>
  We now use the simplifier to break down the strategyproofness conditions into SAT formulae.
  This takes a few seconds, so we use some low-level ML code to at least do the simplification
  in parallel.
\<close>
local_setup \<open>fn lthy =>
  let
    val lthy' = lthy addsimps @{thms Fishb_strict_iff Ball_scf Ball_scf_diff R_evals}
    val thms = Par_List.map (Simplifier.asm_full_simplify lthy') @{thms sp}
  in
    Local_Theory.notes [((@{binding sp'}, []), [(thms, [])])] lthy |> snd
  end
\<close>

text \<open>
  We show that the strategyproofness conditions, the non-emptiness conditions (i.\,e.\ every SCF
  must return at least one winner), and the efficiency conditions are not satisfiable together,
  which means that the SCF whose existence we assumed simply cannot exist.
\<close>
theorem absurd: False
  using sp' and nonemptiness [simplified] by satx

end

subsection \<open>Lifting to more than 3 agents and alternatives\<close>

text \<open>
  We now employ the standard lifting argument outlined before to lift this impossibility
  from 3 agents and alternatives to any setting with at least 3 agents and alternatives.
\<close>
locale fb_impossibility =
  strategyproof_anonymous_scf agents alts scf Fishb +
  pareto_efficient_scf agents alts scf
  for agents :: "'agent set" and alts :: "'alt set" and scf +
  assumes card_agents_ge: "card agents \<ge> 3"
      and card_alts_ge:   "card alts \<ge> 3"
begin

(* TODO: Move? *)
lemma finite_list':
  assumes "finite A"
  obtains xs where "A = set xs" "distinct xs" "length xs = card A"
proof -
  from assms obtain xs where "set xs = A" using finite_list by blast
  thus ?thesis using distinct_card[of "remdups xs"]
    by (intro that[of "remdups xs"]) simp_all
qed

lemma finite_list_subset:
  assumes "finite A" "card A \<ge> n"
  obtains xs where "set xs \<subseteq> A" "distinct xs" "length xs = n"
proof -
  obtain xs where "A = set xs" "distinct xs" "length xs = card A"
    using finite_list'[OF assms(1)] by blast
  with assms show ?thesis
    by (intro that[of "take n xs"]) (simp_all add: set_take_subset)
qed

lemma card_ge_3E:
  assumes "finite A" "card A \<ge> 3"
  obtains a b c where "distinct [a,b,c]" "{a,b,c} \<subseteq> A"
proof -
  from finite_list_subset[OF assms] guess xs .
  moreover then obtain a b c where "xs = [a, b, c]"
    by (auto simp: eval_nat_numeral length_Suc_conv)
  ultimately show ?thesis by (intro that[of a b c]) simp_all
qed

theorem absurd: False
proof -
  from card_ge_3E[OF finite_agents card_agents_ge] guess A1 A2 A3 .
  note agents = this
  let ?agents' = "{A1, A2, A3}"
  from card_ge_3E[OF finite_alts card_alts_ge] guess a b c .
  note alts = this
  let ?alts' = "{a, b, c}"

  interpret scf_lowering_anonymous agents alts scf ?agents' ?alts'
    by standard (use agents alts in auto)
  interpret liftable_set_extension ?alts' alts Fishb
    by (intro Fishburn_liftable alts)
  interpret scf_lowering_strategyproof agents alts scf ?agents' ?alts' Fishb ..
  interpret fb_impossibility_3_3 ?agents' ?alts' lowered A1 A2 A3 a b c
    by standard (use agents alts in simp_all)
  from absurd show False .
qed

end

end


theory DemoFacit
imports "$HIPSTER_HOME/IsaHipster"

begin

(* Normal list datatype *)
datatype 'a Lst =
   Nil
  | Cons "'a" "'a Lst" (infix ";" 65)

(* The append function. We must use +++ instead of Haskell's ++ *)
fun app :: "'a Lst \<Rightarrow> 'a Lst \<Rightarrow> 'a Lst" (infix "+++" 60)
where
  "Nil +++ xs = xs"
| "(x;xs) +++ ys = x;(xs +++ ys)"

(* The reverse function *)
fun rev :: "'a Lst \<Rightarrow> 'a Lst"
where
  "rev Nil = Nil"
| "rev (x;xs) = (rev xs) +++ (x;Nil)"

(* Datatype for binary trees from your exercises *)
datatype 'a Tree =
  Empty
  | Node "'a" "'a Tree" "'a Tree"

(* The swap function: swaps the left and right subtree. *)
fun swap :: "'a Tree => 'a Tree"
where
  "swap Empty = Empty"
| "swap (Node data l r) = Node data (swap r) (swap l)"

(* The flatten function: turn a tree into a list *)
fun flatten :: "'a Tree \<Rightarrow> 'a Lst"
where
  "flatten Empty = Nil"
| "flatten (Node data l r) =  ((flatten l) +++ (data;Nil)) +++ (flatten r)"

hipster app rev
lemma lemma_a [thy_expl]: "y +++ Lst.Nil = y"
apply (induction y)
apply simp
by simp

lemma lemma_aa [thy_expl]: "(y +++ z) +++ x2 = y +++ (z +++ x2)"
apply (induction y)
apply simp
by simp

lemma lemma_ab [thy_expl]: "Demo.rev z +++ Demo.rev y = Demo.rev (y +++ z)"
apply (induction y)
apply simp
apply (metis Demo.lemma_a)
apply simp
by (metis lemma_aa)

lemma lemma_ac [thy_expl]: "Demo.rev (Demo.rev y) = y"
apply (induction y)
apply simp
apply simp
by (metis Demo.lemma_a Demo.rev.simps(1) Demo.rev.simps(2) Lst.distinct(1) app.elims app.simps(2) lemma_ab)

(* Last week's exercise 10 *)
theorem exercise10: "flatten (swap p) = rev (flatten p)"
apply (induction p)
apply simp
apply simp
by (metis Demo.rev.simps(1) Demo.rev.simps(2) lemma_a lemma_aa lemma_ab)

(* The spine function: turns a list into a tree. *)
fun spine :: "'a Lst \<Rightarrow> 'a Tree"
where
  "spine Nil = Empty"
| "spine (x;xs) = Node x Empty (spine xs)"

hipster spine flatten
lemma lemma_ad [thy_expl]: "(flatten z) +++ (y ; flatten x2) = flatten (Node y z x2)"
apply (induction x2)
apply simp
apply (metis lemma_a)
apply simp
by (metis app.simps(1) app.simps(2) lemma_aa)

lemma lemma_ae [thy_expl]: "flatten (spine y) = y"
apply (induction y)
apply simp
by simp
end


theory Ex037
  imports Main
begin

lemma "\<lbrakk>A \<or> B ; \<not>A \<or> \<not>C\<rbrakk> \<Longrightarrow> C \<longrightarrow> B"
proof -
  {
    assume "A \<or> B"
    {
      assume "\<not>A \<or> \<not>C"
      {
        assume "\<not>A"
        {
          assume A
          with \<open>\<not>A\<close> have False by contradiction
          hence "C \<longrightarrow> B" by (rule FalseE)
        }
        note tmp=this
        {
          assume B
          {
            assume C
            from \<open>B\<close> have B by assumption
          }
          hence "C \<longrightarrow> B" by (rule impI)
        }
        from \<open>A \<or> B\<close> and tmp and this have "C \<longrightarrow> B" by (rule disjE)
      }
      note tmp=this
      {
        assume "\<not>C"
        {
          assume C
          with \<open>\<not>C\<close> have False by contradiction
          hence B by (rule FalseE)
        }
        hence "C \<longrightarrow> B" by (rule impI)
      }
      with \<open>\<not>A \<or> \<not>C\<close> and tmp show "C \<longrightarrow> B" by (rule disjE)
    }
  }
qed