chapter \<open>A monad for generating fresh names\<close>

theory Fresh_Monad
imports
  "HOL-Library.State_Monad"
  Term_Utils
begin

text \<open>
  Generation of fresh names in general can be thought of as picking a string that is not an element
  of a (finite) set of already existing names. For Isabelle, the \<^emph>\<open>Nominal\<close> framework
  \<^cite>\<open>urban2008nominal and urban2013nominal\<close> provides support for reasoning over fresh names, but
  unfortunately, its definitions are not executable.

  Instead, I chose to model generation of fresh names as a monad based on @{type state}. With this,
  it becomes possible to write programs using \<open>do\<close>-notation. This is implemented abstractly as a
  @{command locale} that expects two operations:

  \<^item> \<open>next\<close> expects a value and generates a larger value, according to @{class linorder}
  \<^item> \<open>arb\<close> produces any value, similarly to @{const undefined}, but executable
\<close>

locale fresh =
  fixes "next" :: "'a::linorder \<Rightarrow> 'a" and arb :: 'a
  assumes next_ge: "next x > x"
begin

abbreviation update_next :: "('a, unit) state" where
"update_next \<equiv> State_Monad.update next"

lemma update_next_strict_mono[simp, intro]: "strict_mono_state update_next"
using next_ge by (auto intro: update_strict_mono)

lemma update_next_mono[simp, intro]: "mono_state update_next"
by (rule strict_mono_implies_mono) (rule update_next_strict_mono)

definition create :: "('a, 'a) state" where
"create = update_next \<bind> (\<lambda>_. State_Monad.get)"

lemma create_alt_def[code]: "create = State (\<lambda>a. (next a, next a))"
unfolding create_def State_Monad.update_def State_Monad.get_def State_Monad.set_def State_Monad.bind_def
by simp

abbreviation fresh_in :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" where
"fresh_in S s \<equiv> Ball S ((\<ge>) s)"

lemma next_ge_all: "finite S \<Longrightarrow> fresh_in S s \<Longrightarrow> next s \<notin> S"
by (metis antisym less_imp_le less_irrefl next_ge)

definition Next :: "'a set \<Rightarrow> 'a" where
"Next S = (if S = {} then arb else next (Max S))"

lemma Next_ge_max: "finite S \<Longrightarrow> S \<noteq> {} \<Longrightarrow> Next S > Max S"
unfolding Next_def using next_ge by simp

lemma Next_not_member_subset: "finite S' \<Longrightarrow> S \<subseteq> S' \<Longrightarrow> Next S' \<notin> S"
unfolding Next_def using next_ge
by (metis Max_ge Max_mono empty_iff finite_subset leD less_le_trans subset_empty)

lemma Next_not_member: "finite S \<Longrightarrow> Next S \<notin> S"
by (rule Next_not_member_subset) auto

lemma Next_geq_not_member: "finite S \<Longrightarrow> s \<ge> Next S \<Longrightarrow> s \<notin> S"
unfolding Next_def using next_ge
by (metis (full_types) Max_ge all_not_in_conv leD le_less_trans)

lemma next_not_member: "finite S \<Longrightarrow> s \<ge> Next S \<Longrightarrow> next s \<notin> S"
by (meson Next_geq_not_member less_imp_le next_ge order_trans)

lemma create_mono[simp, intro]: "mono_state create"
unfolding create_def
by (auto intro: bind_mono_strong)

lemma create_strict_mono[simp, intro]: "strict_mono_state create"
unfolding create_def
by (rule bind_strict_mono_strong2) auto

abbreviation run_fresh where
"run_fresh m S \<equiv> fst (run_state m (Next S))"

abbreviation fresh_fin :: "'a fset \<Rightarrow> 'a \<Rightarrow> bool" where
"fresh_fin S s \<equiv> fBall S ((\<ge>) s)"

context includes fset.lifting begin

lemma next_ge_fall: "fresh_fin S s \<Longrightarrow> next s |\<notin>| S"
by (transfer fixing: "next") (rule next_ge_all)

lift_definition fNext :: "'a fset \<Rightarrow> 'a" is Next .

lemma fNext_ge_max: "S \<noteq> {||} \<Longrightarrow> fNext S > fMax S"
by transfer (rule Next_ge_max)

lemma next_not_fmember: "s \<ge> fNext S \<Longrightarrow> next s |\<notin>| S"
by transfer (rule next_not_member)

lemma fNext_geq_not_member: "s \<ge> fNext S \<Longrightarrow> s |\<notin>| S"
by transfer (rule Next_geq_not_member)

lemma fNext_not_member: "fNext S |\<notin>| S"
by transfer (rule Next_not_member)

lemma fNext_not_member_subset: "S |\<subseteq>| S' \<Longrightarrow> fNext S' |\<notin>| S"
by transfer (rule Next_not_member_subset)

abbreviation frun_fresh where
"frun_fresh m S \<equiv> fst (run_state m (fNext S))"

end

end

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_nat_MSortTDCount
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) y = Z"
| "minus (S z) (S y2) = minus z y2"

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

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 y l) = plus (S Z) (length l)"

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

fun lmerge :: "Nat list => Nat list => Nat list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if le z x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun take :: "Nat => 'a list => 'a list" where
  "take x y =
   (if le x Z then nil2 else
      (case y of
         nil2 => nil2
         | cons2 z xs => (case x of S x2 => cons2 z (take x2 xs))))"

(*fun did not finish the proof*)
function idiv :: "Nat => Nat => Nat" where
  "idiv x y = (if lt x y then Z else S (idiv (minus x y) y))"
  by pat_completeness auto

fun drop :: "Nat => 'a list => 'a list" where
  "drop x y =
   (if le x Z then y else
      (case y of
         nil2 => nil2
         | cons2 z xs1 => (case x of S x2 => drop x2 xs1)))"

(*fun did not finish the proof*)
function msorttd :: "Nat list => Nat list" where
  "msorttd (nil2) = nil2"
| "msorttd (cons2 y (nil2)) = cons2 y (nil2)"
| "msorttd (cons2 y (cons2 x2 x3)) =
     (let k :: Nat = idiv (length (cons2 y (cons2 x2 x3))) (S (S Z))
     in lmerge
          (msorttd (take k (cons2 y (cons2 x2 x3))))
          (msorttd (drop k (cons2 y (cons2 x2 x3)))))"
  by pat_completeness auto

fun count :: "'a => 'a list => Nat" where
  "count x (nil2) = Z"
| "count x (cons2 z ys) =
     (if (x = z) then plus (S Z) (count x ys) else count x ys)"

theorem property0 :
  "((count x (msorttd xs)) = (count x xs))"
  oops

end


(*  Title:      HOL/Library/Order_Continuity.thy
    Author:     David von Oheimb, TU München
    Author:     Johannes Hölzl, TU München
*)

section \<open>Continuity and iterations\<close>

theory Order_Continuity
imports Complex_MainRLT Countable_Complete_Lattices
begin

(* TODO: Generalize theory to chain-complete partial orders *)

lemma SUP_nat_binary:
  "(sup A (SUP x\<in>Collect ((<) (0::nat)). B)) = (sup A B::'a::countable_complete_lattice)"
  apply (subst image_constant)
   apply auto
  done

lemma INF_nat_binary:
  "inf A (INF x\<in>Collect ((<) (0::nat)). B) = (inf A B::'a::countable_complete_lattice)"
  apply (subst image_constant)
   apply auto
  done

text \<open>
  The name \<open>continuous\<close> is already taken in \<open>Complex_MainRLT\<close>, so we use
  \<open>sup_continuous\<close> and \<open>inf_continuous\<close>. These names appear sometimes in literature
  and have the advantage that these names are duals.
\<close>

named_theorems order_continuous_intros

subsection \<open>Continuity for complete lattices\<close>

definition
  sup_continuous :: "('a::countable_complete_lattice \<Rightarrow> 'b::countable_complete_lattice) \<Rightarrow> bool"
where
  "sup_continuous F \<longleftrightarrow> (\<forall>M::nat \<Rightarrow> 'a. mono M \<longrightarrow> F (SUP i. M i) = (SUP i. F (M i)))"

lemma sup_continuousD: "sup_continuous F \<Longrightarrow> mono M \<Longrightarrow> F (SUP i::nat. M i) = (SUP i. F (M i))"
  by (auto simp: sup_continuous_def)

lemma sup_continuous_mono:
  "mono F" if "sup_continuous F"
proof
  fix A B :: "'a"
  assume "A \<le> B"
  let ?f = "\<lambda>n::nat. if n = 0 then A else B"
  from \<open>A \<le> B\<close> have "incseq ?f"
    by (auto intro: monoI)
  with \<open>sup_continuous F\<close> have *: "F (SUP i. ?f i) = (SUP i. F (?f i))"
    by (auto dest: sup_continuousD)
  from \<open>A \<le> B\<close> have "B = sup A B"
    by (simp add: le_iff_sup)
  then have "F B = F (sup A B)"
    by simp
  also have "\<dots> = sup (F A) (F B)"
    using * by (simp add: if_distrib SUP_nat_binary cong del: SUP_cong)
  finally show "F A \<le> F B"
    by (simp add: le_iff_sup)
qed

lemma [order_continuous_intros]:
  shows sup_continuous_const: "sup_continuous (\<lambda>x. c)"
    and sup_continuous_id: "sup_continuous (\<lambda>x. x)"
    and sup_continuous_apply: "sup_continuous (\<lambda>f. f x)"
    and sup_continuous_fun: "(\<And>s. sup_continuous (\<lambda>x. P x s)) \<Longrightarrow> sup_continuous P"
    and sup_continuous_If: "sup_continuous F \<Longrightarrow> sup_continuous G \<Longrightarrow> sup_continuous (\<lambda>f. if C then F f else G f)"
  by (auto simp: sup_continuous_def image_comp)

lemma sup_continuous_compose:
  assumes f: "sup_continuous f" and g: "sup_continuous g"
  shows "sup_continuous (\<lambda>x. f (g x))"
  unfolding sup_continuous_def
proof safe
  fix M :: "nat \<Rightarrow> 'c"
  assume M: "mono M"
  then have "mono (\<lambda>i. g (M i))"
    using sup_continuous_mono[OF g] by (auto simp: mono_def)
  with M show "f (g (Sup (M ` UNIV))) = (SUP i. f (g (M i)))"
    by (auto simp: sup_continuous_def g[THEN sup_continuousD] f[THEN sup_continuousD])
qed

lemma sup_continuous_sup[order_continuous_intros]:
  "sup_continuous f \<Longrightarrow> sup_continuous g \<Longrightarrow> sup_continuous (\<lambda>x. sup (f x) (g x))"
  by (simp add: sup_continuous_def ccSUP_sup_distrib)

lemma sup_continuous_inf[order_continuous_intros]:
  fixes P Q :: "'a :: countable_complete_lattice \<Rightarrow> 'b :: countable_complete_distrib_lattice"
  assumes P: "sup_continuous P" and Q: "sup_continuous Q"
  shows "sup_continuous (\<lambda>x. inf (P x) (Q x))"
  unfolding sup_continuous_def
proof (safe intro!: antisym)
  fix M :: "nat \<Rightarrow> 'a" assume M: "incseq M"
  have "inf (P (SUP i. M i)) (Q (SUP i. M i)) \<le> (SUP j i. inf (P (M i)) (Q (M j)))"
    by (simp add: sup_continuousD[OF P M] sup_continuousD[OF Q M] inf_ccSUP ccSUP_inf)
  also have "\<dots> \<le> (SUP i. inf (P (M i)) (Q (M i)))"
  proof (intro ccSUP_least)
    fix i j from M assms[THEN sup_continuous_mono] show "inf (P (M i)) (Q (M j)) \<le> (SUP i. inf (P (M i)) (Q (M i)))"
      by (intro ccSUP_upper2[of _ "sup i j"] inf_mono) (auto simp: mono_def)
  qed auto
  finally show "inf (P (SUP i. M i)) (Q (SUP i. M i)) \<le> (SUP i. inf (P (M i)) (Q (M i)))" .

  show "(SUP i. inf (P (M i)) (Q (M i))) \<le> inf (P (SUP i. M i)) (Q (SUP i. M i))"
    unfolding sup_continuousD[OF P M] sup_continuousD[OF Q M] by (intro ccSUP_least inf_mono ccSUP_upper) auto
qed

lemma sup_continuous_and[order_continuous_intros]:
  "sup_continuous P \<Longrightarrow> sup_continuous Q \<Longrightarrow> sup_continuous (\<lambda>x. P x \<and> Q x)"
  using sup_continuous_inf[of P Q] by simp

lemma sup_continuous_or[order_continuous_intros]:
  "sup_continuous P \<Longrightarrow> sup_continuous Q \<Longrightarrow> sup_continuous (\<lambda>x. P x \<or> Q x)"
  by (auto simp: sup_continuous_def)

lemma sup_continuous_lfp:
  assumes "sup_continuous F" shows "lfp F = (SUP i. (F ^^ i) bot)" (is "lfp F = ?U")
proof (rule antisym)
  note mono = sup_continuous_mono[OF \<open>sup_continuous F\<close>]
  show "?U \<le> lfp F"
  proof (rule SUP_least)
    fix i show "(F ^^ i) bot \<le> lfp F"
    proof (induct i)
      case (Suc i)
      have "(F ^^ Suc i) bot = F ((F ^^ i) bot)" by simp
      also have "\<dots> \<le> F (lfp F)" by (rule monoD[OF mono Suc])
      also have "\<dots> = lfp F" by (simp add: lfp_fixpoint[OF mono])
      finally show ?case .
    qed simp
  qed
  show "lfp F \<le> ?U"
  proof (rule lfp_lowerbound)
    have "mono (\<lambda>i::nat. (F ^^ i) bot)"
    proof -
      { fix i::nat have "(F ^^ i) bot \<le> (F ^^ (Suc i)) bot"
        proof (induct i)
          case 0 show ?case by simp
        next
          case Suc thus ?case using monoD[OF mono Suc] by auto
        qed }
      thus ?thesis by (auto simp add: mono_iff_le_Suc)
    qed
    hence "F ?U = (SUP i. (F ^^ Suc i) bot)"
      using \<open>sup_continuous F\<close> by (simp add: sup_continuous_def)
    also have "\<dots> \<le> ?U"
      by (fast intro: SUP_least SUP_upper)
    finally show "F ?U \<le> ?U" .
  qed
qed

lemma lfp_transfer_bounded:
  assumes P: "P bot" "\<And>x. P x \<Longrightarrow> P (f x)" "\<And>M. (\<And>i. P (M i)) \<Longrightarrow> P (SUP i::nat. M i)"
  assumes \<alpha>: "\<And>M. mono M \<Longrightarrow> (\<And>i::nat. P (M i)) \<Longrightarrow> \<alpha> (SUP i. M i) = (SUP i. \<alpha> (M i))"
  assumes f: "sup_continuous f" and g: "sup_continuous g"
  assumes [simp]: "\<And>x. P x \<Longrightarrow> x \<le> lfp f \<Longrightarrow> \<alpha> (f x) = g (\<alpha> x)"
  assumes g_bound: "\<And>x. \<alpha> bot \<le> g x"
  shows "\<alpha> (lfp f) = lfp g"
proof (rule antisym)
  note mono_g = sup_continuous_mono[OF g]
  note mono_f = sup_continuous_mono[OF f]
  have lfp_bound: "\<alpha> bot \<le> lfp g"
    by (subst lfp_unfold[OF mono_g]) (rule g_bound)

  have P_pow: "P ((f ^^ i) bot)" for i
    by (induction i) (auto intro!: P)
  have incseq_pow: "mono (\<lambda>i. (f ^^ i) bot)"
    unfolding mono_iff_le_Suc
  proof
    fix i show "(f ^^ i) bot \<le> (f ^^ (Suc i)) bot"
    proof (induct i)
      case Suc thus ?case using monoD[OF sup_continuous_mono[OF f] Suc] by auto
    qed (simp add: le_fun_def)
  qed
  have P_lfp: "P (lfp f)"
    using P_pow unfolding sup_continuous_lfp[OF f] by (auto intro!: P)

  have iter_le_lfp: "(f ^^ n) bot \<le> lfp f" for n
    apply (induction n)
    apply simp
    apply (subst lfp_unfold[OF mono_f])
    apply (auto intro!: monoD[OF mono_f])
    done

  have "\<alpha> (lfp f) = (SUP i. \<alpha> ((f^^i) bot))"
    unfolding sup_continuous_lfp[OF f] using incseq_pow P_pow by (rule \<alpha>)
  also have "\<dots> \<le> lfp g"
  proof (rule SUP_least)
    fix i show "\<alpha> ((f^^i) bot) \<le> lfp g"
    proof (induction i)
      case (Suc n) then show ?case
        by (subst lfp_unfold[OF mono_g]) (simp add: monoD[OF mono_g] P_pow iter_le_lfp)
    qed (simp add: lfp_bound)
  qed
  finally show "\<alpha> (lfp f) \<le> lfp g" .

  show "lfp g \<le> \<alpha> (lfp f)"
  proof (induction rule: lfp_ordinal_induct[OF mono_g])
    case (1 S) then show ?case
      by (subst lfp_unfold[OF sup_continuous_mono[OF f]])
         (simp add: monoD[OF mono_g] P_lfp)
  qed (auto intro: Sup_least)
qed

lemma lfp_transfer:
  "sup_continuous \<alpha> \<Longrightarrow> sup_continuous f \<Longrightarrow> sup_continuous g \<Longrightarrow>
    (\<And>x. \<alpha> bot \<le> g x) \<Longrightarrow> (\<And>x. x \<le> lfp f \<Longrightarrow> \<alpha> (f x) = g (\<alpha> x)) \<Longrightarrow> \<alpha> (lfp f) = lfp g"
  by (rule lfp_transfer_bounded[where P=top]) (auto dest: sup_continuousD)

definition
  inf_continuous :: "('a::countable_complete_lattice \<Rightarrow> 'b::countable_complete_lattice) \<Rightarrow> bool"
where
  "inf_continuous F \<longleftrightarrow> (\<forall>M::nat \<Rightarrow> 'a. antimono M \<longrightarrow> F (INF i. M i) = (INF i. F (M i)))"

lemma inf_continuousD: "inf_continuous F \<Longrightarrow> antimono M \<Longrightarrow> F (INF i::nat. M i) = (INF i. F (M i))"
  by (auto simp: inf_continuous_def)

lemma inf_continuous_mono:
  "mono F" if "inf_continuous F"
proof
  fix A B :: "'a"
  assume "A \<le> B"
  let ?f = "\<lambda>n::nat. if n = 0 then B else A"
  from \<open>A \<le> B\<close> have "decseq ?f"
    by (auto intro: antimonoI)
  with \<open>inf_continuous F\<close> have *: "F (INF i. ?f i) = (INF i. F (?f i))"
    by (auto dest: inf_continuousD)
  from \<open>A \<le> B\<close> have "A = inf B A"
    by (simp add: inf.absorb_iff2)
  then have "F A = F (inf B A)"
    by simp
  also have "\<dots> = inf (F B) (F A)"
    using * by (simp add: if_distrib INF_nat_binary cong del: INF_cong)
  finally show "F A \<le> F B"
    by (simp add: inf.absorb_iff2)
qed

lemma [order_continuous_intros]:
  shows inf_continuous_const: "inf_continuous (\<lambda>x. c)"
    and inf_continuous_id: "inf_continuous (\<lambda>x. x)"
    and inf_continuous_apply: "inf_continuous (\<lambda>f. f x)"
    and inf_continuous_fun: "(\<And>s. inf_continuous (\<lambda>x. P x s)) \<Longrightarrow> inf_continuous P"
    and inf_continuous_If: "inf_continuous F \<Longrightarrow> inf_continuous G \<Longrightarrow> inf_continuous (\<lambda>f. if C then F f else G f)"
  by (auto simp: inf_continuous_def image_comp)

lemma inf_continuous_inf[order_continuous_intros]:
  "inf_continuous f \<Longrightarrow> inf_continuous g \<Longrightarrow> inf_continuous (\<lambda>x. inf (f x) (g x))"
  by (simp add: inf_continuous_def ccINF_inf_distrib)

lemma inf_continuous_sup[order_continuous_intros]:
  fixes P Q :: "'a :: countable_complete_lattice \<Rightarrow> 'b :: countable_complete_distrib_lattice"
  assumes P: "inf_continuous P" and Q: "inf_continuous Q"
  shows "inf_continuous (\<lambda>x. sup (P x) (Q x))"
  unfolding inf_continuous_def
proof (safe intro!: antisym)
  fix M :: "nat \<Rightarrow> 'a" assume M: "decseq M"
  show "sup (P (INF i. M i)) (Q (INF i. M i)) \<le> (INF i. sup (P (M i)) (Q (M i)))"
    unfolding inf_continuousD[OF P M] inf_continuousD[OF Q M] by (intro ccINF_greatest sup_mono ccINF_lower) auto

  have "(INF i. sup (P (M i)) (Q (M i))) \<le> (INF j i. sup (P (M i)) (Q (M j)))"
  proof (intro ccINF_greatest)
    fix i j from M assms[THEN inf_continuous_mono] show "sup (P (M i)) (Q (M j)) \<ge> (INF i. sup (P (M i)) (Q (M i)))"
      by (intro ccINF_lower2[of _ "sup i j"] sup_mono) (auto simp: mono_def antimono_def)
  qed auto
  also have "\<dots> \<le> sup (P (INF i. M i)) (Q (INF i. M i))"
    by (simp add: inf_continuousD[OF P M] inf_continuousD[OF Q M] ccINF_sup sup_ccINF)
  finally show "sup (P (INF i. M i)) (Q (INF i. M i)) \<ge> (INF i. sup (P (M i)) (Q (M i)))" .
qed

lemma inf_continuous_and[order_continuous_intros]:
  "inf_continuous P \<Longrightarrow> inf_continuous Q \<Longrightarrow> inf_continuous (\<lambda>x. P x \<and> Q x)"
  using inf_continuous_inf[of P Q] by simp

lemma inf_continuous_or[order_continuous_intros]:
  "inf_continuous P \<Longrightarrow> inf_continuous Q \<Longrightarrow> inf_continuous (\<lambda>x. P x \<or> Q x)"
  using inf_continuous_sup[of P Q] by simp

lemma inf_continuous_compose:
  assumes f: "inf_continuous f" and g: "inf_continuous g"
  shows "inf_continuous (\<lambda>x. f (g x))"
  unfolding inf_continuous_def
proof safe
  fix M :: "nat \<Rightarrow> 'c"
  assume M: "antimono M"
  then have "antimono (\<lambda>i. g (M i))"
    using inf_continuous_mono[OF g] by (auto simp: mono_def antimono_def)
  with M show "f (g (Inf (M ` UNIV))) = (INF i. f (g (M i)))"
    by (auto simp: inf_continuous_def g[THEN inf_continuousD] f[THEN inf_continuousD])
qed

lemma inf_continuous_gfp:
  assumes "inf_continuous F" shows "gfp F = (INF i. (F ^^ i) top)" (is "gfp F = ?U")
proof (rule antisym)
  note mono = inf_continuous_mono[OF \<open>inf_continuous F\<close>]
  show "gfp F \<le> ?U"
  proof (rule INF_greatest)
    fix i show "gfp F \<le> (F ^^ i) top"
    proof (induct i)
      case (Suc i)
      have "gfp F = F (gfp F)" by (simp add: gfp_fixpoint[OF mono])
      also have "\<dots> \<le> F ((F ^^ i) top)" by (rule monoD[OF mono Suc])
      also have "\<dots> = (F ^^ Suc i) top" by simp
      finally show ?case .
    qed simp
  qed
  show "?U \<le> gfp F"
  proof (rule gfp_upperbound)
    have *: "antimono (\<lambda>i::nat. (F ^^ i) top)"
    proof -
      { fix i::nat have "(F ^^ Suc i) top \<le> (F ^^ i) top"
        proof (induct i)
          case 0 show ?case by simp
        next
          case Suc thus ?case using monoD[OF mono Suc] by auto
        qed }
      thus ?thesis by (auto simp add: antimono_iff_le_Suc)
    qed
    have "?U \<le> (INF i. (F ^^ Suc i) top)"
      by (fast intro: INF_greatest INF_lower)
    also have "\<dots> \<le> F ?U"
      by (simp add: inf_continuousD \<open>inf_continuous F\<close> *)
    finally show "?U \<le> F ?U" .
  qed
qed

lemma gfp_transfer:
  assumes \<alpha>: "inf_continuous \<alpha>" and f: "inf_continuous f" and g: "inf_continuous g"
  assumes [simp]: "\<alpha> top = top" "\<And>x. \<alpha> (f x) = g (\<alpha> x)"
  shows "\<alpha> (gfp f) = gfp g"
proof -
  have "\<alpha> (gfp f) = (INF i. \<alpha> ((f^^i) top))"
    unfolding inf_continuous_gfp[OF f] by (intro f \<alpha> inf_continuousD antimono_funpow inf_continuous_mono)
  moreover have "\<alpha> ((f^^i) top) = (g^^i) top" for i
    by (induction i; simp)
  ultimately show ?thesis
    unfolding inf_continuous_gfp[OF g] by simp
qed

lemma gfp_transfer_bounded:
  assumes P: "P (f top)" "\<And>x. P x \<Longrightarrow> P (f x)" "\<And>M. antimono M \<Longrightarrow> (\<And>i. P (M i)) \<Longrightarrow> P (INF i::nat. M i)"
  assumes \<alpha>: "\<And>M. antimono M \<Longrightarrow> (\<And>i::nat. P (M i)) \<Longrightarrow> \<alpha> (INF i. M i) = (INF i. \<alpha> (M i))"
  assumes f: "inf_continuous f" and g: "inf_continuous g"
  assumes [simp]: "\<And>x. P x \<Longrightarrow> \<alpha> (f x) = g (\<alpha> x)"
  assumes g_bound: "\<And>x. g x \<le> \<alpha> (f top)"
  shows "\<alpha> (gfp f) = gfp g"
proof (rule antisym)
  note mono_g = inf_continuous_mono[OF g]

  have P_pow: "P ((f ^^ i) (f top))" for i
    by (induction i) (auto intro!: P)

  have antimono_pow: "antimono (\<lambda>i. (f ^^ i) top)"
    unfolding antimono_iff_le_Suc
  proof
    fix i show "(f ^^ Suc i) top \<le> (f ^^ i) top"
    proof (induct i)
      case Suc thus ?case using monoD[OF inf_continuous_mono[OF f] Suc] by auto
    qed (simp add: le_fun_def)
  qed
  have antimono_pow2: "antimono (\<lambda>i. (f ^^ i) (f top))"
  proof
    show "x \<le> y \<Longrightarrow> (f ^^ y) (f top) \<le> (f ^^ x) (f top)" for x y
      using antimono_pow[THEN antimonoD, of "Suc x" "Suc y"]
      unfolding funpow_Suc_right by simp
  qed

  have gfp_f: "gfp f = (INF i. (f ^^ i) (f top))"
    unfolding inf_continuous_gfp[OF f]
  proof (rule INF_eq)
    show "\<exists>j\<in>UNIV. (f ^^ j) (f top) \<le> (f ^^ i) top" for i
      by (intro bexI[of _ "i - 1"]) (auto simp: diff_Suc funpow_Suc_right simp del: funpow.simps(2) split: nat.split)
    show "\<exists>j\<in>UNIV. (f ^^ j) top \<le> (f ^^ i) (f top)" for i
      by (intro bexI[of _ "Suc i"]) (auto simp: funpow_Suc_right simp del: funpow.simps(2))
  qed

  have P_lfp: "P (gfp f)"
    unfolding gfp_f by (auto intro!: P P_pow antimono_pow2)

  have "\<alpha> (gfp f) = (INF i. \<alpha> ((f^^i) (f top)))"
    unfolding gfp_f by (rule \<alpha>) (auto intro!: P_pow antimono_pow2)
  also have "\<dots> \<ge> gfp g"
  proof (rule INF_greatest)
    fix i show "gfp g \<le> \<alpha> ((f^^i) (f top))"
    proof (induction i)
      case (Suc n) then show ?case
        by (subst gfp_unfold[OF mono_g]) (simp add: monoD[OF mono_g] P_pow)
    next
      case 0
      have "gfp g \<le> \<alpha> (f top)"
        by (subst gfp_unfold[OF mono_g]) (rule g_bound)
      then show ?case
        by simp
    qed
  qed
  finally show "gfp g \<le> \<alpha> (gfp f)" .

  show "\<alpha> (gfp f) \<le> gfp g"
  proof (induction rule: gfp_ordinal_induct[OF mono_g])
    case (1 S) then show ?case
      by (subst gfp_unfold[OF inf_continuous_mono[OF f]])
         (simp add: monoD[OF mono_g] P_lfp)
  qed (auto intro: Inf_greatest)
qed

subsubsection \<open>Least fixed points in countable complete lattices\<close>

definition (in countable_complete_lattice) cclfp :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a"
  where "cclfp f = (SUP i. (f ^^ i) bot)"

lemma cclfp_unfold:
  assumes "sup_continuous F" shows "cclfp F = F (cclfp F)"
proof -
  have "cclfp F = (SUP i. F ((F ^^ i) bot))"
    unfolding cclfp_def
    by (subst UNIV_nat_eq) (simp add: image_comp)
  also have "\<dots> = F (cclfp F)"
    unfolding cclfp_def
    by (intro sup_continuousD[symmetric] assms mono_funpow sup_continuous_mono)
  finally show ?thesis .
qed

lemma cclfp_lowerbound: assumes f: "mono f" and A: "f A \<le> A" shows "cclfp f \<le> A"
  unfolding cclfp_def
proof (intro ccSUP_least)
  fix i show "(f ^^ i) bot \<le> A"
  proof (induction i)
    case (Suc i) from monoD[OF f this] A show ?case
      by auto
  qed simp
qed simp

lemma cclfp_transfer:
  assumes "sup_continuous \<alpha>" "mono f"
  assumes "\<alpha> bot = bot" "\<And>x. \<alpha> (f x) = g (\<alpha> x)"
  shows "\<alpha> (cclfp f) = cclfp g"
proof -
  have "\<alpha> (cclfp f) = (SUP i. \<alpha> ((f ^^ i) bot))"
    unfolding cclfp_def by (intro sup_continuousD assms mono_funpow sup_continuous_mono)
  moreover have "\<alpha> ((f ^^ i) bot) = (g ^^ i) bot" for i
    by (induction i) (simp_all add: assms)
  ultimately show ?thesis
    by (simp add: cclfp_def)
qed

end


theory GabrielaLimonta
imports Main
begin

(* Pumping Lemma for regular languages *)

(* We start by formalizing a representation of a DFA, the states will be represented by nat numbers.
   The delta function has the type "'a \<Rightarrow> state \<Rightarrow> state".
   A DFA has the following type: "state set \<Rightarrow> state \<Rightarrow> state set \<Rightarrow> ('a \<Rightarrow> state \<Rightarrow> state)", this
   represents the states of the DFA, the initial state, the final states and the delta function. *)
type_synonym state = nat

(* the states for our DFA are identified by nat and a word is a list of nat numbers, a language
   represented by the DFA is a set of nat list *)

(* A word in a language is represented by a list. The language represented by a DFA is a set of lists.
   The function consume takes a word and indicates the state the DFA is after consuming that word. *)
fun consume :: "'a list \<Rightarrow> ('a \<Rightarrow> state \<Rightarrow> state) \<Rightarrow> state set \<Rightarrow> state \<Rightarrow> state" where
  "consume [] \<delta> Q = id" |
  "consume (a#w) \<delta> Q = consume w \<delta> Q \<circ> \<delta> a"

value "consume [] (\<lambda>x y. y+1) {0,1,2} 0"
value "consume [1,2,3] (\<lambda>x y. y+1) {0,1,2} 0"

(* The language represented by a DFA is the set of words w that allow us to go from the initial
   state to one of the final states *)
fun language :: "state set \<Rightarrow> state \<Rightarrow> state set \<Rightarrow> ('a \<Rightarrow> state \<Rightarrow> state) \<Rightarrow> 'a list set" where
  "language Q q\<^sub>0 q\<^sub>f \<delta> = {w. consume w \<delta> Q q\<^sub>0 \<in> q\<^sub>f}"

(* This is an example for the abstraction of a DFA *)
datatype alphabet = a | b

fun lang_ab :: "alphabet \<Rightarrow> state \<Rightarrow> state" where
  "lang_ab a s = (if s = 0 then 0 else 2)" |
  "lang_ab b s = (if s = 0 \<or> s = 1 then 1 else 2)"

value "consume [a,a,a,a,a,a,a,a,b] lang_ab {0,1,2} 0 \<in> {1}"
value "consume [a,a,a,a,a,b,a,a,b] lang_ab {0,1,2} 0 \<in> {1}"

(* A DFA is correctly formed when the set of states is finite, the initial state is in the set of
   states the final states are a subset of the states and that the delta function always yields as
   a result a state that belongs to the states of the DFA *)
definition dfa :: "state set \<Rightarrow> state \<Rightarrow> state set \<Rightarrow> ('a \<Rightarrow> state \<Rightarrow> state) \<Rightarrow> bool" where
  "dfa Q q\<^sub>0 q\<^sub>f \<delta> \<equiv> finite Q \<and> q\<^sub>0 \<in> Q \<and> q\<^sub>f \<subseteq> Q \<and> (\<forall> a q. q \<in> Q \<and> \<delta> a q \<in> Q )"

(* We define injectivity for further use in the proof *)
definition injective :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "injective f A \<longleftrightarrow> (\<forall> x \<in> A. \<forall> y \<in> A . f x = f y \<longrightarrow> x = y)"

(* Auxiliary lemma to proove pidgeonhole: Assuming a set A is finite then a function f is
   is injective over the set A iff the cardinality of the image of f applied to A is equal to
   the cardinality of A *)
lemma cardi: "finite A \<Longrightarrow> injective f A \<longleftrightarrow> card {y. (\<exists>x \<in> A. y = f x)} = card A"
sorry

(* Proof of the pidgeonhole principle *)
lemma pigeonhole: "finite A \<Longrightarrow> finite B \<Longrightarrow> card B < card A \<Longrightarrow> (\<forall> x \<in> A. f x \<in> B)
  \<Longrightarrow> (\<exists> x y. x \<noteq> y \<and> f x = f y \<and> x \<in> A \<and> y \<in> A)"
proof -
  assume "(\<forall>x \<in> A. f x \<in> B)"
  from this have a: "{y. (\<exists>x \<in> A. y = f x)} \<subseteq> B" by auto
  assume "finite B"
  then have b: "card {y. (\<exists>x \<in> A. y = f x)} \<le> card B" using a and card_mono by auto
  assume "card B < card A"
  then have "card {y. (\<exists>x \<in> A. y = f x)} < card A" using b by auto
  then have c: "card {y. (\<exists>x \<in> A. y = f x)} \<noteq> card A" by auto
  assume "finite A"
  then have "\<not> injective f A" using cardi and c by auto
  thus ?thesis using injective_def by blast
qed

(* We define a function pump that is meant to "pump" a word a k number of times, that is, it yields
  the word repeated a k number of times. *)
fun pump :: "nat => 'a list \<Rightarrow> 'a list" where
  "pump 0 y = []" |
  "pump k y = pump (k - 1) y@y"

(* Finally the formalization of the pumping lemma, this lemma is usually used to proof that some
   language is not a regular language. *)
lemma pumping:
  assumes "dfa Q q\<^sub>0 q\<^sub>f \<delta>"
  shows "\<exists> p. p\<ge>1 \<and> (\<forall>w. w \<in> (language Q q\<^sub>0 q\<^sub>f \<delta>) \<and> length w \<ge> p
        \<longrightarrow> (\<exists> x y z. w = x@y@z \<and> length y \<ge> 1 \<and> length (x@y) \<le> p \<and> (\<forall>i. i\<ge>0
            \<longrightarrow> (x @ (pump i y) @ z) \<in> (language Q q\<^sub>0 q\<^sub>f \<delta>))))"
sorry

end


theory Sat
  imports IMP
begin

fun Sat :: "bexp \<Rightarrow> bool" where
"Sat (Bc b) = b" |
"Sat (Not b) = (\<exists>s. \<not> bval b s)" |
"Sat (And a b) = (\<exists>s. bval a s \<and> bval b s)" |
"Sat (Less a b) = (\<exists>s. aval a s < aval b s)"

theorem sat_equiv: "Sat a \<longleftrightarrow> (\<exists>s. bval a s)"
  apply (induction a)
     apply auto
  done

theorem unsat_contradiction: "\<not> Sat (And a (Not a))"
  by simp

theorem sat_taut_incl: "(\<forall>s. bval a s) \<Longrightarrow> Sat b \<Longrightarrow> Sat (And a b)"
  apply (induction b arbitrary: a)
     apply simp_all
  done

theorem sat_split: "Sat (And a b) \<Longrightarrow> Sat a \<and> Sat b"
proof -
  assume "Sat (And a b)"
  hence "\<exists>s. bval a s \<and> bval b s" by simp
  hence "(\<exists>s. bval a s) \<and> (\<exists>s. bval b s)" by auto
  thus ?thesis using sat_equiv by simp
qed

end


(*  Title:       Examples of hybrid systems verifications
    Author:      Jonathan Julián Huerta y Munive, 2019
    Maintainer:  Jonathan Julián Huerta y Munive <jjhuertaymunive1@sheffield.ac.uk>
*)

subsection \<open> Examples \<close>

text \<open> We prove partial correctness specifications of some hybrid systems with our
recently described verification components.\<close>

theory HS_VC_MKA_Examples_rel
  imports HS_VC_MKA_rel

begin

subsubsection\<open>Pendulum\<close>

text \<open> The ODEs @{text "x' t = y t"} and {text "y' t = - x t"} describe the circular motion of
a mass attached to a string looked from above. We use @{text "s$1"} to represent the x-coordinate
and @{text "s$2"} for the y-coordinate. We prove that this motion remains circular. \<close>

abbreviation fpend :: "real^2 \<Rightarrow> real^2" ("f")
  where "f s \<equiv> (\<chi> i. if i = 1 then s$2 else -s$1)"

abbreviation pend_flow :: "real \<Rightarrow> real^2 \<Rightarrow> real^2" ("\<phi>")
  where "\<phi> t s \<equiv> (\<chi> i. if i = 1 then s$1 * cos t + s$2 * sin t
  else - s$1 * sin t + s$2 * cos t)"

\<comment> \<open>Verified by providing dynamics. \<close>

lemma pendulum_dyn:
  "\<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil> \<le> wp (EVOL \<phi> G T) \<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil>"
  by simp

\<comment> \<open>Verified with differential invariants. \<close>

lemma pendulum_inv:
  "\<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil> \<le> wp (x\<acute>= f & G) \<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil>"
  by (auto intro!: poly_derivatives diff_invariant_rules)

\<comment> \<open>Verified with the flow. \<close>

lemma local_flow_pend: "local_flow f UNIV UNIV \<phi>"
  apply(unfold_locales, simp_all add: local_lipschitz_def lipschitz_on_def vec_eq_iff, clarsimp)
    apply(rule_tac x="1" in exI, clarsimp, rule_tac x=1 in exI)
    apply(simp add: dist_norm norm_vec_def L2_set_def power2_commute UNIV_2)
  by (auto simp: forall_2 intro!: poly_derivatives)

lemma pendulum_flow:
  "\<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil> \<le> wp (x\<acute>= f & G) \<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil>"
  by (simp add: local_flow.wp_g_ode[OF local_flow_pend])

no_notation fpend ("f")
        and pend_flow ("\<phi>")

subsubsection\<open> Bouncing Ball \<close>

text \<open> A ball is dropped from rest at an initial height @{text "h"}. The motion is described with
the free-fall equations @{text "x' t = v t"} and @{text "v' t = g"} where @{text "g"} is the
constant acceleration due to gravity. The bounce is modelled with a variable assigntment that
flips the velocity, thus it is a completely elastic collision with the ground. We use @{text "s$1"}
to ball's height and @{text "s$2"} for its velocity. We prove that the ball remains above ground
and below its initial resting position. \<close>

abbreviation fball :: "real \<Rightarrow> real^2 \<Rightarrow> real^2" ("f")
  where "f g s \<equiv> (\<chi> i. if i = 1 then s$2 else g)"

abbreviation ball_flow :: "real \<Rightarrow> real \<Rightarrow> real^2 \<Rightarrow> real^2" ("\<phi>")
  where "\<phi> g t s \<equiv> (\<chi> i. if i = 1 then g * t ^ 2/2 + s$2 * t + s$1 else g * t + s$2)"

\<comment> \<open>Verified with differential invariants. \<close>

named_theorems bb_real_arith "real arithmetic properties for the bouncing ball."

lemma inv_imp_pos_le[bb_real_arith]:
  assumes "0 > g" and inv: "2 * g * x - 2 * g * h = v * v"
  shows "(x::real) \<le> h"
proof-
  have "v * v = 2 * g * x - 2 * g * h \<and> 0 > g"
    using inv and \<open>0 > g\<close> by auto
  hence obs:"v * v = 2 * g * (x - h) \<and> 0 > g \<and> v * v \<ge> 0"
    using left_diff_distrib mult.commute by (metis zero_le_square)
  hence "(v * v)/(2 * g) = (x - h)"
    by auto
  also from obs have "(v * v)/(2 * g) \<le> 0"
    using divide_nonneg_neg by fastforce
  ultimately have "h - x \<ge> 0"
    by linarith
  thus ?thesis by auto
qed

lemma bouncing_ball_inv:
  fixes h::real
  shows "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow> \<lceil>\<lambda>s. s$1 = h \<and> s$2 = 0\<rceil> \<le>
  wp
    (LOOP
      ((x\<acute>= f g & (\<lambda> s. s$1 \<ge> 0) DINV (\<lambda>s. 2 * g * s$1 - 2 * g * h - s$2 * s$2 = 0));
       (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
    INV (\<lambda>s. 0 \<le> s$1 \<and> 2 * g * s$1 - 2 * g * h - s$2 * s$2 = 0)
  ) \<lceil>\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h\<rceil>"
  apply(rule wp_loopI, simp_all, force simp: bb_real_arith)
  by (rule wp_g_odei) (auto intro!: poly_derivatives diff_invariant_rules)

\<comment> \<open>Verified by providing dynamics. \<close>

lemma inv_conserv_at_ground[bb_real_arith]:
  assumes invar: "2 * g * x = 2 * g * h + v * v"
    and pos: "g * \<tau>\<^sup>2 / 2 + v * \<tau> + (x::real) = 0"
  shows "2 * g * h + (g * \<tau> * (g * \<tau> + v) + v * (g * \<tau> + v)) = 0"
proof-
  from pos have "g * \<tau>\<^sup>2  + 2 * v * \<tau> + 2 * x = 0" by auto
  then have "g\<^sup>2 * \<tau>\<^sup>2  + 2 * g * v * \<tau> + 2 * g * x = 0"
    by (metis (mono_tags, hide_lams) Groups.mult_ac(1,3) mult_zero_right
        monoid_mult_class.power2_eq_square semiring_class.distrib_left)
  hence "g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + v\<^sup>2 + 2 * g * h = 0"
    using invar by (simp add: monoid_mult_class.power2_eq_square)
  hence obs: "(g * \<tau> + v)\<^sup>2 + 2 * g * h = 0"
    apply(subst power2_sum) by (metis (no_types, hide_lams) Groups.add_ac(2, 3)
        Groups.mult_ac(2, 3) monoid_mult_class.power2_eq_square nat_distrib(2))
  thus "2 * g * h + (g * \<tau> * (g * \<tau> + v) + v * (g * \<tau> + v)) = 0"
    by (simp add: monoid_mult_class.power2_eq_square)
qed

lemma inv_conserv_at_air[bb_real_arith]:
  assumes invar: "2 * g * x = 2 * g * h + v * v"
  shows "2 * g * (g * \<tau>\<^sup>2 / 2 + v * \<tau> + (x::real)) =
  2 * g * h + (g * \<tau> * (g * \<tau> + v) + v * (g * \<tau> + v))" (is "?lhs = ?rhs")
proof-
  have "?lhs = g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + 2 * g * x"
    by(auto simp: algebra_simps semiring_normalization_rules(29))
  also have "... = g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + 2 * g * h + v * v" (is "... = ?middle")
    by(subst invar, simp)
  finally have "?lhs = ?middle".
  moreover
  {have "?rhs = g * g * (\<tau> * \<tau>) + 2 * g * v * \<tau> + 2 * g * h + v * v"
    by (simp add: Groups.mult_ac(2,3) semiring_class.distrib_left)
  also have "... = ?middle"
    by (simp add: semiring_normalization_rules(29))
  finally have "?rhs = ?middle".}
  ultimately show ?thesis by auto
qed

lemma bouncing_ball_dyn:
  fixes h::real
  assumes "g < 0" and "h \<ge> 0"
  shows "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  \<lceil>\<lambda>s. s$1 = h \<and> s$2 = 0\<rceil> \<le> wp
    (LOOP
      ((EVOL (\<phi> g) (\<lambda>s. 0 \<le> s$1) T);
      (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
    INV (\<lambda>s. 0 \<le> s$1 \<and> 2 * g * s$1 = 2 * g * h + s$2 * s$2))
  \<lceil>\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h\<rceil>"
  by (rule wp_loopI) (auto simp: bb_real_arith)

\<comment> \<open>Verified with the flow. \<close>

lemma local_flow_ball: "local_flow (f g) UNIV UNIV (\<phi> g)"
  apply(unfold_locales, simp_all add: local_lipschitz_def lipschitz_on_def vec_eq_iff, clarsimp)
    apply(rule_tac x="1/2" in exI, clarsimp, rule_tac x=1 in exI)
    apply(simp add: dist_norm norm_vec_def L2_set_def UNIV_2)
  by (auto simp: forall_2 intro!: poly_derivatives)

lemma bouncing_ball_flow:
  fixes h::real
  assumes "g < 0" and "h \<ge> 0"
  shows "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  \<lceil>\<lambda>s. s$1 = h \<and> s$2 = 0\<rceil> \<le> wp
    (LOOP
      ((x\<acute>= f g & (\<lambda> s. s$1 \<ge> 0));
      (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
    INV (\<lambda>s. 0 \<le> s$1 \<and> 2 * g * s$1 = 2 * g * h + s$2 * s$2))
  \<lceil>\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h\<rceil>"
  apply(rule wp_loopI, simp_all add: local_flow.wp_g_ode[OF local_flow_ball])
  by (auto simp: bb_real_arith)

no_notation fball ("f")
        and ball_flow ("\<phi>")

subsubsection\<open> Thermostat \<close>

text \<open> A thermostat has a chronometer, a thermometer and a switch to turn on and off a heater.
At most every @{text "t"} minutes, it sets its chronometer to @{term "0::real"}, it registers
the room temperature, and it turns the heater on (or off) based on this reading. The temperature
follows the ODE @{text "T' = - a * (T - U)"} where @{text "U"} is @{text "L \<ge> 0"} when the heater
is on, and @{text "0"} when it is off. We use @{term "1::4"} to denote the room's temperature,
@{term "2::4"} is time as measured by the thermostat's chronometer, @{term "3::4"} is the
temperature detected by the thermometer, and @{term "4::4"} states whether the heater is on
(@{text "s$4 = 1"}) or off (@{text "s$4 = 0"}). We prove that the thermostat keeps the room's
temperature between @{text "Tmin"} and @{text "Tmax"}. \<close>

abbreviation temp_vec_field :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("f")
  where "f a L s \<equiv> (\<chi> i. if i = 2 then 1 else (if i = 1 then - a * (s$1 - L) else 0))"

abbreviation temp_flow :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("\<phi>")
  where "\<phi> a L t s \<equiv> (\<chi> i. if i = 1 then - exp(-a * t) * (L - s$1) + L else
  (if i = 2 then t + s$2 else s$i))"

\<comment> \<open>Verified with the flow. \<close>

lemma norm_diff_temp_dyn: "0 < a \<Longrightarrow> \<parallel>f a L s\<^sub>1 - f a L s\<^sub>2\<parallel> = \<bar>a\<bar> * \<bar>s\<^sub>1$1 - s\<^sub>2$1\<bar>"
proof(simp add: norm_vec_def L2_set_def, unfold UNIV_4, simp)
  assume a1: "0 < a"
  have f2: "\<And>r ra. \<bar>(r::real) + - ra\<bar> = \<bar>ra + - r\<bar>"
    by (metis abs_minus_commute minus_real_def)
  have "\<And>r ra rb. (r::real) * ra + - (r * rb) = r * (ra + - rb)"
    by (metis minus_real_def right_diff_distrib)
  hence "\<bar>a * (s\<^sub>1$1 + - L) + - (a * (s\<^sub>2$1 + - L))\<bar> = a * \<bar>s\<^sub>1$1 + - s\<^sub>2$1\<bar>"
    using a1 by (simp add: abs_mult)
  thus "\<bar>a * (s\<^sub>2$1 - L) - a * (s\<^sub>1$1 - L)\<bar> = a * \<bar>s\<^sub>1$1 - s\<^sub>2$1\<bar>"
    using f2 minus_real_def by presburger
qed

lemma local_lipschitz_temp_dyn:
  assumes "0 < (a::real)"
  shows "local_lipschitz UNIV UNIV (\<lambda>t::real. f a L)"
  apply(unfold local_lipschitz_def lipschitz_on_def dist_norm)
  apply(clarsimp, rule_tac x=1 in exI, clarsimp, rule_tac x=a in exI)
  using assms
  apply(simp_all add: norm_diff_temp_dyn)
  apply(simp add: norm_vec_def L2_set_def, unfold UNIV_4, clarsimp)
  unfolding real_sqrt_abs[symmetric] by (rule real_le_lsqrt) auto

lemma local_flow_temp: "a > 0 \<Longrightarrow> local_flow (f a L) UNIV UNIV (\<phi> a L)"
  by (unfold_locales, auto intro!: poly_derivatives local_lipschitz_temp_dyn simp: forall_4 vec_eq_iff)

lemma temp_dyn_down_real_arith:
  assumes "a > 0" and Thyps: "0 < Tmin" "Tmin \<le> T" "T \<le> Tmax"
    and thyps: "0 \<le> (t::real)" "\<forall>\<tau>\<in>{0..t}. \<tau> \<le> - (ln (Tmin / T) / a) "
  shows "Tmin \<le> exp (-a * t) * T" and "exp (-a * t) * T \<le> Tmax"
proof-
  have "0 \<le> t \<and> t \<le> - (ln (Tmin / T) / a)"
    using thyps by auto
  hence "ln (Tmin / T) \<le> - a * t \<and> - a * t \<le> 0"
    using assms(1) divide_le_cancel by fastforce
  also have "Tmin / T > 0"
    using Thyps by auto
  ultimately have obs: "Tmin / T \<le> exp (-a * t)" "exp (-a * t) \<le> 1"
    using exp_ln exp_le_one_iff by (metis exp_less_cancel_iff not_less, simp)
  thus "Tmin \<le> exp (-a * t) * T"
    using Thyps by (simp add: pos_divide_le_eq)
  show "exp (-a * t) * T \<le> Tmax"
    using Thyps mult_left_le_one_le[OF _ exp_ge_zero obs(2), of T]
      less_eq_real_def order_trans_rules(23) by blast
qed

lemma temp_dyn_up_real_arith:
  assumes "a > 0" and Thyps: "Tmin \<le> T" "T \<le> Tmax" "Tmax < (L::real)"
    and thyps: "0 \<le> t" "\<forall>\<tau>\<in>{0..t}. \<tau> \<le> - (ln ((L - Tmax) / (L - T)) / a) "
  shows "L - Tmax \<le> exp (-(a * t)) * (L - T)"
    and "L - exp (-(a * t)) * (L - T) \<le> Tmax"
    and "Tmin \<le> L - exp (-(a * t)) * (L - T)"
proof-
  have "0 \<le> t \<and> t \<le> - (ln ((L - Tmax) / (L - T)) / a)"
    using thyps by auto
  hence "ln ((L - Tmax) / (L - T)) \<le> - a * t \<and> - a * t \<le> 0"
    using assms(1) divide_le_cancel by fastforce
  also have "(L - Tmax) / (L - T) > 0"
    using Thyps by auto
  ultimately have "(L - Tmax) / (L - T) \<le> exp (-a * t) \<and> exp (-a * t) \<le> 1"
    using exp_ln exp_le_one_iff by (metis exp_less_cancel_iff not_less)
  moreover have "L - T > 0"
    using Thyps by auto
  ultimately have obs: "(L - Tmax) \<le> exp (-a * t) * (L - T) \<and> exp (-a * t) * (L - T) \<le> (L - T)"
    by (simp add: pos_divide_le_eq)
  thus "(L - Tmax) \<le> exp (-(a * t)) * (L - T)"
    by auto
  thus "L - exp (-(a * t)) * (L - T) \<le> Tmax"
    by auto
  show "Tmin \<le> L - exp (-(a * t)) * (L - T)"
    using Thyps and obs by auto
qed

lemmas fbox_temp_dyn = local_flow.fbox_g_ode_ivl[OF local_flow_temp _ UNIV_I]

lemma thermostat:
  assumes "a > 0" and "0 \<le> t" and "0 < Tmin" and "Tmax < L"
  shows "\<lceil>\<lambda>s. Tmin \<le> s$1 \<and> s$1 \<le> Tmax \<and> s$4 = 0\<rceil> \<le> wp
  (LOOP
    \<comment> \<open>control\<close>
    ((2 ::= (\<lambda>s. 0));(3 ::= (\<lambda>s. s$1));
    (IF (\<lambda>s. s$4 = 0 \<and> s$3 \<le> Tmin + 1) THEN (4 ::= (\<lambda>s.1)) ELSE
    (IF (\<lambda>s. s$4 = 1 \<and> s$3 \<ge> Tmax - 1) THEN (4 ::= (\<lambda>s.0)) ELSE skip));
    \<comment> \<open>dynamics\<close>
    (IF (\<lambda>s. s$4 = 0) THEN (x\<acute>=(f a 0) & (\<lambda>s. s$2 \<le> - (ln (Tmin/s$3))/a) on {0..t} UNIV @ 0)
    ELSE (x\<acute>=(f a L) & (\<lambda>s. s$2 \<le> - (ln ((L-Tmax)/(L-s$3)))/a) on {0..t} UNIV @ 0)) )
  INV (\<lambda>s. Tmin \<le>s$1 \<and> s$1 \<le> Tmax \<and> (s$4 = 0 \<or> s$4 = 1)))
  \<lceil>\<lambda>s. Tmin \<le> s$1 \<and> s$1 \<le> Tmax\<rceil>"
  apply(rule wp_loopI, simp_all add: fbox_temp_dyn[OF assms(1,2)])
  using temp_dyn_up_real_arith[OF assms(1) _ _ assms(4), of Tmin]
    and temp_dyn_down_real_arith[OF assms(1,3), of _ Tmax] by auto

no_notation temp_vec_field ("f")
        and temp_flow ("\<phi>")

end


theory TestRevList
imports Main
begin

no_notation Nil("[]") and Cons (infixr "#" 65) and append (infixr "@" 65)
hide_type list
hide_const rev

datatype 'a list = Nil ("[]")
| Cons 'a "'a list" (infixr "#" 65)

primrec app :: "'a list => 'a list =>'a list" (infixr "@" 65)
where
"[] @ ys = ys" |
"(x # xs) @ ys = x # (xs @ ys)"

primrec rev :: "'a list => 'a list" where
"rev [] = []" |
"rev (x # xs) = (rev xs) @ (x #[])"

value "rev (True # False # [])"
value "rev (a # b# c# [])"

lemma app_assoc [simp]: "(xs @ys) @ zs = xs @(ys @zs)"
  apply(induct_tac xs)
  apply(auto)
  done

lemma app_Nil [simp]: "xs @ [] = xs"
  apply(induct_tac xs)
  apply(auto)
  done

lemma rev_app [simp]: "rev(xs@ys) = (rev ys) @ (rev xs)"
  apply(induct_tac xs)
   apply(auto)
  done

theorem rev_rev [simp]: "rev(rev xs) = xs"
  apply(induct_tac xs)
  apply(auto)
done


section\<open>Functions\<close>
theory Functions
imports
  Bin_Rels
  Rewrite
  HOTG.Set_Difference
begin

subsection \<open>Evaluation of Functions\<close>

definition "eval S x \<equiv> THE y. \<langle>x, y\<rangle> \<in> S"

bundle isa_set_eval_syntax begin notation eval ("(_`_)" [999, 1000] 999) end
bundle no_isa_set_eval_syntax begin no_notation eval ("_`_" [999, 1000] 999) end
unbundle isa_set_eval_syntax

lemma eval_singleton_eq [simp]: "{\<langle>x, y\<rangle>}`x = y"
  unfolding eval_def by auto

lemma eval_repl_eq [simp]: "x \<in> A \<Longrightarrow> {\<langle>a, f a\<rangle> | a \<in> A}`x = f x"
  unfolding eval_def by auto

lemma cons_eval_eq [simp]:
  "x \<notin> dom A \<Longrightarrow> (cons \<langle>x, y\<rangle> A)`x = y"
  unfolding eval_def by auto

lemma cons_eval_eq' [simp]:
  "x \<noteq> y \<Longrightarrow> (cons \<langle>y, z\<rangle> A)`x = A`x"
  unfolding eval_def by auto

lemma bin_union_eval_eq_left_eval [simp]:
  "x \<notin> dom B \<Longrightarrow> (A \<union> B)`x = A`x"
  unfolding eval_def by (auto elim: not_mem_domE)

lemma bin_union_eval_eq_right_eval [simp]:
  "x \<notin> dom A \<Longrightarrow> (A \<union> B)`x = B`x"
  unfolding eval_def by (auto elim: not_mem_domE)

subsection \<open>Functional Part of a Set\<close>

text \<open>The following expresses that a set S is a function on A (it need not even be
relation elsewhere).\<close>

definition "function A S \<equiv> \<forall>x \<in> A. \<exists>!y. \<langle>x, y\<rangle> \<in> S"

(*TODO: alternative with type constraints rather than set constraints*)
(* definition "fu A B \<equiv> type (\<lambda>f. \<forall>x : A. \<exists>!y. \<langle>x, y\<rangle> \<in> f \<and> y : B x)"
definition "fu3 A B C \<equiv> fu A (\<lambda>x. fu (B x) (C x))" *)

lemma functionI [intro]:
  assumes "\<And>x y y'. \<lbrakk>x \<in> A; \<langle>x, y\<rangle> \<in> S; \<langle>x, y'\<rangle> \<in> S\<rbrakk> \<Longrightarrow> y = y'"
  and "\<And>x. x \<in> A \<Longrightarrow> \<exists>y. \<langle>x, y\<rangle> \<in> S"
  shows "function A S"
  unfolding function_def by (auto intro: assms)

lemma functionD: "function A S \<Longrightarrow> x \<in> A \<Longrightarrow> \<exists>!y. \<langle>x, y\<rangle> \<in> S"
  unfolding function_def by auto

lemma function_right_unique:
  "\<lbrakk>function A S; x \<in> A; S`x = y; S`x = y'\<rbrakk> \<Longrightarrow> y = y'"
  unfolding function_def by auto

lemma function_pair_eval_mem_if_mem_dom [elim]:
  "\<lbrakk>function A S; x \<in> A\<rbrakk> \<Longrightarrow> \<langle>x, S`x\<rangle> \<in> S"
  unfolding eval_def function_def by (rule theI', drule ballD)

lemma function_pair_mem_iff_eval_eq [iff]:
  "\<lbrakk>function A S; x \<in> A\<rbrakk> \<Longrightarrow> \<langle>x, y\<rangle> \<in> S \<longleftrightarrow> S`x = y"
  unfolding function_def eval_def by (auto dest!: ballD intro: theI')

lemma function_mem_domE:
  assumes "function A S"
  and "x \<in> A"
  obtains y where "S`x = y"
  using assms by auto

lemma function_empty_dom: "function {} S"
  unfolding function_def by auto

subsection \<open>Generic Notion of a Function\<close>

definition [typedef]: "Fun \<equiv> (\<lambda>f. function (dom f) f) \<sqdot> Bin_Rel"

lemma
  FunI: "\<lbrakk>f : Bin_Rel; function (dom f) f\<rbrakk> \<Longrightarrow> f : Fun" and
  FunD: "f : Fun \<Longrightarrow> function (dom f) f \<and> f : Bin_Rel"
  unfolding Fun_def by auto

lemma FunE [elim]:
  assumes "f : Fun"
  obtains "f : Bin_Rel" "function (dom f) f"
  using assms by (auto dest: FunD)

lemma Fun_right_unique:
  assumes "f : Fun"
  and "x \<in> dom f"
  and "f`x = y"
  and "f`x = y'"
  shows "y = y'"
proof -
  from \<open>f : Fun\<close> have "function (dom f) f" by (auto dest: FunD)
  with function_right_unique show "y = y'" using assms by auto
qed

lemma Fun_pair_mem_iff_eval_eq:
  "f : Fun \<Longrightarrow> x \<in> (dom f) \<Longrightarrow> \<langle>x, y\<rangle> \<in> f \<longleftrightarrow> f`x = y"
  by auto

lemma Fun_eval_eq_if_pair_mem [simp]:
  "\<lbrakk>f : Fun; \<langle>x, y\<rangle> \<in> f\<rbrakk> \<Longrightarrow> f`x = y"
  by auto

lemma Fun_fst_snd_eq_pair_if_mem [simp]:
  "\<lbrakk>f : Fun; p \<in> f\<rbrakk> \<Longrightarrow> \<langle>fst p, snd p\<rangle> = p"
  by auto

lemma Fun_fst_snd_mem_if_mem:
  "\<lbrakk>f : Fun; p \<in> f\<rbrakk> \<Longrightarrow> \<langle>fst p, snd p\<rangle> \<in> f"
  by auto

lemma Fun_fst_mem_dom_if_mem:
  "\<lbrakk>f : Fun; p \<in> f\<rbrakk> \<Longrightarrow> fst p \<in> (dom f)"
  by auto

lemma Fun_eval_fst_eq [simp]:
  "\<lbrakk>f : Fun; p \<in> f\<rbrakk> \<Longrightarrow> f`(fst p) = snd p"
  by auto

lemma Fun_mem_domE:
  assumes "f : Fun"
  and "x \<in> dom f"
  obtains y where "f`x = y"
  using assms by auto

lemma Fun_memE [elim]:
  assumes "f : Fun"
  and "p \<in> f"
  obtains x y where "p = \<langle>x, y\<rangle>" "f`x = y"
  using assms by (auto dest: Fun_fst_snd_eq_pair_if_mem[symmetric])

subsection \<open>Functions with Explicit Domain and Codomain\<close>

definition [typedef]: "Dep_Function A B \<equiv> function A \<sqdot> Subset (\<Sum>x \<in> A. (B x))"

abbreviation "Function A B \<equiv> Dep_Function A (\<lambda>_. B)"

text \<open>Set model of \<^term>\<open>Dep_Function\<close>:\<close>

definition
  "dep_functions A B \<equiv> {f \<in> powerset (\<Sum>x \<in> A. (B x)) | function A f}"

(*TODO: localise*)
syntax
  "_dep_functions"  :: \<open>[pttrns, set, set] \<Rightarrow> set type\<close> ("(2\<Prod>_ \<in> _./ _)" [0, 0, 100])
  "_dep_functions2" :: \<open>[pttrns, set, set] \<Rightarrow> set type\<close>
translations
  "\<Prod>x xs \<in> A. B" \<rightharpoonup> "CONST dep_functions A (\<lambda>x. _dep_functions2 xs A B)"
  "_dep_functions2 x A B" \<rightharpoonup> "\<Prod>x \<in> A. B"
  "\<Prod>x \<in> A. B" \<rightleftharpoons> "CONST dep_functions A (\<lambda>x. B)"

text \<open>Syntax rules converting soft type notation to underlying set representation:\<close>
syntax
  "_telescope'" :: "logic \<Rightarrow> logic \<Rightarrow> logic"  (infixr "\<rightarrow>" 50)
translations
  "(x \<in> A) \<rightarrow> (y \<in> B) \<rightarrow> C" \<rightleftharpoons> "(x \<in> A) \<rightarrow> \<Prod>y \<in> B. C"
  "(x \<in> A) \<rightarrow> B \<rightarrow> C" \<rightleftharpoons> "(x \<in> A) \<rightarrow> \<Prod>_ \<in> B. C"
  "A \<rightarrow> (y \<in> B) \<rightarrow> C" \<rightleftharpoons> "A \<rightarrow> \<Prod>y \<in> B. C"
  "A \<rightarrow> B \<rightarrow> C" \<rightleftharpoons> "A \<rightarrow> \<Prod>_ \<in> B. C"
  "\<Prod>x \<in> A. ((y \<in> B) \<rightarrow> C)" \<rightharpoonup> "\<Prod>x \<in> A. \<Prod>y \<in> B. C"
  "\<Prod>x \<in> A. (B \<rightarrow> C)" \<rightharpoonup> "\<Prod>x \<in> A. \<Prod>_ \<in> B. C"
  "(x \<in> A) \<rightarrow> B" \<rightleftharpoons> "CONST Dep_Function A (\<lambda>x. B)"
  "A \<rightarrow> B" \<rightleftharpoons> "CONST Function A B"

soft_type_translation "f \<in> \<Prod>x \<in> A. (B x)" \<rightleftharpoons> "f : (x \<in> A) \<rightarrow> B x"
  unfolding dep_functions_def by unfold_types auto

corollary mem_dep_functions_iff_Dep_Function:
  "f \<in> \<Prod>x \<in> A. (B x) \<longleftrightarrow> f : (x \<in> A) \<rightarrow> B x"
  by auto

corollary Element_dep_functions_iff_Dep_Function:
  "f : (Element \<Prod>x \<in> A. (B x)) \<longleftrightarrow> f : (x \<in> A) \<rightarrow> B x"
  by (subst mem_iff_Element[symmetric]) (fact mem_dep_functions_iff_Dep_Function)

(*TODO: rules like these should automatically be derivable from above lemma and
allow for type simplification*)
lemma Dep_Function_if_Element_dep_functions [derive]:
  "f : Element (\<Prod>x \<in> A. (B x)) \<Longrightarrow> f : (x \<in> A) \<rightarrow> B x"
  by (fact iffD1[OF Element_dep_functions_iff_Dep_Function])

lemma Element_dep_functions_if_Dep_Function [backward_derive]:
  "f : (x \<in> A) \<rightarrow> B x \<Longrightarrow> f : Element (\<Prod>x \<in> A. (B x))"
  by (fact iffD2[OF Element_dep_functions_iff_Dep_Function])

subsection \<open>Properties of generic functions\<close>

lemma Dep_Function_cong [cong]:
  "\<lbrakk>A = A'; \<And>x. x \<in> A \<Longrightarrow> B x = B' x\<rbrakk> \<Longrightarrow> f : (x \<in> A) \<rightarrow> B x \<longleftrightarrow> f : (x \<in> A') \<rightarrow> B' x"
  unfolding Dep_Function_def by auto

lemma function_if_Dep_Function: "f : (x \<in> A) \<rightarrow> B x \<Longrightarrow> function A f"
  by unfold_types

lemma Dep_Function_Subset_dep_pairs [derive]:
  "f : (x \<in> A) \<rightarrow> B x \<Longrightarrow> f : Subset (\<Sum>x \<in> A. (B x))"
  by unfold_types

lemma Dep_Function_dom_eq [simp]:
  assumes "f : (x \<in> A) \<rightarrow> B x"
  shows "dom f = A"
proof (rule eqI)
  have "function A f" by (rule function_if_Dep_Function) discharge_types
  fix x assume "x \<in> A"
  then show "x \<in> dom f"
    by (intro mem_domI) (auto dest!: functionD[OF \<open>function A f\<close>])
next
  have f_subset: "f \<subseteq> \<Sum>x \<in> A. (B x)" by discharge_types
  fix x assume "x \<in> dom f"
  then obtain y where "\<langle>x, y\<rangle> \<in> f "by auto
  with f_subset have "\<langle>x, y\<rangle> \<in> \<Sum>x \<in> A. (B x)" by auto
  then show "x \<in> A" by simp
qed

lemma Fun_if_Dep_Function [derive]: "f : (x \<in> A) \<rightarrow> B x \<Longrightarrow> f : Fun"
  by (rule FunI) (auto dest: function_if_Dep_Function)

lemma Function_if_Dep_Function [derive]:
  "f : (x \<in> A) \<rightarrow> B x \<Longrightarrow> f : A \<rightarrow> (\<Union>x \<in> A. B x)"
  by unfold_types auto

lemma Dep_FunctionI:
  assumes func_f: "function A f"
  and "f : Bin_Rel"
  and [simp]: "dom f = A"
  and f_eval_x_mem: "\<And>x. x \<in> A \<Longrightarrow> f`x \<in> B x"
  shows "f : (x \<in> A) \<rightarrow> B x"
proof -
  {
    have f_subset: "f \<subseteq> (dom f) \<times> (rng f)"
      by (rule Bin_Rel_subset_pairs_dom_rng) discharge_types
    fix p assume "p \<in> f"
    with f_subset obtain x y where "x \<in> A" and [simp]: "p = \<langle>x, y\<rangle>" by auto
    with \<open>p \<in> f\<close> have "f`x = y" by auto
    moreover have "f`x \<in> B x" by (fact f_eval_x_mem[OF \<open>x \<in> A\<close>])
    ultimately have "p \<in> \<Sum>x \<in> A. B x" by auto
  }
  then show ?thesis
    by (intro iffD1[OF mem_dep_functions_iff_Dep_Function])
      (auto simp only: dep_functions_def)
qed

lemma FunctionI' [derive]: "f : function A \<sqdot> Relation A B \<Longrightarrow> f : A \<rightarrow> B"
  by unfold_types

lemma Dep_Function_pair_eval_mem_if_mem [elim]:
  assumes "f : (x \<in> A) \<rightarrow> B x"
  and "x \<in> A"
  shows "\<langle>x, f`x\<rangle> \<in> f"
  using assms by (auto dest: function_if_Dep_Function)

lemma Dep_Function_mem_dom_if_pair_mem:
  "\<lbrakk>f : (x \<in> A) \<rightarrow> B x; \<langle>x, y\<rangle> \<in> f\<rbrakk> \<Longrightarrow> x \<in> A"
  by unfold_types auto

lemma Dep_Function_mem_codom_if_pair_mem:
  "\<lbrakk>f : (x \<in> A) \<rightarrow> B x; \<langle>x, y\<rangle> \<in> f\<rbrakk> \<Longrightarrow> y \<in> B x"
  by unfold_types auto

lemma Dep_Function_eval_mem_if_mem [elim]:
  "\<lbrakk>f : (x \<in> A) \<rightarrow> B x; x \<in> A\<rbrakk> \<Longrightarrow> f`x \<in> B x"
  using Dep_Function_mem_codom_if_pair_mem
  by (fast dest: Dep_Function_pair_eval_mem_if_mem)

lemma Dep_Function_fst_mem_dom_if_mem [elim]:
  "\<lbrakk>f : (x \<in> A) \<rightarrow> B x; p \<in> f\<rbrakk> \<Longrightarrow> fst p \<in> A"
  by (rule Dep_Function_mem_dom_if_pair_mem)
    (auto intro: Fun_fst_snd_mem_if_mem)

lemma Dep_Function_snd_mem_codom_if_mem:
  "\<lbrakk>f : (x \<in> A) \<rightarrow> B x; p \<in> f\<rbrakk> \<Longrightarrow> snd p \<in> B (fst p)"
  by (rule Dep_Function_mem_codom_if_pair_mem)
    (auto intro: Fun_fst_snd_mem_if_mem)

lemma Dep_Function_subset_pairs: "f : (x \<in> A) \<rightarrow> B x \<Longrightarrow> f \<subseteq> A \<times> (\<Union>x \<in> A. B x)"
  by auto

lemma Function_subset_pairs [derive]:
  "f : A \<rightarrow> B \<Longrightarrow> f : Subset (A \<times> B)"
  by auto

lemma Dep_Function_fst_snd_eq_pair [simp]:
  assumes "f : (x \<in> A) \<rightarrow> B x"
  and "p \<in> f"
  shows "\<langle>fst p, snd p\<rangle> = p"
  using assms by (auto intro!: Fun_fst_snd_eq_pair_if_mem)

lemma Dep_Function_fst_eval_fst_eq_pair [simp]:
  assumes "f : (x \<in> A) \<rightarrow> B x"
  and "p \<in> f"
  shows "f`(fst p) = snd p"
  using assms by auto

lemma Dep_Function_pair_mem_iff_eval_eq:
  "f : (x \<in> A) \<rightarrow> B x \<Longrightarrow> x \<in> A \<Longrightarrow> \<langle>x, y\<rangle> \<in> f \<longleftrightarrow> f`x = y"
  by auto

lemma Dep_Fun_eval_eq_if_pair_mem [simp]:
  "\<lbrakk>f : (x \<in> A) \<rightarrow> B x; \<langle>x, y\<rangle> \<in> f\<rbrakk> \<Longrightarrow> f`x = y"
  by auto

lemma Dep_Function_mem_domE:
  assumes "f : (x \<in> A) \<rightarrow> B x"
  and "x \<in> A"
  obtains y where "f`x = y" "y \<in> B x"
  using assms Dep_Function_eval_mem_if_mem by auto

lemma Dep_Function_memE [elim]:
  assumes "f : (x \<in> A) \<rightarrow> B x"
  and "p \<in> f"
  obtains x y where "p = \<langle>x, y\<rangle>" "x \<in> A" "y \<in> B x" "f`x = y"
proof -
  assume hyp: "\<And>x y. p = \<langle>x, y\<rangle> \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> B x \<Longrightarrow> f`x = y \<Longrightarrow> thesis"
  obtain x y where "p = \<langle>x, y\<rangle>" "f`x = y"
    by (rule Fun_memE) (insert assms, auto)
  then show thesis
  proof (intro hyp[of x y])
    from assms have "p = \<langle>fst p, snd p\<rangle>" by auto
    moreover from Dep_Function_fst_mem_dom_if_mem have "fst p \<in> A"
      using assms by auto
    moreover from Dep_Function_snd_mem_codom_if_mem have "snd p \<in> B (fst p)"
      using assms by auto
    ultimately show "x \<in> A" and "y \<in> B x" using \<open>p = \<langle>x, y\<rangle>\<close> by auto
  qed assumption
qed

lemma Dep_Function_Rep_eval_eq [simp]:
  assumes "f : (x \<in> A) \<rightarrow> B x"
  shows "{\<langle>x, f`x\<rangle> | x \<in> A} = f"
  using assms by (intro eqI) auto

lemma Dep_Function_empty_dom_iff_eq_empty [iff]: "f : (x \<in> {}) \<rightarrow> B x \<longleftrightarrow> f = {}"
  by unfold_types auto

lemma Dep_Function_subsetI:
  assumes f_type: "f : (x \<in> A) \<rightarrow> B x"
  and g_type: "g : (x \<in> A') \<rightarrow> B' x"
  and A_subset: "A \<subseteq> A'"
  and f_g_agree: "\<And>x. x \<in> A \<Longrightarrow> f`x = g`x"
  shows "f \<subseteq> g"
proof
  fix p assume "p \<in> f"
  then obtain x y where p_eq: "p = \<langle>x, y\<rangle>" and "x \<in> A" "f`x = y"
    by (rule Dep_Function_memE[OF f_type])
  with f_g_agree have p_eq: "p = \<langle>x, g`x\<rangle>" by blast
  show "p \<in> g"
    by (subst p_eq, rule Dep_Function_pair_eval_mem_if_mem[OF g_type])
      (insert A_subset, auto)
qed

lemma Dep_Function_eval_eqI:
  assumes "f : (x \<in> A) \<rightarrow> B x" "g : (x \<in> A') \<rightarrow> B' x"
  and "f \<subseteq> g"
  and "x \<in> A \<inter> A'"
  shows "f`x = g`x"
proof -
  from assms have "\<langle>x, f`x\<rangle> \<in> g" and "\<langle>x, g`x\<rangle> \<in> g" by auto
  then show ?thesis by auto
qed

lemma Dep_Function_ex_dom_iff:
  "\<exists>A. f : (x \<in> A) \<rightarrow> B x \<longleftrightarrow> f : (x \<in> dom f) \<rightarrow> B x"
  by auto

lemma empty_Function [type]: "{} : {} \<rightarrow> X" by auto

lemma singleton_FunctionI [intro]: "y \<in> B \<Longrightarrow> {\<langle>x, y\<rangle>} : {x} \<rightarrow> B"
  by (rule Dep_FunctionI) auto

lemma Function_eq_singleton [simp]: "f : {a} \<rightarrow> {b} \<Longrightarrow> f = {\<langle>a, b\<rangle>}"
  by (unfold_types, unfold function_def) auto

lemma cons_FunctionI:
  "\<lbrakk>f : A \<rightarrow> B; x \<notin> A\<rbrakk> \<Longrightarrow> cons \<langle>x, y\<rangle> f : A \<union> {x} \<rightarrow> B \<union> {y}"
  by (unfold_types, unfold function_def) auto

lemma cons_FunctionI':
  assumes "f : A \<rightarrow> B"
  and "x \<notin> A"
  and "y \<in> B"
  shows "cons \<langle>x, y\<rangle> f : A \<union> {x} \<rightarrow> B"
proof -
  from assms(1-2) have "cons \<langle>x, y\<rangle> f : A \<union> {x} \<rightarrow> B \<union> {y}"
    by (rule cons_FunctionI)
  moreover from \<open>y \<in> B\<close> have "B \<union> {y} = B" by simp
  ultimately show "cons \<langle>x, y\<rangle> f : A \<union> {x} \<rightarrow> B" by simp
qed

lemma singleton_bin_union_FunctionI:
  "\<lbrakk>f : A \<rightarrow> B; x \<notin> A\<rbrakk> \<Longrightarrow> {\<langle>x, y\<rangle>} \<union> f : A \<union> {x} \<rightarrow> B \<union> {y}"
  by (subst singleton_bin_union_eq_cons, fact cons_FunctionI)

subsection \<open>Lambda abstraction\<close>

definition lambda :: "set \<Rightarrow> (set \<Rightarrow> set) \<Rightarrow> set"
  where "lambda A f \<equiv> {\<langle>x, f x\<rangle> | x \<in> A}"

(*TODO: localise*)
syntax
  "_lam"  :: "[pttrns, set, set] \<Rightarrow> set" ("(2\<lambda>_ \<in> _./ _)" 60)
  "_lam2" :: \<open>[pttrns, set, set] \<Rightarrow> set\<close>
translations
  "\<lambda>x xs \<in> A. f" \<rightharpoonup> "CONST lambda A (\<lambda>x. _lam2 xs A f)"
  "_lam2 x A f" \<rightharpoonup> "\<lambda>x \<in> A. f"
  "\<lambda>x \<in> A. f" \<rightleftharpoons> "CONST lambda A (\<lambda>x. f)"

lemma lambda_cong [cong]:
  "\<lbrakk>A = A'; \<And>x. x \<in> A \<Longrightarrow> f x = f' x\<rbrakk> \<Longrightarrow> (\<lambda>x \<in> A. f x) = \<lambda>x \<in> A'. f' x"
  unfolding lambda_def by auto

lemma eval_lambda_eq [simp]: "a \<in> A \<Longrightarrow> (\<lambda>x \<in> A. f x)`a = f a"
  unfolding lambda_def by auto

lemma eval_lambda_uncurry_eq [simp]:
  assumes "a \<in> A" "b \<in> B"
  shows "(\<lambda>p \<in> A \<times> B. uncurry f p)`\<langle>a, b\<rangle> = f a b"
  using assms by auto

lemma lambda_pairs_eq_lambda_uncurry:
  "(\<lambda>p \<in> A \<times> B. f p) = (\<lambda>\<langle>a, b\<rangle> \<in> A \<times> B. f \<langle>a, b\<rangle>)"
  by (rule lambda_cong) auto

lemma lambda_pair_mem_if_mem [intro]: "a \<in> A \<Longrightarrow> \<langle>a, f a\<rangle> \<in> \<lambda>x \<in> A. f x"
  unfolding lambda_def by auto

lemma lambda_memE [elim]:
  assumes "p \<in> \<lambda>x \<in> A. f x"
  obtains x y where "p = \<langle>x, y\<rangle>" "x \<in> A" "f x = y"
  using assms unfolding lambda_def by auto

lemma lambda_memD [dest]: "\<langle>a, b\<rangle> \<in> \<lambda>x \<in> A. f x \<Longrightarrow> b = f a"
  by auto

lemma lambda_dom_eq [simp]: "dom (\<lambda>x \<in> A. f x) = A"
  unfolding lambda_def by simp

lemma app_eq_if_mem_if_lambda_eq:
  "\<lbrakk>(\<lambda>x \<in> A. f x) = \<lambda>x \<in> A. g x; a \<in> A\<rbrakk> \<Longrightarrow> f a = g a"
  by (erule eqE) auto

subsubsection\<open>Type-theoretic rules\<close>

lemma lambda_type [type]:
  "lambda : (A : Set) \<Rightarrow> ((x : Element A) \<Rightarrow> Element (B x)) \<Rightarrow> (x \<in> A) \<rightarrow> B x"
  by unfold_types auto

(*TODO: it is necessery to specify this backward_derive rule since although
above type rule encodes that the type of f depends on A, this will not be
used in the type_derivator when proving `lambda A f : T`; more specifically,
the derivator will merely derivate types for A and f and then see if they can be
fed to Dep_fun_typeE together with lambda_type*)
lemma lambda_app_type [backward_derive]:
  assumes "A : Set" "f : (x : Element A) \<Rightarrow> Element (B x)"
  shows "lambda A f : (x \<in> A) \<rightarrow> B x"
  by discharge_types

lemma uncurry_type [type]:
  "uncurry : ((a : Element A) \<Rightarrow> (b : Element B) \<Rightarrow> C \<langle>a, b\<rangle>) \<Rightarrow>
    (p : Element (A \<times> B)) \<Rightarrow> C p"
  unfolding uncurry_def by unfold_types auto

(*TODO: if f is a lambda abstraction, the derivator must use backward_derive
rules to prove its type before being able to apply it to uncurry_type together
with Dep_fun_typeE; so we need to create this backward_derive rule to guide
the derivator*)
lemma uncurry_app_type [backward_derive]:
  assumes "f : (a : Element A) \<Rightarrow> (b : Element B) \<Rightarrow> C \<langle>a, b\<rangle>"
  shows "uncurry f : (p : Element (A \<times> B)) \<Rightarrow> C p"
  by discharge_types

lemma eval_type [type]:
  "eval: ((x \<in> A) \<rightarrow> B x) \<Rightarrow> (x : Element A) \<Rightarrow> Element (B x)"
  (*TOOD: the type derivator should convert the set-theoretic statement
    Dep_Function_eval_mem_if_mem to a type-theoretic one*)
  using Dep_Function_eval_mem_if_mem
  by (intro Dep_fun_typeI) (auto intro: ElementI dest: ElementD)

notepad
begin
  have
    "\<lbrakk>f : (x \<in> A) \<rightarrow> (y \<in> B x) \<rightarrow> C x y; a: Element A; b: Element (B a)\<rbrakk>
      \<Longrightarrow> f`a`b: Element (C a b)"
    (*TODO: should not need an increase of the limit*)
    using [[type_derivation_depth=3]]
    by discharge_types
end

lemma lambda_type_dom_subset_if_Dep_Function:
  assumes "f : (x \<in> A) \<rightarrow> B x"
  and "A' \<subseteq> A"
  shows "(\<lambda>a \<in> A'. f`a) : (x \<in> A') \<rightarrow> B x"
  using assms by (intro Dep_FunctionI) auto

lemma lambda_type_dom_bin_inter_if_Dep_Function:
  assumes "f : (x \<in> A) \<rightarrow> B x"
  shows "(\<lambda>a \<in> A \<inter> A'. f`a) : (x \<in> A \<inter> A') \<rightarrow> B x"
  using assms by (rule lambda_type_dom_subset_if_Dep_Function) auto

subsection \<open>Extensionality\<close>

lemma Dep_Function_ext:
  assumes "f : (x \<in> A) \<rightarrow> B x" "g : (x \<in> A) \<rightarrow> C x"
  and "\<And>x. x \<in> A \<Longrightarrow> f`x = g`x"
  shows "f = g"
  by (rule eq_if_subset_if_subset; rule Dep_Function_subsetI) (insert assms, auto)

lemma lambda_ext:
  assumes "f : (x \<in> A) \<rightarrow> B x"
  and "\<And>a. a \<in> A \<Longrightarrow> g a = f`a"
  shows "(\<lambda>a \<in> A. g a) = f"
  unfolding lambda_def
  using assms
  by (rewrite at "{\<langle>x, g x\<rangle> | x \<in> A}" to "{\<langle>x, f`x\<rangle> | x \<in> A}" repl_cong) auto

lemma Dep_Function_eta [simp]: "f : (x \<in> A) \<rightarrow> B x \<Longrightarrow> (\<lambda>x \<in> A. f`x) = f"
  by (rule Dep_Function_ext) auto

lemma Dep_Function_eq_if_subset:
  assumes f_type: "f : (x \<in> A) \<rightarrow> B x" and g_type: "g : (x \<in> A) \<rightarrow> C x"
  and "f \<subseteq> g"
  shows "f = g"
proof (rule eqI)
  fix p assume "p \<in> g"
  with g_type obtain x y where [simp]: "p = \<langle>x, y\<rangle>" "g`x = y" "x \<in> A" by blast
  then have [simp]: "f`x = g`x" by (intro Dep_Function_eval_eqI) auto
  from Dep_Function_pair_mem_iff_eval_eq show "p \<in> f" by auto
qed (insert assms, auto)

(*Every element of `(x \<in> A) \<rightarrow> B x` may be expressed as a lambda abstraction*)
lemma Dep_Function_eq_lambdaE:
  assumes "f : (x \<in> A) \<rightarrow> B x"
  obtains g where "g : (x : Element A) \<Rightarrow> Element (B x)" and "f = (\<lambda>x \<in> A. g x)"
proof
  let ?g="(\<lambda>x. f`x)"
  show "f = (\<lambda>x \<in> A. ?g x)" by auto
  show "?g : (x : Element A) \<Rightarrow> Element (B x)" by discharge_types
qed

(*note: no contravariance with current definition possible*)
lemma Dep_Function_covariant_codom:
  assumes "f : (x \<in> A) \<rightarrow> B x"
  and "\<And>x. x \<in> A \<Longrightarrow> f`x \<in> B x \<Longrightarrow> f`x \<in> B' x"
  shows "f : (x \<in> A) \<rightarrow> B' x"
  using assms by (intro Dep_FunctionI) (auto intro!: functionI)

corollary Dep_Function_covariant_codom_subset:
  assumes "f : (x \<in> A) \<rightarrow> B x"
  and "\<And>x. x \<in> A \<Longrightarrow> B x \<subseteq> C x"
  shows "f : (x \<in> A) \<rightarrow> C x"
  using assms(2) by (intro Dep_Function_covariant_codom[OF assms(1)]) auto

(*Larry: Such functions arise in non-standard datatypes, ZF/ex/Ntree for
  instance.*)
lemma Dep_Function_collectI:
  assumes "f : (x \<in> A) \<rightarrow> B x"
  and "\<And>x. x \<in> A \<Longrightarrow> P x (f`x)"
  shows "f : (x \<in> A) \<rightarrow> {y \<in> B x | P x y}"
  by (rule Dep_Function_covariant_codom) (insert assms, auto)

lemma Dep_Function_collectD:
  assumes "f : (x \<in> A) \<rightarrow> {y \<in> B x | P x y}"
  shows "f : (x \<in> A) \<rightarrow> B x" and "\<And>x. x \<in> A \<Longrightarrow> P x (f`x)"
proof -
  from assms show "f : (x \<in> A) \<rightarrow> B x"
    by (rule Dep_Function_covariant_codom_subset) auto
  fix x assume "x \<in> A"
  then show "P x (f`x)" by (auto dest: Dep_Function_eval_mem_if_mem[OF assms])
qed

subsection \<open>Injectivity and surjectivity\<close>

definition "injective A f \<equiv> \<forall>x x' \<in> A. f`x = f`x' \<longrightarrow> x = x'"

definition "surjective B f \<equiv> \<forall>y \<in> B. \<exists>x. f`x = y"

lemma injectiveI:
  assumes "\<And>x x'. x \<in> A \<Longrightarrow> x' \<in> A \<Longrightarrow> f`x = f`x' \<Longrightarrow> x = x'"
  shows "injective A f"
  unfolding injective_def using assms by simp

lemma surjectiveI:
  assumes "\<And>y. y \<in> B \<Longrightarrow> \<exists>x \<in> A. f`x = y"
  shows "surjective B f"
  unfolding surjective_def using assms by blast

text \<open>Extend a function's domain by mapping new elements to the empty set.\<close>

definition triv_ext :: "set \<Rightarrow> set \<Rightarrow> set"
  where "triv_ext A f \<equiv> f \<union> (\<lambda>x \<in> (A \<setminus> dom f). {})"

lemma dom_triv_ext_eq [simp]: "dom (triv_ext A f) = dom f \<union> A"
  unfolding triv_ext_def by auto

subsection \<open>Composition\<close>

definition "fun_comp g f \<equiv> \<lambda>x \<in> dom f. g`(f`x)"

bundle isa_set_fun_comp_syntax begin notation fun_comp (infixr "\<circ>" 80) end
bundle no_isa_set_fun_comp_syntax begin no_notation fun_comp (infixr "\<circ>" 80) end
unbundle isa_set_fun_comp_syntax

lemma fun_comp_type [type]:
  "(\<circ>) : ((x \<in> B) \<rightarrow> C x) \<Rightarrow> (f : A \<rightarrow> B) \<Rightarrow> (x \<in> A) \<rightarrow> C (f`x)"
  unfolding fun_comp_def
  by (intro Dep_fun_typeI Dep_FunctionI) auto

lemma lambda_comp_lambda_eq [simp]:
  "f : Element A \<Rightarrow> Element B \<Longrightarrow> (\<lambda>y \<in> B. g y) \<circ> (\<lambda>x \<in> A. f x) = \<lambda>x \<in> A. g (f x)"
  unfolding fun_comp_def by auto

lemma comp_id_eq [simp]: "f : (x \<in> A) \<rightarrow> B x \<Longrightarrow> f \<circ> (\<lambda>x \<in> A. x) = f"
  unfolding fun_comp_def by auto

lemma id_comp_eq [simp]: "f : A \<rightarrow> B \<Longrightarrow> (\<lambda>x \<in> B. x) \<circ> f = f"
  unfolding fun_comp_def by auto

lemma comp_assoc [simp]:
  assumes "f : A \<rightarrow> B" "g : B \<rightarrow> C"
  shows "h \<circ> g \<circ> f = (h \<circ> g) \<circ> f"
  (*TOOD: slow proof*)
  unfolding fun_comp_def by auto

subsection \<open>Restriction\<close>

definition "restriction f A \<equiv> \<lambda>a \<in> dom f \<inter> A. f`a"

bundle isa_set_restriction_syntax begin notation restriction (infix "\<restriction>" 100) end
bundle no_isa_set_restriction_syntax begin no_notation restriction (infix "\<restriction>" 100) end
unbundle isa_set_restriction_syntax

lemma restriction_type [type]:
  "(\<restriction>) : ((x \<in> A) \<rightarrow> B x) \<Rightarrow> (A' : Set) \<Rightarrow> (x \<in> A \<inter> A') \<rightarrow> B x"
  unfolding restriction_def
  using lambda_type_dom_bin_inter_if_Dep_Function
  by (auto simp only: Dep_Function_dom_eq)

lemma Fun_restriction_subset [simp]: "f : Fun \<Longrightarrow> restriction f A \<subseteq> f"
  unfolding restriction_def by auto

lemma Fun_restriction_eq_collect:
  assumes "f : Fun"
  shows "f\<restriction>A = {p \<in> f | fst p \<in> A}" (is "?lhs = ?rhs")
proof (rule eqI)
  fix p assume "p \<in> ?rhs"
  then have "p \<in> f" "fst p \<in> A" by auto
  with Fun_fst_mem_dom_if_mem have "fst p \<in> dom f" by auto
  with assms obtain x y where [simp]: "p = \<langle>x, y\<rangle>" "y = f`x"
    by (auto elim!: Fun_memE)
  with assms \<open>fst p \<in> A\<close> \<open>fst p \<in> dom f\<close> show "p \<in> ?lhs"
    unfolding restriction_def by (auto intro!: lambda_pair_mem_if_mem)
next
  fix p assume "p \<in> ?lhs"
  with assms show "p \<in> ?rhs" unfolding restriction_def by auto
qed

lemma restriction_eval_eq [simp]: "a \<in> A \<Longrightarrow> A \<subseteq> dom f \<Longrightarrow> (f\<restriction>A)`a = f`a"
  unfolding restriction_def by auto

lemma dom_restriction_eq [simp]: "dom (f\<restriction>A) = dom f \<inter> A"
  unfolding restriction_def by auto

lemma restriction_type_Subset:
  "(\<restriction>) : ((x \<in> A) \<rightarrow> B x) \<Rightarrow> (A' : Subset A) \<Rightarrow> (x \<in> A') \<rightarrow> B x"
  by (intro Dep_fun_typeI,
    rewrite at "A'" in "(x \<in> A') \<rightarrow> _" in for (A')
      bin_inter_eq_right_if_subset[where ?A=A, symmetric])
    auto

subsection \<open>Gluing\<close>

definition "glue X = \<Union>X"

lemma glue_eval_eq:
  assumes "\<And>f y'. \<lbrakk>f \<in> F; \<langle>x, y'\<rangle> \<in> f\<rbrakk> \<Longrightarrow> y' = y"
  and "f \<in> F"
  and "\<langle>x, y\<rangle> \<in> f"
  shows "(glue F)`x = y"
  unfolding eval_def glue_def by (rule the_equality) (auto intro: assms)

lemma glue_Dep_Functions_typeI:
  assumes all_fun: "\<And>f. f \<in> F \<Longrightarrow> f : (x \<in> dom f) \<rightarrow> B x"
  and all_agree: "\<And>f g x. \<lbrakk>f \<in> F; g \<in> F; x \<in> dom f; x \<in> dom g\<rbrakk> \<Longrightarrow> f`x = g`x"
  shows "glue F : (x \<in> (\<Union>f \<in> F. dom f)) \<rightarrow> B x"
proof (rule Dep_FunctionI)
  {
    fix x assume "x \<in> (\<Union>f \<in> F. dom f)"
    then obtain f where "f \<in> F" "x \<in> dom f" by auto
    moreover have "\<langle>x, f`x\<rangle> \<in> f"
      by (simp only:
        Dep_Function_pair_mem_iff_eval_eq[OF all_fun[OF \<open>f \<in> F\<close>] \<open>x \<in> dom f\<close>])
    ultimately have "\<exists>f y. f \<in> F \<and> \<langle>x, y\<rangle> \<in> f \<and> f`x = y" by auto
  }
  note ex_mem_F_pair_mem = this
  show "function (\<Union>f \<in> F. dom f) (glue F)" unfolding glue_def
  proof
   fix x y y' assume "x \<in> (\<Union>f \<in> F. dom f)" "\<langle>x, y\<rangle> \<in> \<Union>F" "\<langle>x, y'\<rangle> \<in> \<Union>F"
    then obtain f g where f_g_props: "\<langle>x, y\<rangle> \<in> f" "\<langle>x, y'\<rangle> \<in> g" "f \<in> F" "g \<in> F"
      by auto
    with all_fun have "y = f`x" by auto
    also with f_g_props have "... = g`x" by (intro all_agree) auto
    also with all_fun f_g_props have "... = y'" by auto
    finally show "y = y'" .
  next
    fix x assume "x \<in> (\<Union>f \<in> F. dom f)"
    from ex_mem_F_pair_mem[OF this] show "\<exists>y. \<langle>x, y\<rangle> \<in> \<Union>F" by auto
  qed
  fix x assume "x \<in> (\<Union>f \<in> F. dom f)"
  from ex_mem_F_pair_mem[OF this]
    obtain f y where "f \<in> F" "\<langle>x, y\<rangle> \<in> f" and "f`x = y" by auto
  then have "glue F`x = y"
  proof (intro glue_eval_eq)
    fix f' y' assume "f' \<in> F" "\<langle>x, y'\<rangle> \<in> f'"
    with all_fun have "y' = f'`x" by auto
    also with \<open>\<langle>x, y'\<rangle> \<in> f'\<close> have "... = f`x"
      using \<open>\<langle>x, y\<rangle> \<in> f\<close> by (intro all_agree) auto
    finally show "y' = y" using \<open>f`x = y\<close> by simp
  qed assumption
  moreover from \<open>f \<in> F\<close> have "y \<in> B x" by
    (intro Dep_Function_mem_codom_if_pair_mem[where ?B=B]) (auto dest: all_fun)
  ultimately show "glue F`x \<in> B x" unfolding glue_def by auto
qed (unfold glue_def, auto dest: all_fun)

lemma glue_Dep_Functions_eval_eq:
  assumes all_fun: "\<And>f. f \<in> F \<Longrightarrow> f : (x \<in> dom f) \<rightarrow> B x"
  and all_agree: "\<And>f'. \<lbrakk>f' \<in> F; x \<in> dom f'\<rbrakk> \<Longrightarrow> f'`x = f`x"
  and "f \<in> F"
  and "x \<in> dom f"
  shows "(glue F)`x = f`x"
proof (rule glue_eval_eq[OF _ \<open>f \<in> F\<close>])
 fix f' y' assume f'_props: "f' \<in> F" "\<langle>x, y'\<rangle> \<in> f'"
  then have "y' = f'`x"
    by (intro Dep_Fun_eval_eq_if_pair_mem[symmetric]) (auto dest: all_fun)
  also have "... = f`x" using f'_props by (intro all_agree) auto
  finally show "y' = f`x" .
next
  show "\<langle>x, f`x\<rangle> \<in> f"
    by (rule Dep_Function_pair_eval_mem_if_mem) (auto intro: assms)
qed

lemma glue_upair_Dep_Functions_typeI:
  assumes "f : (x \<in> A) \<rightarrow> B x" "g : (x \<in> A') \<rightarrow> B x"
  and "\<And>x. \<lbrakk>x \<in> A; x \<in> A'\<rbrakk> \<Longrightarrow> f`x = g`x"
  shows "glue {f, g} : (x \<in> A \<union> A') \<rightarrow> B x"
proof -
  have "(\<Union>f \<in> {f, g}. dom f) = (\<Union>f \<in> {f}. dom f) \<union> (\<Union>f \<in> {g}. dom f)"
    by (auto simp only: idx_union_bin_union_dom_eq_bin_union_idx_union)
  also have "... = dom f \<union> dom g" by auto
  also have "... = A \<union> A'" by simp
  finally have "A \<union> A' = (\<Union>f \<in> {f, g}. dom f)" by auto
  then show ?thesis using assms by (auto intro: glue_Dep_Functions_typeI)
qed

lemma glue_upair_Dep_Functions_eval_eq_left:
  assumes "f : (x \<in> A) \<rightarrow> B x" "g : (x \<in> A') \<rightarrow> B x"
  and "\<And>x. x \<in> A \<inter> A' \<Longrightarrow> f`x = g`x"
  and "x \<in> A"
  shows "(glue {f, g})`x = f`x"
  by (intro glue_Dep_Functions_eval_eq) (auto simp: assms)

lemma glue_upair_Dep_Functions_eval_eq_right:
  assumes "f : (x \<in> A) \<rightarrow> B x" "g : (x \<in> A') \<rightarrow> B x"
  and "\<And>x. x \<in> A \<inter> A' \<Longrightarrow> f`x = g`x"
  and  "x \<in> A'"
  shows "(glue {f, g})`x = g`x"
  by (subst cons_comm, rule glue_upair_Dep_Functions_eval_eq_left)
    (auto simp: assms)

subsection \<open>Universes\<close>

lemma univ_closed_dep_functions [intro!]:
  assumes "A \<in> univ U"
  and "\<And>x. x \<in> A \<Longrightarrow> B x \<in> univ U"
  shows "\<Prod>x \<in> A. (B x) \<in> univ U"
proof -
  let ?P = "powerset \<Sum>x \<in> A. (B x)"
  have "\<Prod>x \<in> A. (B x) \<subseteq> ?P" unfolding dep_functions_def by (fact collect_subset)
  moreover have "?P \<in> univ U" using assms by auto
  ultimately show ?thesis by (auto intro: mem_univ_trans)
qed

end


(*
    File:        Poset.thy
    Time-stamp:  <2020-06-22T03:40:26Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: Logics_ZF (of Isabelle2020)
*)

theory Poset imports ZF FinCard begin

definition poset :: "[[i,i]=>o, i]=>o" where
"poset(R, P) == (ALL x: P. R(x, x)) &
  (ALL x: P. ALL y: P. R(x, y) & R(y, x) --> x = y) &
  (ALL x: P. ALL y: P. ALL z: P. R(x, y) & R(y, z) --> R(x, z))"

definition chain :: "[[i,i]=>o, i]=>o" where
"chain(R, P) == poset(R, P)
   & (ALL x: P. ALL y: P. R(x, y) | R(y, x))"

definition invrel :: "[[i, i]=>o, i, i]=>o" where
"invrel(R, x, y) == R(y, x)"

definition least :: "[[i,i]=>o, i, i]=>o" where
"least(R, P, x) == x: P & (ALL y: P. R(x, y))"

definition greatest :: "[[i,i]=>o, i, i]=>o" where
"greatest(R, P, x) == x: P & (ALL y: P. R(y, x))"

definition minimal :: "[[i, i]=>o, i, i]=>o" where
"minimal(R, P, x) == x: P & (ALL y: P. R(y, x) --> y = x)"

definition maximal :: "[[i, i]=>o, i, i]=>o" where
"maximal(R, P, x) == x: P & (ALL y: P. R(x, y) --> y = x)"

definition downset :: "[[i, i]=>o, i, i]=>i" where
"downset(R, P, x) == {y: P. R(y, x)}"

definition upset :: "[[i, i]=>o, i, i]=>i" where
"upset(R, P, x) == {y: P. R(x, y)}"

definition upperbound :: "[[i, i]=>o, i, i]=>i" where
"upperbound(R, P, S) == {x: P. ALL y: S. R(y, x)}"

definition lowerbound :: "[[i, i]=>o, i, i]=>i" where
"lowerbound(R, P, S) == {x: P. ALL y: S. R(x, y)}"

(** poset **)
lemma posetI:
  "[| !!x. x: P ==> R(x, x);
      !!x y. [| x: P; y: P; R(x, y); R(y, x) |] ==> x = y;
      !!x y z. [| x: P; y: P; z: P; R(x, y); R(y, z) |] ==> R(x, z)
   |] ==> poset(R, P)"
apply (unfold poset_def)
apply blast
done

lemma poset_reflD:
  "[| poset(R, P); x: P |] ==> R(x, x)"
apply (unfold poset_def)
apply blast
done

lemma poset_antisymD:
  "[| poset(R, P); R(x, y); R(y, x); x: P; y: P |] ==> x = y"
apply (unfold poset_def)
apply blast
done

lemma poset_transD:
  "[| poset(R, P); R(x, y); R(y, z); x: P; y: P; z: P |] ==> R(x, z)"
apply (unfold poset_def)
apply blast
done

lemma poset_subset:
  "[| S <= P; poset(R, P) |] ==> poset(R, S)"
apply (rule posetI)
apply (drule subsetD, assumption)
apply (erule poset_reflD, assumption)
apply (erule poset_antisymD, assumption+)
apply (erule subsetD, assumption)+
apply (erule poset_transD, assumption+)
apply (erule subsetD, assumption)+
done

lemma poset_invrel_iff:
  "poset(invrel(R), P) <-> poset(R, P)"
apply (unfold poset_def invrel_def)
apply blast
done

(** chain **)
lemma chainI:
  "[| poset(R, P); !!x y. [| x: P; y: P |] ==> R(x, y) | R(y, x) |]
      ==> chain(R, P)"
apply (unfold chain_def)
apply blast
done

lemma chain_imp_poset:
    "chain(R, P) ==> poset(R, P)"
apply (unfold chain_def)
apply blast
done

lemmas chainD1 = chain_imp_poset

lemma chainD2:
  "[| chain(R, P); x: P; y: P |] ==> R(x, y) | R(y, x)"
apply (unfold chain_def)
apply blast
done

lemma chain_subset:
    "[| S <= P; chain(R, P) |] ==> chain(R, S)"
apply (blast intro: chainI poset_subset dest: chainD1 chainD2)
done

lemma chain_invrel_iff:
  "chain(invrel(R), P) <-> chain(R, P)"
apply (unfold chain_def)
apply (simp add: poset_invrel_iff)
apply (unfold invrel_def)
apply blast
done

(** least/greatest **)
lemma leastI:
  "[| !!y. y: P ==> R(x, y); x: P |] ==> least(R, P, x)"
apply (unfold least_def)
apply blast
done

lemma leastD1:
  "least(R, P, x) ==> x: P"
apply (unfold least_def)
apply blast
done

lemma leastD2:
  "[| least(R, P, x); y: P |] ==> R(x, y)"
apply (unfold least_def)
apply blast
done

lemma least_unique:
  "[| least(R, P, x); least(R, P, y); poset(R, P) |] ==> x = y"
apply (erule poset_antisymD)
apply (erule leastD2, erule leastD1)
apply (erule leastD2, erule leastD1)
apply (erule leastD1)
apply (erule leastD1)
done

lemma least_subset:
  "[| S <= P; least(R, P, x); x: S |] ==> least(R, S, x)"
apply (rule leastI)
apply (drule subsetD)
apply (drule_tac [2] leastD2)
by assumption+

lemma Finite_non_empty_chain_has_least_element:
  assumes major: "Finite(P)"
  and prem1: "chain(R, P)"
  and prem2: "P ~= 0"
  shows "EX x. least(R, P, x)"
apply (rule prem2 [THEN rev_mp])
apply (rule prem1 [THEN rev_mp])
apply (rule major [THEN Finite_into_Fin, THEN Fin_induct])
apply blast
apply (intro impI)
apply (case_tac "y = 0")
apply hypsubst
apply (rule exI)
apply (rule leastI)
apply (rule_tac [2] singletonI)
apply (erule singletonE)
apply hypsubst
apply (erule chain_imp_poset [THEN poset_reflD])
apply (rule singletonI)
apply (drule mp [THEN mp])
apply (rule chain_subset)
apply (rule subset_consI)
apply assumption+
apply (erule exE)
apply (frule chainD2)
apply (rule consI1)
apply (rule consI2)
apply (erule leastD1)
apply (erule disjE)
apply (rename_tac [2] v)
apply (rule_tac x="x" in exI)
apply (rule_tac [2] x="v" in exI)
apply (rule_tac [2] leastI)
apply (rule leastI)
apply (rule_tac [4] consI2)
apply safe
apply (erule chain_imp_poset [THEN poset_reflD])
apply (erule_tac [2] chain_imp_poset [THEN poset_transD])
prefer 2 apply assumption
apply (rule_tac [4] consI2)
apply (erule_tac [5] consI2)
apply (erule_tac [2] leastD2)
apply (erule_tac [5] leastD2)
apply (assumption | (rule consI1 leastD1))+
done

lemma least_invrel_iff:
    "least(invrel(R), P, x) <-> greatest(R, P, x)"
apply (unfold least_def greatest_def invrel_def)
apply (rule iff_refl)
done

lemma greatest_invrel_iff:
    "greatest(invrel(R), P, x) <-> least(R, P, x)"
apply (unfold least_def greatest_def invrel_def)
apply (rule iff_refl)
done

(** minimal/maximal **)
lemma minimalI:
  "[| !!y. [| y: P;  R(y, x) |] ==> y = x; x: P |] ==> minimal(R, P, x)"
apply (unfold minimal_def)
apply blast
done

lemma minimalD1:
  "minimal(R, P, x) ==> x: P"
apply (unfold minimal_def)
apply blast
done

lemma minimalD2:
  "[| minimal(R, P, x); R(y, x); y: P |] ==> y = x"
apply (unfold minimal_def)
apply blast
done

lemma minimal_subset:
  "[| S <= P; minimal(R, P, x); x: S |] ==> minimal(R, S, x)"
apply (rule minimalI)
apply (erule minimalD2)
apply assumption
apply (erule subsetD)
apply assumption+
done

lemma least_imp_minimal:
  "[| least(R, P, x); poset(R, P) |] ==> minimal(R, P, x)"
apply (rule minimalI)
apply (erule poset_antisymD)
apply (erule_tac [2] leastD2)
apply (assumption | (erule leastD1))+
done

lemma chain_minimal_imp_least:
  "[| minimal(R, P, x); chain(R, P) |] ==> least(R, P, x)"
apply (rule leastI)
apply (rule chainD2 [THEN disjE])
apply assumption
apply (erule minimalD1)
apply assumption+
apply (drule minimalD2)
apply assumption+
apply hypsubst
apply (erule chainD1 [THEN poset_reflD], assumption)
apply (erule minimalD1)
done

lemma minimal_invrel_iff:
    "minimal(invrel(R), P, x) <-> maximal(R, P, x)"
apply (unfold minimal_def maximal_def invrel_def)
apply (rule iff_refl)
done

lemma maximal_invrel_iff:
    "maximal(invrel(R), P, x) <-> minimal(R, P, x)"
apply (unfold minimal_def maximal_def invrel_def)
apply (rule iff_refl)
done

(** upset/downset **)
lemma upsetI:
  "[| y: P; R(x, y) |] ==> y: upset(R, P, x)"
apply (unfold upset_def)
apply blast
done

lemma upsetE:
  "[| y: upset(R, P, x); [| y: P; R(x, y) |] ==> Q |] ==> Q"
apply (unfold upset_def)
apply blast
done

lemma upset_subset:
    "upset(R, P, x) <= P"
apply (blast elim!: upsetE)
done

lemma least_upset:
  "[| poset(R, P); x: P |] ==> least(R, upset(R, P, x), x)"
apply (rule leastI)
apply (erule upsetE)
apply (assumption | (rule upsetI) | (erule poset_reflD))+
done

lemma upset_invrel_eq:
    "upset(invrel(R), P, x) = downset(R, P, x)"
apply (unfold downset_def upset_def invrel_def)
apply (rule refl)
done

lemma downset_invrel_eq:
    "downset(invrel(R), P, x) = upset(R, P, x)"
apply (unfold downset_def upset_def invrel_def)
apply (rule refl)
done

(** upperbound/lowerbound **)
lemma upperboundI:
  "[| x: P; !!y. y: S ==> R(y, x) |] ==> x: upperbound(R, P, S)"
apply (unfold upperbound_def)
apply blast
done

lemma upperboundE:
  "[| x: upperbound(R, P, S); [| x: P; ALL y: S. R(y, x) |] ==> Q |] ==> Q"
apply (unfold upperbound_def)
apply blast
done

lemma upperbound_invrel_eq:
    "upperbound(invrel(R), P, S) = lowerbound(R, P, S)"
apply (unfold lowerbound_def upperbound_def invrel_def)
apply (rule refl)
done

lemma lowerbound_invrel_eq:
    "lowerbound(invrel(R), P, S) = upperbound(R, P, S)"
apply (unfold lowerbound_def upperbound_def invrel_def)
apply (rule refl)
done

(** Prove symmetric theorems **)
lemma greatestI:
  "[| !!y. y: P ==> R(y, x); x: P |] ==> greatest(R, P, x)"
apply (unfold greatest_def)
apply blast
done

lemma greatestD1:
  "greatest(R, P, x) ==> x: P"
apply (unfold greatest_def)
apply blast
done

lemma greatestD2:
  "[| greatest(R, P, x); y: P |] ==> R(y, x)"
apply (unfold greatest_def)
apply blast
done

lemma greatest_unique:
  "[| greatest(R, P, x); greatest(R, P, y); poset(R, P) |] ==> x = y"
apply (simp only: least_invrel_iff [THEN iff_sym])
apply (subst (asm) poset_invrel_iff [THEN iff_sym])
apply (erule least_unique)
apply assumption+
done

lemma greatest_subset:
  "[| S <= P; greatest(R, P, x); x: S |] ==> greatest(R, S, x)"
apply (rule greatestI)
apply (drule subsetD)
apply (drule_tac [2] greatestD2)
by assumption+

lemma Finite_non_empty_chain_has_greatest_element:
  assumes major: "Finite(P)"
  and prem1: "chain(R, P)"
  and prem2: "P ~= 0"
  shows "EX x. greatest(R, P, x)"
apply (insert major prem1 prem2)
apply (simp only: least_invrel_iff [THEN iff_sym])
apply (subst (asm) chain_invrel_iff [THEN iff_sym])
apply (rule Finite_non_empty_chain_has_least_element)
apply assumption+
done

lemma maximalI:
  "[| !!y. [| y: P;  R(x, y) |] ==> y = x; x: P |] ==> maximal(R, P, x)"
apply (unfold maximal_def)
apply blast
done

lemma maximalD1:
  "maximal(R, P, x) ==> x: P"
apply (unfold maximal_def)
apply blast
done

lemma maximalD2:
  "[| maximal(R, P, x); R(x, y); y: P |] ==> y = x"
apply (unfold maximal_def)
apply blast
done

lemma maximal_subset:
  "[| S <= P; maximal(R, P, x); x: S |] ==> maximal(R, S, x)"
apply (rule maximalI)
apply (erule maximalD2)
apply assumption
apply (erule subsetD)
apply assumption+
done

lemma greatest_imp_maximal:
  "[| greatest(R, P, x); poset(R, P) |] ==> maximal(R, P, x)"
apply (rule maximalI)
apply (erule poset_antisymD)
apply (erule_tac [1] greatestD2)
apply (assumption | (erule greatestD1))+
done

lemma chain_maximal_imp_greatest:
  "[| maximal(R, P, x); chain(R, P) |] ==> greatest(R, P, x)"
apply (simp only: least_invrel_iff [THEN iff_sym])
apply (simp only: minimal_invrel_iff [THEN iff_sym])
apply (subst (asm) chain_invrel_iff [THEN iff_sym])
apply (rule chain_minimal_imp_least)
apply assumption+
done

lemma downsetI:
  "[| y: P; R(y, x) |] ==> y: downset(R, P, x)"
apply (unfold downset_def)
apply blast
done

lemma downsetE:
  "[| y: downset(R, P, x); [| y: P; R(y, x) |] ==> Q |] ==> Q"
apply (unfold downset_def)
apply blast
done

lemma downset_subset:
    "downset(R, P, x) <= P"
apply (blast elim!: downsetE)
done

lemma greatest_downset:
  "[| poset(R, P); x: P |] ==> greatest(R, downset(R, P, x), x)"
apply (rule greatestI)
apply (erule downsetE)
apply (assumption | (rule downsetI) | (erule poset_reflD))+
done

lemma lowerboundI:
  "[| x: P; !!y. y: S ==> R(x, y) |] ==> x: lowerbound(R, P, S)"
apply (unfold lowerbound_def)
apply blast
done

lemma lowerboundE:
  "[| x: lowerbound(R, P, S); [| x: P; ALL y: S. R(x, y) |] ==> Q |] ==> Q"
apply (unfold lowerbound_def)
apply blast
done

end