(*
  Authors: Asta Halkjær From, Agnes Moesgård Eschen & Jørgen Villadsen, DTU Compute
*)

theory CICM imports Main begin

section \<open>Syntax / Semantics\<close>

datatype form = Pro nat (\<open>\<cdot>\<close>) | Neg form (\<open>\<sim>\<close>) | Imp form form (infix \<open>\<rightarrow>\<close> 0)

primrec semantics (infix \<open>\<Turnstile>\<close> 0) where
  \<open>(I \<Turnstile> \<cdot> n) = I n\<close> |
  \<open>(I \<Turnstile> \<sim> p) = (\<not> (I \<Turnstile> p))\<close> |
  \<open>(I \<Turnstile> (p \<rightarrow> q)) = ((I \<Turnstile> p) \<longrightarrow> (I \<Turnstile> q))\<close>

section \<open>System L1 from Jan Lukasiewicz: Elements of Mathematical Logic (English Tr. 1963)\<close>

inductive Axiomatics (\<open>\<turnstile>\<close>) where
  \<open>\<turnstile> q\<close> if \<open>\<turnstile> p\<close> and \<open>\<turnstile> (p \<rightarrow> q)\<close> |
  \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> (p \<rightarrow> r)))\<close> |
  \<open>\<turnstile> ((\<sim> p \<rightarrow> p) \<rightarrow> p)\<close> |
  \<open>\<turnstile> (p \<rightarrow> (\<sim> p \<rightarrow> q))\<close>

section \<open>Soundness\<close>

theorem L1_soundness: \<open>\<forall>I. (I \<Turnstile> p)\<close> if \<open>\<turnstile> p\<close>
  using that by induct simp_all

section \<open>Preliminaries\<close>

abbreviation Truth (\<open>\<top>\<close>) where \<open>\<top> \<equiv> (undefined \<rightarrow> undefined)\<close>

abbreviation Falsity (\<open>\<bottom>\<close>) where \<open>\<bottom> \<equiv> \<sim> \<top>\<close>

lemma simps:
  \<open>(I \<Turnstile> \<sim> p) = (if I \<Turnstile> p then False else True)\<close>
  \<open>(I \<Turnstile> (p \<rightarrow> q)) = (if I \<Turnstile> p then (I \<Turnstile> q) else True)\<close>
  by simp_all

lemmas MP = Axiomatics.intros(1)

lemmas Trans = Axiomatics.intros(2)

lemmas Clav = Axiomatics.intros(3)

lemmas Expl = Axiomatics.intros(4)

section \<open>Derived Rules\<close>

lemma thes04: \<open>\<turnstile> ((((q \<rightarrow> r) \<rightarrow> (p \<rightarrow> r)) \<rightarrow> s) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> s))\<close>
  using MP Trans by metis

lemma thes05: \<open>\<turnstile> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> ((s \<rightarrow> q) \<rightarrow> (p \<rightarrow> (s \<rightarrow> r))))\<close>
  using MP thes04 by metis

lemma thes06: \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> (((p \<rightarrow> r) \<rightarrow> s) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> s)))\<close>
  using MP Trans thes04 by metis

lemma thes07: \<open>\<turnstile> ((t \<rightarrow> ((p \<rightarrow> r) \<rightarrow> s)) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (t \<rightarrow> ((q \<rightarrow> r) \<rightarrow> s))))\<close>
  using MP thes05 thes06 by metis

lemma thes09: \<open>\<turnstile> (((\<sim> p \<rightarrow> q) \<rightarrow> r) \<rightarrow> (p \<rightarrow> r))\<close>
  using MP Trans Expl by metis

lemma thes10: \<open>\<turnstile> (p \<rightarrow> (((\<sim> p \<rightarrow> p) \<rightarrow> p) \<rightarrow> ((q \<rightarrow> p) \<rightarrow> p)))\<close>
  using MP thes06 thes09 by metis

lemma thes11: \<open>\<turnstile> ((q \<rightarrow> ((\<sim> p \<rightarrow> p) \<rightarrow> p)) \<rightarrow> ((\<sim> p \<rightarrow> p) \<rightarrow> p))\<close>
  using MP Clav thes10 by metis

lemma thes12: \<open>\<turnstile> (t \<rightarrow> ((\<sim> p \<rightarrow> p) \<rightarrow> p))\<close>
  using MP thes09 thes11 by metis

lemma thes13: \<open>\<turnstile> ((\<sim> p \<rightarrow> q) \<rightarrow> (t \<rightarrow> ((q \<rightarrow> p) \<rightarrow> p)))\<close>
  using MP thes07 thes12 by metis

lemma thes14: \<open>\<turnstile> (((t \<rightarrow> ((q \<rightarrow> p) \<rightarrow> p)) \<rightarrow> r) \<rightarrow> ((\<sim> p \<rightarrow> q) \<rightarrow> r))\<close>
  using MP Trans thes13 by metis

lemma thes15: \<open>\<turnstile> ((\<sim> p \<rightarrow> q) \<rightarrow> ((q \<rightarrow> p) \<rightarrow> p))\<close>
  using MP Clav thes14 by metis

lemma thes16: \<open>\<turnstile> (p \<rightarrow> p)\<close>
  using MP thes09 Clav by metis

lemma thes17: \<open>\<turnstile> (p \<rightarrow> ((q \<rightarrow> p) \<rightarrow> p))\<close>
  using MP thes09 thes15 by metis

lemma thes18: \<open>\<turnstile> (q \<rightarrow> (p \<rightarrow> q))\<close>
  using MP Expl thes05 thes17 by metis

lemma thes19: \<open>\<turnstile> (((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> (q \<rightarrow> r))\<close>
  using MP Trans thes18 by metis

lemma thes20: \<open>\<turnstile> (p \<rightarrow> ((p \<rightarrow> q) \<rightarrow> q))\<close>
  using MP thes15 thes19 by metis

lemma thes21: \<open>\<turnstile> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> (q \<rightarrow> (p \<rightarrow> r)))\<close>
  using MP thes05 thes20 by metis

lemma thes22: \<open>\<turnstile> ((q \<rightarrow> r) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)))\<close>
  using MP Trans thes21 by metis

lemma thes23: \<open>\<turnstile> (((q \<rightarrow> (p \<rightarrow> r)) \<rightarrow> s) \<rightarrow> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> s))\<close>
  using MP Trans thes21 by metis

lemma thes24: \<open>\<turnstile> ((((p \<rightarrow> q) \<rightarrow> p) \<rightarrow> p))\<close>
  using MP Expl thes15 thes23 by metis

lemma thes25: \<open>\<turnstile> (((p \<rightarrow> r) \<rightarrow> s) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> s)))\<close>
  using MP thes06 thes21 by metis

lemma thes26: \<open>\<turnstile> (((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> ((r \<rightarrow> p) \<rightarrow> p))\<close>
  using MP thes24 thes25 by metis

lemma thes28: \<open>\<turnstile> ((((r \<rightarrow> p) \<rightarrow> p) \<rightarrow> s) \<rightarrow> (((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> s))\<close>
  using MP Trans thes26 by metis

lemma thes29: \<open>\<turnstile> (((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> ((p \<rightarrow> r) \<rightarrow> r))\<close>
  using MP thes26 thes28 by metis

lemma thes31: \<open>\<turnstile> ((p \<rightarrow> s) \<rightarrow> (((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> ((s \<rightarrow> r) \<rightarrow> r)))\<close>
  using MP thes07 thes29 by metis

lemma thes32: \<open>\<turnstile> (((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> ((p \<rightarrow> s) \<rightarrow> ((s \<rightarrow> r) \<rightarrow> r)))\<close>
  using MP thes21 thes31 by metis

lemma thes33: \<open>\<turnstile> ((p \<rightarrow> s) \<rightarrow> ((s \<rightarrow> (q \<rightarrow> (p \<rightarrow> r))) \<rightarrow> (q \<rightarrow> (p \<rightarrow> r))))\<close>
  using MP thes18 thes32 by metis

lemma thes34: \<open>\<turnstile> ((s \<rightarrow> (q \<rightarrow> (p \<rightarrow> r))) \<rightarrow> ((p \<rightarrow> s) \<rightarrow> (q \<rightarrow> (p \<rightarrow> r))))\<close>
  using MP thes21 thes33 by metis

lemma thes35: \<open>\<turnstile> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)))\<close>
  using MP thes22 thes34 by metis

lemma thes36: \<open>\<turnstile> (\<sim> p \<rightarrow> (p \<rightarrow> q))\<close>
  using MP Expl thes21 by metis

lemma thes37: \<open>\<turnstile> (((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> (\<sim> p \<rightarrow> r))\<close>
  using MP Trans thes36 by metis

lemma thes39: \<open>\<turnstile> (\<sim> (\<sim> p) \<rightarrow> p)\<close>
  using MP Clav thes37 by metis

lemma thes41: \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> (\<sim> (\<sim> p) \<rightarrow> q))\<close>
  using MP Trans thes39 by metis

lemma thes42: \<open>\<turnstile> (((\<sim> (\<sim> p) \<rightarrow> q) \<rightarrow> r) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> r))\<close>
  using MP Trans thes41 by metis

lemma thes43: \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> ((q \<rightarrow> \<sim> p) \<rightarrow> \<sim> p))\<close>
  using MP thes15 thes42 by metis

lemma thes44: \<open>\<turnstile> ((s \<rightarrow> (q \<rightarrow> \<sim> p)) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (s \<rightarrow> \<sim> p)))\<close>
  using MP thes05 thes43 by metis

lemma thes45: \<open>\<turnstile> ((s \<rightarrow> (q \<rightarrow> p)) \<rightarrow> ((\<sim> p \<rightarrow> q) \<rightarrow> (s \<rightarrow> p)))\<close>
  using MP thes05 thes15 by metis

lemma thes46: \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> (\<sim> q \<rightarrow> \<sim> p))\<close>
  using MP thes36 thes44 by metis

lemma thes47: \<open>\<turnstile> ((p \<rightarrow> \<sim> q) \<rightarrow> (q \<rightarrow> \<sim> p))\<close>
  using MP Expl thes44 by metis

lemma thes48: \<open>\<turnstile> ((\<sim> p \<rightarrow> q) \<rightarrow> (\<sim> q \<rightarrow> p))\<close>
  using MP thes36 thes45 by metis

lemma thes66: \<open>\<turnstile> (\<sim> (p \<rightarrow> q) \<rightarrow> p)\<close>
  using MP thes36 thes48 by metis

lemma thes67: \<open>\<turnstile> (\<sim> (p \<rightarrow> q) \<rightarrow> \<sim> q)\<close>
  using MP thes18 thes46 by metis

lemma \<sim>: \<open>\<turnstile> ((p \<rightarrow> \<bottom>) \<rightarrow> \<sim> p)\<close>
  using MP thes21 thes16 thes47 by metis

primrec imply :: \<open>form list \<Rightarrow> form \<Rightarrow> form\<close> where
  \<open>imply [] q = q\<close>
| \<open>imply (p # ps) q = (p \<rightarrow> imply ps q)\<close>

lemma imply_head: \<open>\<turnstile> (imply (p # ps) p)\<close>
  by (induct ps) (simp add: thes16, metis MP Trans thes18 imply.simps(2))

lemma imply_Cons: \<open>\<turnstile> (imply ps q) \<Longrightarrow> \<turnstile> (imply (p # ps) q)\<close>
  using MP thes18 imply.simps(2) by metis

lemma imply_mem: \<open>p \<in> set ps \<Longrightarrow> \<turnstile> (imply ps p)\<close>
  using imply_head imply_Cons by (induct ps) auto

lemma imply_MP: \<open>\<turnstile> (imply ps p \<rightarrow> (imply ps (p \<rightarrow> q) \<rightarrow> imply ps q))\<close>
  using imply.simps by (induct ps) (metis thes20, metis MP Trans thes35 thes21)

lemma imply_mp': \<open>\<turnstile> (imply ps p) \<Longrightarrow> \<turnstile> (imply ps (p \<rightarrow> q)) \<Longrightarrow> \<turnstile> (imply ps q)\<close>
  using imply_MP by (meson MP)

lemma add_imply: \<open>\<turnstile> q \<Longrightarrow> \<turnstile> (imply ps q)\<close>
  using imply_Cons by (induct ps) simp_all

lemma imply_append: \<open>imply (ps @ qs) r = imply ps (imply qs r)\<close>
  by (induct ps) simp_all

lemma imply_swap: \<open>\<turnstile> (imply (ps @ qs) r) \<Longrightarrow> \<turnstile> (imply (qs @ ps) r)\<close>
proof (induct qs arbitrary: ps)
  case (Cons q qs)
  then show ?case
    by (metis imply_Cons imply_head imply_mp' imply.simps(2) imply_append)
qed simp

lemma deduct: \<open>\<turnstile> (imply (p # ps) q) \<longleftrightarrow> \<turnstile> (imply ps (p \<rightarrow> q))\<close>
  using imply_swap by (metis imply.simps(1-2) imply_append)

theorem imply_weaken: \<open>\<turnstile> (imply ps q) \<Longrightarrow> set ps \<subseteq> set ps' \<Longrightarrow> \<turnstile> (imply ps' q)\<close>
proof (induct ps arbitrary: q)
  case (Cons p ps)
  note \<open>\<turnstile> (imply (p # ps) q)\<close>
  then have \<open>\<turnstile> (imply ps (p \<rightarrow> q))\<close>
    using deduct by blast
  then have \<open>\<turnstile> (imply ps' (p \<rightarrow> q))\<close>
    using Cons by simp
  then show ?case
    using Cons(3) by (meson imply_mem imply_mp' list.set_intros(1) subset_code(1))
qed (simp add: add_imply)

lemma cut: \<open>\<turnstile> (imply ps p) \<Longrightarrow> \<turnstile> (imply (p # ps) q) \<Longrightarrow> \<turnstile> (imply ps q)\<close>
  using deduct imply_mp' by blast

lemma imply4: \<open>\<turnstile> (imply (p # q # ps) r) \<Longrightarrow> \<turnstile> (imply (q # p # ps) r)\<close>
  by (metis thes21 MP imply.simps(2))

lemma cut': \<open>\<turnstile> (imply (p # ps) r) \<Longrightarrow> \<turnstile> (imply (q # ps) p) \<Longrightarrow> \<turnstile> (imply (q # ps) r)\<close>
  using imply_Cons cut imply4 by blast

lemma imply_lift: \<open>\<turnstile> (p \<rightarrow> q) \<Longrightarrow> \<turnstile> (imply ps p \<rightarrow> imply ps q)\<close>
  by (metis thes16 add_imply imply.simps(2) imply_mp')

lemma imply_DNeg: \<open>\<turnstile> (imply ps (\<sim> (\<sim> p)) \<rightarrow> imply ps p)\<close>
  using thes39 imply_lift by simp

lemma Boole: \<open>\<turnstile> (imply (\<sim> p # ps) \<bottom>) \<Longrightarrow> \<turnstile> (imply ps p)\<close>
  by (meson \<sim> MP imply_DNeg deduct imply_lift)

lemma imply_front: \<open>\<turnstile> (imply S p) \<Longrightarrow> set S - {q} \<subseteq> set S' \<Longrightarrow> \<turnstile> (imply (q # S') p)\<close>
  by (metis Diff_single_insert imply_weaken list.set(2))

section \<open>Consistent\<close>

definition consistent :: \<open>form set \<Rightarrow> bool\<close> where
  \<open>consistent S \<equiv> \<nexists>S'. set S' \<subseteq> S \<and> \<turnstile> (imply S' \<bottom>)\<close>

lemma UN_finite_bound:
  assumes \<open>finite p\<close> \<open>p \<subseteq> (\<Union>n. f n)\<close>
  shows \<open>\<exists>m :: nat. p \<subseteq> (\<Union>n \<le> m. f n)\<close>
  using assms
proof (induct rule: finite_induct)
  case (insert x p)
  then obtain m where \<open>p \<subseteq> (\<Union>n \<le> m. f n)\<close>
    by fast
  then have \<open>p \<subseteq> (\<Union>n \<le> (m + k). f n)\<close> for k
    by fastforce
  moreover obtain m' where \<open>x \<in> f m'\<close>
    using insert(4) by blast
  ultimately have \<open>{x} \<union> p \<subseteq> (\<Union>n \<le> m + m'. f n)\<close>
    by auto
  then show ?case
    by blast
qed simp

section \<open>Extension\<close>

primrec extend :: \<open>form set \<Rightarrow> (nat \<Rightarrow> form) \<Rightarrow> nat \<Rightarrow> form set\<close> where
  \<open>extend S f 0 = S\<close>
| \<open>extend S f (Suc n) =
    (if consistent ({f n} \<union> extend S f n)
     then {f n} \<union> extend S f n
     else extend S f n)\<close>

definition Extend :: \<open>form set \<Rightarrow> (nat \<Rightarrow> form) \<Rightarrow> form set\<close> where
  \<open>Extend S f \<equiv> \<Union>n. extend S f n\<close>

lemma Extend_subset: \<open>S \<subseteq> Extend S f\<close>
  unfolding Extend_def by (metis Union_upper extend.simps(1) range_eqI)

lemma extend_bound: \<open>(\<Union>n \<le> m. extend S f n) = extend S f m\<close>
  by (induct m) (simp_all add: atMost_Suc)

lemma consistent_extend: \<open>consistent S \<Longrightarrow> consistent (extend S f n)\<close>
  by (induct n) simp_all

lemma consistent_Extend:
  assumes \<open>consistent S\<close>
  shows \<open>consistent (Extend S f)\<close>
  unfolding Extend_def
proof (rule ccontr)
  assume \<open>\<not> consistent (\<Union>n. extend S f n)\<close>
  then obtain S' where \<open>\<turnstile> (imply S' \<bottom>)\<close> \<open>set S' \<subseteq> (\<Union>n. extend S f n)\<close>
    unfolding consistent_def by blast
  then obtain m where \<open>set S' \<subseteq> (\<Union>n \<le> m. extend S f n)\<close>
    using UN_finite_bound by (metis List.finite_set)
  then have \<open>set S' \<subseteq> extend S f m\<close>
    using extend_bound by blast
  moreover have \<open>consistent (extend S f m)\<close>
    using assms consistent_extend by blast
  ultimately show False
    unfolding consistent_def using \<open>\<turnstile> (imply S' \<bottom>)\<close> by blast
qed

section \<open>Maximal\<close>

definition maximal :: \<open>form set \<Rightarrow> bool\<close> where
  \<open>maximal S \<equiv> \<forall>p. p \<notin> S \<longrightarrow> \<not> consistent ({p} \<union> S)\<close>

lemma maximal_Extend:
  assumes \<open>surj f\<close>
  shows \<open>maximal (Extend S f)\<close>
proof (rule ccontr)
  assume \<open>\<not> maximal (Extend S f)\<close>
  then obtain p where \<open>p \<notin> Extend S f\<close> \<open>consistent ({p} \<union> Extend S f)\<close>
    unfolding maximal_def using assms consistent_Extend by blast
  obtain k where n: \<open>f k = p\<close>
    using \<open>surj f\<close> unfolding surj_def by metis
  then have \<open>p \<notin> extend S f (Suc k)\<close>
    using \<open>p \<notin> Extend S f\<close> unfolding Extend_def by blast
  then have \<open>\<not> consistent ({p} \<union> extend S f k)\<close>
    using n by fastforce
  moreover have \<open>{p} \<union> extend S f k \<subseteq> {p} \<union> Extend S f\<close>
    unfolding Extend_def by blast
  ultimately have \<open>\<not> consistent ({p} \<union> Extend S f)\<close>
    unfolding consistent_def by fastforce
  then show False
    using \<open>consistent ({p} \<union> Extend S f)\<close> by blast
qed

section \<open>Hintikka\<close>

locale Hintikka =
  fixes H :: \<open>form set\<close>
  assumes
    NoFalsity: \<open>\<bottom> \<notin> H\<close> and
    ProP: \<open>\<cdot> n \<in> H \<Longrightarrow> \<sim> (\<cdot> n) \<notin> H\<close> and
    ImpP: \<open>(p \<rightarrow> q) \<in> H \<Longrightarrow> \<sim> p \<in> H \<or> q \<in> H\<close> and
    ImpN: \<open>\<sim> (p \<rightarrow> q) \<in> H \<Longrightarrow> p \<in> H \<and> \<sim> q \<in> H\<close> and
    NegN: \<open>\<sim> (\<sim> p) \<in> H \<Longrightarrow> p \<in> H\<close>

abbreviation (input) \<open>model H n \<equiv> \<cdot> n \<in> H\<close>

lemma Hintikka_model:
  \<open>Hintikka H \<Longrightarrow> (p \<in> H \<longrightarrow> (model H \<Turnstile> p)) \<and> (\<sim> p \<in> H \<longrightarrow> \<not> (model H \<Turnstile> p))\<close>
  by (induct p) (simp; unfold Hintikka_def, blast)+

lemma inconsistent_head:
  assumes \<open>maximal S\<close> \<open>consistent S\<close> \<open>p \<notin> S\<close>
  shows \<open>\<exists>S'. \<turnstile> (imply (p # S') \<bottom>) \<and> set S' \<subseteq> S\<close>
proof -
  obtain S' where S': \<open>\<turnstile> (imply S' \<bottom>)\<close> \<open>set S' \<subseteq> {p} \<union> S\<close> \<open>p \<in> set S'\<close>
    using assms unfolding maximal_def consistent_def by fast
  then obtain S'' where S'': \<open>\<turnstile> (imply (p # S'') \<bottom>)\<close> \<open>set S'' = set S' - {p}\<close>
    by (metis imply_front set_removeAll subset_refl)
  then show ?thesis
    using S'(2) by fast
qed

lemma Hintikka_Extend:
  assumes \<open>maximal S\<close> \<open>consistent S\<close>
  shows \<open>Hintikka S\<close>
proof
  show \<open>\<bottom> \<notin> S\<close>
    using assms(2) imply_head imply_mem unfolding consistent_def
    by (metis List.set_insert empty_set insert_Diff insert_is_Un singletonI sup.cobounded1)
next
  fix n
  assume \<open>\<cdot> n \<in> S\<close>
  moreover have \<open>\<turnstile> (imply [\<cdot> n, \<sim> (\<cdot> n)] \<bottom>)\<close>
    by (simp add: Expl)
  ultimately show \<open>\<sim> (\<cdot> n) \<notin> S\<close>
    using assms(2) unfolding consistent_def
    by (metis bot.extremum empty_set insert_subset list.set(2))
next
  fix p q
  assume *: \<open>(p \<rightarrow> q) \<in> S\<close>
  show \<open>\<sim> p \<in> S \<or> q \<in> S\<close>
  proof (rule disjCI, rule ccontr)
    assume **: \<open>q \<notin> S\<close>
    then obtain Sq' where Sq': \<open>\<turnstile> (imply (q # Sq') \<bottom>)\<close> \<open>set Sq' \<subseteq> S\<close>
      using assms inconsistent_head by blast
    assume \<open>(\<sim> p) \<notin> S\<close>
    then obtain Sp' where Sp': \<open>\<turnstile> (imply (\<sim> p # Sp') \<bottom>)\<close> \<open>set Sp' \<subseteq> S\<close>
      using assms inconsistent_head by blast

    obtain S' where S': \<open>set S' = set Sp' \<union> set Sq'\<close>
      by (meson set_append)
    then have \<open>\<turnstile> (imply (\<sim> p # S') \<bottom>)\<close> \<open>\<turnstile> (imply (q # S') \<bottom>)\<close>
    proof -
      have \<open>set Sp' \<subseteq> set S'\<close>
        using S' by blast
      then show \<open>\<turnstile> (imply (\<sim> p # S') \<bottom>)\<close>
        by (metis Sp'(1) deduct imply_weaken)
      have \<open>set Sq' \<subseteq> set S'\<close>
        using S' by blast
      then show \<open>\<turnstile> (imply (q # S') \<bottom>)\<close>
        using ** by (metis Sq'(1) deduct imply_weaken)
    qed
    then have \<open>\<turnstile> (imply ((p \<rightarrow> q) # S') \<bottom>)\<close>
      using Boole imply_Cons imply_head imply_mp' cut' by metis
    moreover have \<open>set ((p \<rightarrow> q) # S') \<subseteq> S\<close> if \<open>q \<notin> S\<close>
      using that *(1) S' Sp'(2) Sq'(2) by auto
    ultimately show False
      using ** assms unfolding consistent_def by blast
  qed
next
  fix p q
  assume *: \<open>\<sim> (p \<rightarrow> q) \<in> S\<close>
  show \<open>p \<in> S \<and> \<sim> q \<in> S\<close>
  proof (rule conjI; rule ccontr)
    assume \<open>p \<notin> S\<close>
    then obtain S' where S': \<open>\<turnstile> (imply (p # S') \<bottom>)\<close> \<open>set S' \<subseteq> S\<close>
      using assms inconsistent_head by blast
    moreover have \<open>\<turnstile> (imply (\<sim> (p \<rightarrow> q) # S') p)\<close>
      using add_imply thes66 deduct by blast
    ultimately have \<open>\<turnstile> (imply (\<sim> (p \<rightarrow> q) # S') \<bottom>)\<close>
      using cut' by blast
    moreover have \<open>set (\<sim> (p \<rightarrow> q) # S') \<subseteq> S\<close>
      using *(1) S'(2) by fastforce
    ultimately show False
      using assms unfolding consistent_def by blast
  next
    assume \<open>\<sim> q \<notin> S\<close>
    then obtain S' where S': \<open>\<turnstile> (imply (\<sim> q # S') \<bottom>)\<close> \<open>set S' \<subseteq> S\<close>
      using assms inconsistent_head by blast
    moreover have \<open>\<turnstile> (imply (\<sim> (p \<rightarrow> q) # S') (\<sim> q))\<close>
      using add_imply thes67 deduct by blast
    ultimately have \<open>\<turnstile> (imply (\<sim> (p \<rightarrow> q) # S') \<bottom>)\<close>
      using cut' by blast
    moreover have \<open>set (\<sim> (p \<rightarrow> q) # S') \<subseteq> S\<close>
      using *(1) S'(2) by fastforce
    ultimately show False
      using assms unfolding consistent_def by blast
  qed
next
  fix p
  assume *: \<open>\<sim> (\<sim> p) \<in> S\<close>
  show \<open>p \<in> S\<close>
  proof (rule ccontr)
    assume \<open>p \<notin> S\<close>
    then obtain SNA where SNA: \<open>\<turnstile> (imply (p # SNA) \<bottom>)\<close> \<open>set SNA \<subseteq> S\<close>
      using assms inconsistent_head by blast
    from * obtain SA where SA: \<open>\<turnstile> (imply SA p)\<close> \<open>set SA \<subseteq> S\<close>
      using imply_DNeg MP
      by (metis empty_set empty_subsetI imply_head insert_absorb insert_mono list.simps(15))
    obtain S' where S': \<open>set S' = set SA \<union> set SNA\<close> \<open>set S' \<subseteq> S\<close>
      using SA(2) SNA(2) by (metis Un_subset_iff set_union)
    with SNA SA have \<open>\<turnstile> (imply (p # S') \<bottom>)\<close> \<open>\<turnstile> (imply S' p)\<close>
      using deduct imply_weaken by simp_all
    with S' assms show \<open>False\<close> unfolding consistent_def
      using cut by meson
  qed
qed

section \<open>Countable Formulas\<close>

primrec diag :: \<open>nat \<Rightarrow> (nat \<times> nat)\<close> where
  \<open>diag 0 = (0, 0)\<close>
| \<open>diag (Suc n) =
     (let (x, y) = diag n
      in case y of
          0 \<Rightarrow> (0, Suc x)
        | Suc y \<Rightarrow> (Suc x, y))\<close>

theorem diag_le1: \<open>fst (diag (Suc n)) < Suc n\<close>
  by (induct n) (simp_all add: Let_def split_def split: nat.split)

theorem diag_le2: \<open>snd (diag (Suc (Suc n))) < Suc (Suc n)\<close>
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n')
  then show ?case
  proof (induct n')
    case 0
    then show ?case by simp
  next
    case (Suc _)
    then show ?case
      using diag_le1 by (simp add: Let_def split_def split: nat.split)
  qed
qed

theorem diag_le3: \<open>fst (diag n) = Suc x \<Longrightarrow> snd (diag n) < n\<close>
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n')
  then show ?case
  proof (induct n')
    case 0
    then show ?case by simp
  next
    case (Suc n'')
    then show ?case using diag_le2 by simp
  qed
qed

theorem diag_le4: \<open>fst (diag n) = Suc x \<Longrightarrow> x < n\<close>
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n')
  then have \<open>fst (diag (Suc n')) < Suc n'\<close>
    using diag_le1 by blast
  then show ?case using Suc by simp
qed

function undiag :: \<open>nat \<times> nat \<Rightarrow> nat\<close> where
  \<open>undiag (0, 0) = 0\<close>
| \<open>undiag (0, Suc y) = Suc (undiag (y, 0))\<close>
| \<open>undiag (Suc x, y) = Suc (undiag (x, Suc y))\<close>
  by pat_completeness auto
termination
  by (relation \<open>measure (\<lambda>(x, y). ((x + y) * (x + y + 1)) div 2 + x)\<close>) auto

theorem diag_undiag [simp]: \<open>diag (undiag (x, y)) = (x, y)\<close>
  by (induct rule: undiag.induct) simp_all

datatype btree = Leaf nat | Branch btree btree

function diag_btree :: \<open>nat \<Rightarrow> btree\<close> where
  \<open>diag_btree n = (case fst (diag n) of
       0 \<Rightarrow> Leaf (snd (diag n))
     | Suc x \<Rightarrow> Branch (diag_btree x) (diag_btree (snd (diag n))))\<close>
  by auto
termination
  by (relation \<open>measure id\<close>) (auto intro: diag_le3 diag_le4)

primrec undiag_btree :: \<open>btree \<Rightarrow> nat\<close> where
  \<open>undiag_btree (Leaf n) = undiag (0, n)\<close>
| \<open>undiag_btree (Branch t1 t2) = undiag (Suc (undiag_btree t1), undiag_btree t2)\<close>

theorem diag_undiag_btree [simp]: \<open>diag_btree (undiag_btree t) = t\<close>
  by (induct t) simp_all

declare diag_btree.simps [simp del] undiag_btree.simps [simp del]

fun form_of_btree :: \<open>btree \<Rightarrow> form\<close> where
  \<open>form_of_btree (Leaf n) = undefined\<close>
| \<open>form_of_btree (Branch (Leaf 0) (Leaf n)) = \<cdot> n\<close>
| \<open>form_of_btree (Branch (Leaf (Suc 0)) (Branch t1 t2)) =
     Imp (form_of_btree t1) (form_of_btree t2)\<close>
| \<open>form_of_btree (Branch (Leaf 0) (Branch t _)) = \<sim> (form_of_btree t)\<close>
| \<open>form_of_btree (Branch (Leaf (Suc 0)) (Leaf _)) = undefined\<close>
| \<open>form_of_btree (Branch (Leaf (Suc (Suc _))) _) = undefined\<close>
| \<open>form_of_btree (Branch (Branch _ _) _) = undefined\<close>

primrec btree_of_form :: \<open>form \<Rightarrow> btree\<close> where
  \<open>btree_of_form (\<cdot> n) = Branch (Leaf 0) (Leaf n)\<close>
| \<open>btree_of_form (\<sim> p) = Branch (Leaf 0) (Branch (btree_of_form p) (Leaf 0))\<close>
| \<open>btree_of_form (Imp p q) = Branch (Leaf (Suc 0))
     (Branch (btree_of_form p) (btree_of_form q))\<close>

definition diag_form :: \<open>nat \<Rightarrow> form\<close> where
  \<open>diag_form n = form_of_btree (diag_btree n)\<close>

definition undiag_form :: \<open>form \<Rightarrow> nat\<close> where
  \<open>undiag_form p = undiag_btree (btree_of_form p)\<close>

theorem diag_undiag_form [simp]: \<open>diag_form (undiag_form p) = p\<close>
  unfolding diag_form_def undiag_form_def by (induct p) simp_all

abbreviation \<open>from_nat \<equiv> diag_form\<close>
abbreviation \<open>to_nat \<equiv> undiag_form\<close>

lemma surj_from_nat: \<open>surj from_nat\<close>
  by (metis diag_undiag_form surj_def)

section \<open>Completeness\<close>

lemma imply_completeness:
  assumes valid: \<open>\<forall>I. list_all (\<lambda>q. (I \<Turnstile> q)) ps \<longrightarrow> (I \<Turnstile> p)\<close>
  shows \<open>\<turnstile> (imply ps p)\<close>
proof (rule ccontr)
  assume \<open>\<not> \<turnstile> (imply ps p)\<close>
  then have *: \<open>\<not> \<turnstile> (imply (\<sim> p # ps) \<bottom>)\<close>
    using Boole by blast

  let ?S = \<open>set (\<sim> p # ps)\<close>
  let ?H = \<open>Extend ?S from_nat\<close>

  have \<open>consistent ?S\<close>
    unfolding consistent_def using * imply_weaken by blast
  then have \<open>consistent ?H\<close> \<open>maximal ?H\<close>
    using consistent_Extend maximal_Extend surj_from_nat by blast+
  then have \<open>Hintikka ?H\<close>
    using Hintikka_Extend by blast

  have \<open>model ?H \<Turnstile> p\<close> if \<open>p \<in> ?S\<close> for p
    using that Extend_subset Hintikka_model \<open>Hintikka ?H\<close> by blast
  then have \<open>model ?H \<Turnstile> (\<sim> p)\<close> \<open>list_all (\<lambda>p. (model ?H \<Turnstile> p)) ps\<close>
    unfolding list_all_def by fastforce+
  then have \<open>model ?H \<Turnstile> p\<close>
    using valid by blast
  then show False
    using \<open>model ?H \<Turnstile> (\<sim> p)\<close> by simp
qed

theorem L1_completeness: \<open>\<turnstile> p\<close> if \<open>\<forall>I. (I \<Turnstile> p)\<close>
  using that imply_completeness[where ps=\<open>[]\<close>] by simp

section \<open>The Meredith Single Axiom (C. A. Meredith, J. Computing Systems 1:155-164 1953)\<close>

text \<open>Inspired by Larry Wos: Conquering the Meredith Single Axiom, J. Autom. Reas. 27:175–199 2001\<close>

inductive Single (\<open>\<tturnstile>\<close>) where
  \<open>\<tturnstile> q\<close> if \<open>\<tturnstile> p\<close> and \<open>\<tturnstile> (p \<rightarrow> q)\<close> |
  \<open>\<tturnstile> (((((p \<rightarrow> q) \<rightarrow> (\<sim> r \<rightarrow> \<sim> s)) \<rightarrow> r) \<rightarrow> t) \<rightarrow> ((t \<rightarrow> p) \<rightarrow> (s \<rightarrow> p)))\<close>

lemma L1_3: \<open>\<tturnstile> (p \<rightarrow> (\<sim> p \<rightarrow> q))\<close>
  using Single.intros by metis

lemma 1: \<open>\<tturnstile> (((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> (q \<rightarrow> r))\<close>
  using Single.intros by metis

lemma 2: \<open>\<tturnstile> (p \<rightarrow> (((q \<rightarrow> p) \<rightarrow> r) \<rightarrow> (s \<rightarrow> r)))\<close>
  using Single.intros 1 by metis

lemma 3: \<open>\<tturnstile> (p \<rightarrow> (((q \<rightarrow> r) \<rightarrow> s) \<rightarrow> (((r \<rightarrow> t) \<rightarrow> (\<sim> s \<rightarrow> \<sim> q)) \<rightarrow> s)))\<close>
  using Single.intros 1 2 by meson

lemma 4: \<open>\<tturnstile> (((p \<rightarrow> q) \<rightarrow> (r \<rightarrow> (s \<rightarrow> (q \<rightarrow> t)))) \<rightarrow> (u \<rightarrow> (r \<rightarrow> (s \<rightarrow> (q \<rightarrow> t)))))\<close>
  using Single.intros 2 3 by meson

lemma 5: \<open>\<tturnstile> (((p \<rightarrow> (\<sim> (\<sim> q) \<rightarrow> q)) \<rightarrow> r) \<rightarrow> r)\<close>
  using Single.intros 1 4 by metis

lemma L1_2: \<open>\<tturnstile> ((\<sim> p \<rightarrow> p) \<rightarrow> p)\<close>
  using Single.intros 1 4 5 by metis

lemma 6: \<open>\<tturnstile> (((p \<rightarrow> (q \<rightarrow> (\<sim> ((r \<rightarrow> (\<sim> (\<sim> s) \<rightarrow> s)) \<rightarrow> \<sim> q)))) \<rightarrow> t) \<rightarrow> t)\<close>
  using Single.intros 4 5 by metis

lemma L1_1: \<open>\<tturnstile> ((p \<rightarrow> q) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> (p \<rightarrow> r)))\<close>
  using Single.intros 6 by meson

theorem \<open>\<turnstile> p \<longleftrightarrow> \<tturnstile> p\<close>
proof
  show \<open>\<turnstile> p\<close> if \<open>\<tturnstile> p\<close>
    using that by induct (auto intro: MP simp: L1_completeness simps simp del: semantics.simps)
next
  show \<open>\<tturnstile> p\<close> if \<open>\<turnstile> p\<close>
    using that by induct (auto intro: Single.intros(1) simp: L1_1 L1_2 L1_3)
qed

end


theory "Denotational_Semantics"
imports
  "HOL-Analysis.Derivative"
  "Syntax"
begin
section \<open>Denotational Semantics\<close>

text \<open>Defines the denotational semantics of Differential Game Logic. \<^url>\<open>https://doi.org/10.1145/2817824\<close> \<^url>\<open>https://doi.org/10.1007/978-3-319-94205-6_15\<close>\<close>

subsection \<open>States\<close>

text \<open>Vector of reals over ident\<close>
type_synonym Rvec = "variable \<Rightarrow> real"
type_synonym state = "Rvec"

text \<open>the set of all worlds\<close>
definition worlds:: "state set"
  where "worlds = {\<nu>. True}"

text \<open>the set of all variables\<close>
abbreviation allvars:: "variable set"
  where "allvars \<equiv> {x::variable. True}"

text \<open>the set of all real variables\<close>
abbreviation allrvars:: "variable set"
  where "allrvars \<equiv> {RVar x | x. True}"

text \<open>the set of all differential variables\<close>
abbreviation alldvars:: "variable set"
  where "alldvars \<equiv> {DVar x | x. True}"

lemma ident_finite: "finite({x::ident. True})"
  by auto

lemma allvar_cases: "allvars = allrvars \<union> alldvars"
  using variable.exhaust by blast

lemma rvar_finite: "finite allrvars"
  using finite_imageI[OF ident_finite, where h=\<open>\<lambda>x. RVar x\<close>] by (simp add: full_SetCompr_eq)

lemma dvar_finite: "finite alldvars"
  using finite_imageI[OF ident_finite, where h=\<open>\<lambda>x. DVar x\<close>] by (simp add: full_SetCompr_eq)

lemma allvars_finite [simp]: "finite(allvars)"
  using allvar_cases dvar_finite rvar_finite by (metis finite_Un)

definition Vagree :: "state \<Rightarrow> state \<Rightarrow> variable set \<Rightarrow> bool"
  where "Vagree \<nu> \<nu>' V \<equiv> (\<forall>i. i\<in>V \<longrightarrow> \<nu>(i) = \<nu>'(i))"

definition Uvariation :: "state \<Rightarrow> state \<Rightarrow> variable set \<Rightarrow> bool"
  where "Uvariation \<nu> \<nu>' U \<equiv> (\<forall>i. ~(i\<in>U) \<longrightarrow> \<nu>(i) = \<nu>'(i))"

lemma Vagree_refl [simp]: "Vagree \<nu> \<nu> V"
  by (auto simp add: Vagree_def)

lemma Vagree_sym: "Vagree \<nu> \<nu>' V = Vagree \<nu>' \<nu> V"
  by (auto simp add: Vagree_def)

lemma Vagree_sym_rel [sym]: "Vagree \<nu> \<nu>' V \<Longrightarrow> Vagree \<nu>' \<nu> V"
  using Vagree_sym by auto

lemma Vagree_union [trans]: "Vagree \<nu> \<nu>' V \<Longrightarrow> Vagree \<nu> \<nu>' W \<Longrightarrow> Vagree \<nu> \<nu>' (V\<union>W)"
  by (auto simp add: Vagree_def)

lemma Vagree_trans [trans]: "Vagree \<nu> \<nu>' V \<Longrightarrow> Vagree  \<nu>' \<nu>'' W \<Longrightarrow> Vagree \<nu> \<nu>'' (V\<inter>W)"
  by (auto simp add: Vagree_def)

lemma Vagree_antimon [simp]: "Vagree \<nu> \<nu>' V \<and> W\<subseteq>V \<longrightarrow> Vagree \<nu> \<nu>' W"
  by (auto simp add: Vagree_def)

lemma Vagree_empty [simp]: "Vagree \<nu> \<nu>' {}"
  by (auto simp add: Vagree_def)

lemma Uvariation_empty [simp]: "Uvariation \<nu> \<nu>' {} = (\<nu>=\<nu>')"
  by (auto simp add: Uvariation_def)

lemma Vagree_univ [simp]: "Vagree \<nu> \<nu>' allvars = (\<nu>=\<nu>')"
  by (auto simp add: Vagree_def)

lemma Uvariation_univ [simp]: "Uvariation \<nu> \<nu>' allvars"
  by (auto simp add: Uvariation_def)

lemma Vagree_and [simp]: "Vagree \<nu> \<nu>' V \<and> Vagree \<nu> \<nu>' W \<longleftrightarrow> Vagree \<nu> \<nu>' (V\<union>W)"
  by (auto simp add: Vagree_def)

lemma Vagree_or: "Vagree \<nu> \<nu>' V \<or> Vagree \<nu> \<nu>' W \<longrightarrow> Vagree \<nu> \<nu>' (V\<inter>W)"
  by (auto simp add: Vagree_def)

lemma Uvariation_refl [simp]: "Uvariation \<nu> \<nu> V"
  by (auto simp add: Uvariation_def)

lemma Uvariation_sym: "Uvariation \<omega> \<nu> U = Uvariation \<nu> \<omega> U"
  unfolding Uvariation_def by auto

lemma Uvariation_sym_rel [sym]: "Uvariation \<omega> \<nu> U \<Longrightarrow> Uvariation \<nu> \<omega> U"
  using Uvariation_sym by auto

lemma Uvariation_trans [trans]: "Uvariation \<omega> \<nu> U \<Longrightarrow> Uvariation \<nu> \<mu> V \<Longrightarrow> Uvariation \<omega> \<mu> (U\<union>V)"
  unfolding Uvariation_def by simp

lemma Uvariation_mon [simp]: "V \<supseteq> U \<Longrightarrow> Uvariation \<omega> \<nu> U \<Longrightarrow> Uvariation \<omega> \<nu> V"
  unfolding Uvariation_def by auto

subsection Interpretations

lemma mon_mono: "mono r = ((\<forall>X Y. (X\<subseteq>Y \<longrightarrow> r(X)\<subseteq>r(Y))))"
  unfolding mono_def by simp

text \<open>interpretations of symbols in ident\<close>
type_synonym interp_rep =
 "(ident \<Rightarrow> real) \<times> (ident \<Rightarrow> (real \<Rightarrow> real)) \<times> (ident \<Rightarrow> (real \<Rightarrow> bool)) \<times> (ident \<Rightarrow> (state set \<Rightarrow> state set))"

definition is_interp :: "interp_rep \<Rightarrow> bool"
 where "is_interp I \<equiv> case I of (_, _, _, G) \<Rightarrow> (\<forall>a. mono (G a))"

typedef interp = "{I:: interp_rep. is_interp I}"
  morphisms raw_interp well_interp
proof
 show "(\<lambda>f. 0, \<lambda>f x. 0, \<lambda>p x. True, \<lambda>a. \<lambda>X. X) \<in> {I. is_interp I}" unfolding is_interp_def mono_def by simp
qed

setup_lifting type_definition_interp

lift_definition Consts::"interp \<Rightarrow> ident \<Rightarrow> (real)" is "\<lambda>(F0, _, _, _). F0" .
lift_definition Funcs:: "interp \<Rightarrow> ident \<Rightarrow> (real \<Rightarrow> real)" is "\<lambda>(_, F, _, _). F" .
lift_definition Preds:: "interp \<Rightarrow> ident \<Rightarrow> (real \<Rightarrow> bool)" is "\<lambda>(_, _, P, _). P" .
lift_definition Games:: "interp \<Rightarrow> ident \<Rightarrow> (state set \<Rightarrow> state set)" is "\<lambda>(_, _, _, G). G" .

text \<open>make interpretations\<close>
lift_definition mkinterp:: "(ident \<Rightarrow> real) \<times> (ident \<Rightarrow> (real \<Rightarrow> real)) \<times> (ident \<Rightarrow> (real \<Rightarrow> bool)) \<times> (ident \<Rightarrow> (state set \<Rightarrow> state set))
\<Rightarrow> interp"
  is "\<lambda>(C, F, P, G). if \<forall>a. mono (G a) then (C, F, P, G) else (C, F, P, \<lambda>_ _. {})"
  by (auto split: prod.splits simp: mono_def is_interp_def)

lemma Consts_mkinterp [simp]: "Consts (mkinterp(C,F,P,G)) = C"
  apply (transfer fixing: C F P G)
  apply (auto simp add: is_interp_def mono_def)
  done

lemma Funcs_mkinterp [simp]: "Funcs (mkinterp(C,F,P,G)) = F"
  apply (transfer fixing: C F P G)
  apply (auto simp add: is_interp_def mono_def)
  done

lemma Preds_mkinterp [simp]: "Preds (mkinterp(C,F,P,G)) = P"
  apply (transfer fixing: C F P G)
  apply (auto simp add: is_interp_def mono_def)
  done

lemma Games_mkinterp [simp]: "(\<And>a. mono (G a) ) \<Longrightarrow> Games (mkinterp(C,F,P,G)) = G"
  apply (transfer fixing: C F P G)
  apply (auto simp add: is_interp_def mono_def)
  done

lemma mkinterp_eq [iff]: "(Consts I = Consts J \<and> Funcs I = Funcs J \<and> Preds I = Preds J \<and> Games I = Games J) = (I=J)"
  apply (transfer fixing: C F P G)
  apply (auto simp add: is_interp_def mono_def)
  done

lifting_update interp.lifting
lifting_forget interp.lifting

subsection Semantics

text \<open>Semantic modification \<open>repv \<omega> x r\<close> replaces the value of variable \<open>x\<close> in the state \<open>\<omega>\<close> with r\<close>
definition repv :: "state \<Rightarrow> variable \<Rightarrow> real \<Rightarrow> state"
  where "repv \<omega> x r = fun_upd \<omega> x r"

lemma repv_def_correct: "repv \<omega> x r = (\<lambda>y. if x = y then r else \<omega>(y))"
  unfolding repv_def by auto

lemma repv_access [simp]: "(repv \<omega> x r)(y) = (if (x=y) then r else \<omega>(y))"
  unfolding repv_def by simp

lemma repv_self [simp]: "repv \<omega> x (\<omega>(x)) = \<omega>"
  unfolding repv_def by auto

lemma Vagree_repv: "Vagree \<omega> (repv \<omega> x d) (-{x})"
  unfolding repv_def Vagree_def by simp

lemma Vagree_repv_self: "Vagree \<omega> (repv \<omega> x d) {x} = (d=\<omega>(x))"
  unfolding repv_def Vagree_def by auto

lemma Uvariation_repv: "Uvariation \<omega> (repv \<omega> x d) {x}"
  unfolding repv_def Uvariation_def by simp

paragraph \<open>Semantics of Terms\<close>

fun term_sem :: "interp \<Rightarrow> trm \<Rightarrow> (state \<Rightarrow> real)"
where
  "term_sem I (Var x) = (\<lambda>\<omega>. \<omega>(x))"
| "term_sem I (Number r) = (\<lambda>\<omega>. r)"
| "term_sem I (Const f) = (\<lambda>\<omega>. (Consts I f))"
| "term_sem I (Func f \<theta>) = (\<lambda>\<omega>. (Funcs I f)(term_sem I \<theta> \<omega>))"
| "term_sem I (Plus \<theta> \<eta>) = (\<lambda>\<omega>. term_sem I \<theta> \<omega> + term_sem I \<eta> \<omega>)"
| "term_sem I (Times \<theta> \<eta>) = (\<lambda>\<omega>. term_sem I \<theta> \<omega> * term_sem I \<eta> \<omega>)"
| "term_sem I (Differential \<theta>) = (\<lambda>\<omega>. sum(\<lambda>x. \<omega>(DVar x)*deriv(\<lambda>X. term_sem I \<theta> (repv \<omega> (RVar x) X))(\<omega>(RVar x)))(allidents))"

paragraph \<open>Solutions of Differential Equations\<close>

(*@note For simplicity, solutions are not limited to a smaller interval of existence*)
type_synonym solution = "real \<Rightarrow> state"

definition solves_ODE :: "interp \<Rightarrow> solution \<Rightarrow> ident \<Rightarrow> trm \<Rightarrow> bool"
where "solves_ODE I F x \<theta> \<equiv> (\<forall>\<zeta>::real.
     Vagree (F(0)) (F(\<zeta>)) (-{RVar x, DVar x})
   \<and> F(\<zeta>)(DVar x) = deriv(\<lambda>t. F(t)(RVar x))(\<zeta>)
   \<and> F(\<zeta>)(DVar x) = term_sem I \<theta> (F(\<zeta>)))"

paragraph \<open>Semantics of Formulas and Games\<close>

fun fml_sem :: "interp \<Rightarrow> fml \<Rightarrow> (state set)" and
   game_sem :: "interp \<Rightarrow> game \<Rightarrow> (state set \<Rightarrow> state set)"
where
  "fml_sem I (Pred p \<theta>) = {\<omega>. (Preds I p)(term_sem I \<theta> \<omega>)}"
| "fml_sem I (Geq \<theta> \<eta>) = {\<omega>. term_sem I \<theta> \<omega> \<ge> term_sem I \<eta> \<omega>}"
| "fml_sem I (Not \<phi>) = {\<omega>. \<omega> \<notin> fml_sem I \<phi>}"
| "fml_sem I (And \<phi> \<psi>) = fml_sem I \<phi> \<inter> fml_sem I \<psi>"
| "fml_sem I (Exists x \<phi>) = {\<omega>. \<exists>r. (repv \<omega> x r) \<in> fml_sem I \<phi>}"
| "fml_sem I (Diamond \<alpha> \<phi>) = game_sem I \<alpha> (fml_sem I \<phi>)"

| "game_sem I (Game a) = (\<lambda>X. (Games I a)(X))"
| "game_sem I (Assign x \<theta>) = (\<lambda>X. {\<omega>. (repv \<omega> x (term_sem I \<theta> \<omega>)) \<in> X})"
| "game_sem I (Test \<phi>) = (\<lambda>X. fml_sem I \<phi> \<inter> X)"
| "game_sem I (Choice \<alpha> \<beta>) = (\<lambda>X. game_sem I \<alpha> X \<union> game_sem I \<beta> X)"
| "game_sem I (Compose \<alpha> \<beta>) = (\<lambda>X. game_sem I \<alpha> (game_sem I \<beta> X))"
| "game_sem I (Loop \<alpha>) = (\<lambda>X. \<Inter>{Z. X \<union> game_sem I \<alpha> Z \<subseteq> Z})"
| "game_sem I (Dual \<alpha>) = (\<lambda>X. -(game_sem I \<alpha> (-X)))"
| "game_sem I (ODE x \<theta>) = (\<lambda>X. {\<omega>. \<exists>F T. Vagree \<omega> (F(0)) (-{DVar x}) \<and> F(T) \<in> X \<and> solves_ODE I F x \<theta>})"

text \<open>Validity\<close>

definition valid_in :: "interp \<Rightarrow> fml \<Rightarrow> bool"
where "valid_in I \<phi> \<equiv> (\<forall>\<omega>. \<omega> \<in> fml_sem I \<phi>)"

definition valid :: "fml \<Rightarrow> bool"
  where "valid \<phi> \<equiv> (\<forall>I.\<forall>\<omega>. \<omega> \<in> fml_sem I \<phi>)"

lemma valid_is_valid_in_all: "valid \<phi> = (\<forall>I. valid_in I \<phi>)"
  unfolding valid_def valid_in_def by auto

definition locally_sound :: "inference \<Rightarrow> bool"
  where "locally_sound R \<equiv>
  (\<forall>I. (\<forall>k. 0\<le>k \<longrightarrow> k<length (fst R) \<longrightarrow> valid_in I (nth (fst R) k)) \<longrightarrow> valid_in I (snd R))"

definition sound :: "inference \<Rightarrow> bool"
  where "sound R \<equiv>
  (\<forall>k. 0\<le>k \<longrightarrow> k<length (fst R) \<longrightarrow> valid (nth (fst R) k)) \<longrightarrow> valid (snd R)"

lemma locally_sound_is_sound: "locally_sound R \<Longrightarrow> sound R"
  unfolding locally_sound_def sound_def using valid_is_valid_in_all by auto

subsection \<open>Monotone Semantics\<close>

lemma monotone_Test [simp]: "X\<subseteq>Y \<Longrightarrow> game_sem I (Test \<phi>) X \<subseteq> game_sem I (Test \<phi>) Y"
  by auto

lemma monotone [simp]: "X\<subseteq>Y \<Longrightarrow> game_sem I \<alpha> X \<subseteq> game_sem I \<alpha> Y"
proof (induction \<alpha> arbitrary: X Y rule: game_induct)
  case (Game a)
  then show ?case by simp
next
  case (Assign x \<theta>)
  then show ?case by auto
next
  case (Test \<phi>)
  then show ?case by auto
next
  case (Choice \<alpha>1 \<alpha>2)
  then show ?case by (metis Un_mono game_sem.simps(4))
next
  case (Compose \<alpha>1 \<alpha>2)
  then show ?case by auto
next
  case (Loop \<alpha>)
  then show ?case by auto
next
  case (Dual \<alpha>)
  then show ?case by auto
next
  case (ODE x \<theta>)
  then show ?case by auto
qed

corollary game_sem_mono [simp]: "mono (\<lambda>X. game_sem I \<alpha> X)"
  by (simp add: mon_mono)

corollary game_union: "game_sem I \<alpha> (X\<union>Y) \<supseteq> game_sem I \<alpha> X \<union> game_sem I \<alpha> Y"
  by simp

lemmas game_sem_union = game_union

subsection \<open>Fixpoint Semantics Alternative for Loops\<close>

lemma game_sem_loop_fixpoint_mono: "mono (\<lambda>Z. X \<union> game_sem I \<alpha> Z)"
  using game_sem_mono by (metis Un_mono mon_mono order_refl)

text \<open>Consequence of Knaster-Tarski Theorem 3.5 of \<^url>\<open>https://doi.org/10.1145/2817824\<close>\<close>

lemma game_sem_loop: "game_sem I (Loop \<alpha>) = (\<lambda>X. lfp(\<lambda>Z. X \<union> game_sem I \<alpha> Z))"
proof-
  have "\<Inter>{Z. X \<union> game_sem I \<alpha> Z \<subseteq> Z} = lfp(\<lambda>Z. X \<union> game_sem I \<alpha> Z)" by (simp add: lfp_def)
  then show ?thesis by (simp add: lfp_def)
qed

corollary game_sem_loop_back: "(\<lambda>X. lfp(\<lambda>Z. X \<union> game_sem I \<alpha> Z)) = game_sem I (Loop \<alpha>)"
  using game_sem_loop by simp

corollary game_sem_loop_iterate: "game_sem I (Loop \<alpha>) = (\<lambda>X. X \<union> game_sem I \<alpha> (game_sem I (Loop \<alpha>) X))"
  by (metis (no_types) game_sem_loop game_sem_loop_fixpoint_mono lfp_fixpoint)

corollary game_sem_loop_unwind: "game_sem I (Loop \<alpha>) = (\<lambda>X. X \<union> game_sem I (Compose \<alpha> (Loop \<alpha>)) X)"
using game_sem_loop_iterate by (metis game_sem.simps(5))

corollary game_sem_loop_unwind_reduce: "(\<lambda>X. X \<union> game_sem I (Compose \<alpha> (Loop \<alpha>)) X) = game_sem I (Loop \<alpha>)"
  using game_sem_loop_unwind by (rule sym)

lemmas lfp_ordinal_induct_set_cases = lfp_ordinal_induct_set [case_names mono step union]

(* Read off a fixpoint induction scheme from the fact that loops have a least fixpoint semantics *)
lemma game_loop_induct [case_names step union]:
  "(\<And>Z. Z \<subseteq> game_sem I (Loop \<alpha>) X \<Longrightarrow> P(Z) \<Longrightarrow> P(X \<union> game_sem I \<alpha> Z))
  \<Longrightarrow> (\<And>M. (\<forall>Z\<in>M. P(Z)) \<Longrightarrow> P(Sup M))
  \<Longrightarrow> P(game_sem I (Loop \<alpha>) X)"
proof-
  assume loopstep: "\<And>Z. Z \<subseteq> game_sem I (Loop \<alpha>) X \<Longrightarrow> P(Z) \<Longrightarrow>  P(X \<union> game_sem I \<alpha> Z)"
  assume loopsup: "\<And>M. (\<forall>Z\<in>M. P(Z)) \<Longrightarrow> P(Sup M)"
  have "P(lfp(\<lambda>Z. X \<union> game_sem I \<alpha> Z))"
  proof (induction rule: lfp_ordinal_induct[where f=\<open>\<lambda>Z. X \<union> game_sem I \<alpha> Z\<close>])
    case mono
    then show ?case using game_sem_loop_fixpoint_mono by simp
  next
    case (step S)
    then show ?case using loopstep[where Z=S] game_sem_loop[where I=I and \<alpha>=\<alpha>] by (simp add: loopstep)
  next
    case (union M)
    then show ?case using loopsup game_sem_loop by auto
  qed
  then show "P(game_sem I (Loop \<alpha>) X)" using game_sem_loop by simp
  (*proof (induction rule: lfp_ordinal_induct_set_cases[where f=\<open>\<lambda>Z. X \<union> game_sem I \<alpha> Z\<close>])
    case mono
    then show ?case using game_sem_loop_fixpoint_mono by simp
  next
    case (step S)
    then show ?case using loopstep by auto
  next
    case (union M)
    then show ?case using loopsup game_sem_loop by auto
  qed*)
qed

subsection \<open>Some Simple Obvious Observations\<close>

lemma fml_sem_not [simp]: "fml_sem I (Not \<phi>) = -fml_sem I \<phi>"
  by auto

lemma fml_sem_not_not [simp]: "fml_sem I (Not (Not \<phi>)) = fml_sem I \<phi>"
  by simp

lemma fml_sem_or [simp]: "fml_sem I (Or \<phi> \<psi>) = fml_sem I \<phi> \<union> fml_sem I \<psi>"
  unfolding Or_def by auto

lemma fml_sem_implies [simp]: "fml_sem I (Implies \<phi> \<psi>) = (-fml_sem I \<phi>) \<union> fml_sem I \<psi>"
  unfolding Implies_def by auto

lemma TT_valid [simp]: "valid TT"
  unfolding valid_def TT_def by simp

paragraph \<open>Semantic equivalence of formulas\<close>

definition fml_equiv:: "fml => fml => bool"
  where "fml_equiv \<phi> \<psi> \<equiv> (\<forall>I. fml_sem I \<phi> = fml_sem I \<psi>)"

text \<open>Substitutionality for Equivalent Formulas\<close>

lemma fml_equiv_subst: "fml_equiv \<phi> \<psi> \<Longrightarrow> P (fml_sem I \<phi>) \<Longrightarrow> P (fml_sem I \<psi>)"
proof-
  assume a1: "fml_equiv \<phi> \<psi>"
  assume a2: "P (fml_sem I \<phi>)"
  from a1 have "fml_sem I \<phi> = fml_sem I \<psi>" using fml_equiv_def by blast
  then show ?thesis using forw_subst a2 by simp
qed

lemma valid_fml_equiv: "valid (\<phi> \<leftrightarrow> \<psi>) = fml_equiv \<phi> \<psi>"
  unfolding valid_def Equiv_def Or_def fml_equiv_def by auto

lemma valid_in_equiv: "valid_in I (\<phi> \<leftrightarrow> \<psi>) = ((fml_sem I \<phi>) = (fml_sem I \<psi>))"
  using valid_in_def Equiv_def Or_def by auto

lemma valid_in_impl: "valid_in I (\<phi> \<rightarrow> \<psi>) = ((fml_sem I \<phi>) \<subseteq> (fml_sem I \<psi>))"
  unfolding valid_in_def Implies_def Or_def by auto

lemma valid_equiv: "valid (\<phi> \<leftrightarrow> \<psi>) = (\<forall>I. fml_sem I \<phi> = fml_sem I \<psi>)"
  using valid_fml_equiv fml_equiv_def by auto

lemma valid_impl: "valid (\<phi> \<rightarrow> \<psi>) = (\<forall>I. (fml_sem I \<phi>) \<subseteq> (fml_sem I \<psi>))"
  unfolding valid_def Implies_def Or_def by auto

lemma fml_sem_equals [simp]: "(\<omega> \<in> fml_sem I (Equals \<theta> \<eta>)) = (term_sem I \<theta> \<omega> = term_sem I \<eta> \<omega>)"
  unfolding valid_def Equals_def Or_def by auto

lemma equiv_refl_valid [simp]: "valid (\<phi> \<leftrightarrow> \<phi>)"
  unfolding valid_def Equiv_def Or_def by simp

lemma equal_refl_valid [simp]: "valid (Equals \<theta> \<theta>)"
  unfolding valid_def Equals_def Or_def by simp

lemma solves_ODE_alt : "solves_ODE I F x \<theta> \<equiv> (\<forall>\<zeta>::real.
     Vagree (F(0)) (F(\<zeta>)) (-{RVar x, DVar x})
   \<and> F(\<zeta>)(DVar x) = deriv(\<lambda>t. F(t)(RVar x))(\<zeta>)
   \<and> F(\<zeta>) \<in> fml_sem I (Equals (Var (DVar x)) \<theta>))"
   unfolding solves_ODE_def using fml_sem_equals by simp

paragraph \<open>Semantic equivalence of games\<close>

definition game_equiv:: "game => game => bool"
  where "game_equiv \<alpha> \<beta> \<equiv> (\<forall>I X. game_sem I \<alpha> X = game_sem I \<beta> X)"

text \<open>Substitutionality for Equivalent Games\<close>

lemma game_equiv_subst: "game_equiv \<alpha> \<beta> \<Longrightarrow> P (game_sem I \<alpha> X) \<Longrightarrow> P (game_sem I \<beta> X)"
proof-
  assume a1: "game_equiv \<alpha> \<beta>"
  assume a2: "P (game_sem I \<alpha> X)"
  from a1 have "game_sem I \<alpha> X = game_sem I \<beta> X" using game_equiv_def by blast
  then show ?thesis using forw_subst a2 by simp
qed

lemma game_equiv_subst_eq: "game_equiv \<alpha> \<beta> \<Longrightarrow> P (game_sem I \<alpha> X) == P (game_sem I \<beta> X)"
  by (simp add: game_equiv_def)

lemma skip_id [simp]: "game_sem I Skip X = X"
  unfolding Skip_def TT_def by auto

lemma loop_iterate_equiv: "game_equiv (Loop \<alpha>) (Choice Skip (Compose \<alpha> (Loop \<alpha>)))"
unfolding game_equiv_def
proof (clarify)
  fix I X
  from game_sem_loop_unwind_reduce have "X \<union> game_sem I (Compose \<alpha> (Loop \<alpha>)) X = game_sem I (Loop \<alpha>) X" by metis
  then show "game_sem I (Loop \<alpha>) X = game_sem I (Choice Skip (Compose \<alpha> (Loop \<alpha>))) X" using skip_id by auto
qed

lemma fml_equiv_valid: "fml_equiv \<phi> \<psi> \<Longrightarrow> valid \<phi> = valid \<psi>"
  unfolding valid_def using fml_equiv_subst by blast

lemma solves_Vagree: "solves_ODE I F x \<theta> \<Longrightarrow> (\<And>\<zeta>. Vagree (F(\<zeta>)) (F(0)) (-{RVar x,DVar x}))"
  using solves_ODE_def Vagree_sym_rel by blast

lemma solves_Vagree_trans: "Uvariation (F(0)) \<omega> U \<Longrightarrow> solves_ODE I F x \<theta> \<Longrightarrow> Uvariation (F(\<zeta>)) \<omega> (U\<union>{RVar x,DVar x})"
  using solves_Vagree Uvariation_Vagree solves_ODE_def
  by (metis Uvariation_sym_rel Uvariation_trans double_complement)

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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_nat_BSortCount
imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

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

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

fun sort2 :: "Nat => Nat => Nat list" where
"sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun pairs :: "Nat list => Nat list => Nat list" where
"pairs (nil2) z = z"
| "pairs (cons2 z2 x2) (nil2) = cons2 z2 x2"
| "pairs (cons2 z2 x2) (cons2 x3 x4) =
     x (sort2 z2 x3) (pairs x2 x4)"

fun stitch :: "Nat list => Nat list => Nat list" where
"stitch (nil2) z = z"
| "stitch (cons2 z2 xs) z = cons2 z2 (pairs xs z)"

function evens :: "'a list => 'a list"
         and odds :: "'a list => 'a list" where
"evens (nil2) = nil2"
| "evens (cons2 z xs) = cons2 z (odds xs)"
| "odds (nil2) = nil2"
| "odds (cons2 z xs) = evens xs"
by pat_completeness auto

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

(*fun did not finish the proof*)
function bmerge :: "Nat list => Nat list => Nat list" where
"bmerge (nil2) z = nil2"
| "bmerge (cons2 z2 x2) (nil2) = cons2 z2 x2"
| "bmerge (cons2 z2 x2) (cons2 x3 x4) =
     (let fail :: Nat list =
       stitch
         (bmerge (evens (cons2 z2 x2)) (evens (cons2 x3 x4)))
         (bmerge (odds (cons2 z2 x2)) (odds (cons2 x3 x4)))
     in (case x2 of
           nil2 =>
             (case x4 of
                nil2 => sort2 z2 x3
                | cons2 x5 x6 => fail)
           | cons2 x7 x8 => fail))"
  by pat_completeness auto

(*fun did not finish the proof*)
function bsort :: "Nat list => Nat list" where
"bsort (nil2) = nil2"
| "bsort (cons2 z (nil2)) = cons2 z (nil2)"
| "bsort (cons2 z (cons2 x2 x3)) =
     bmerge
       (bsort (evens (cons2 z (cons2 x2 x3))))
       (bsort (odds (cons2 z (cons2 x2 x3))))"
  by pat_completeness auto

theorem property0 :
  "((count y (bsort xs)) = (count y xs))"
  oops

end


theory Exercise4
  imports Main
begin

inductive ev :: "nat \<Rightarrow> bool" where
ev0: "ev 0" |
evSS: "ev n \<Longrightarrow> ev (Suc (Suc n))"

lemma "\<not> ev (Suc (Suc (Suc 0)))" (is "\<not> ?EVEN3")
proof
  assume "?EVEN3"
  hence "ev (Suc 0)" by cases
  thus False by cases
qed

end


theory Induction_Demo
imports Main
begin

(* HINT FOR ONLINE DEMO
   Start your first proof attempt with
   itrev xs [] = rev xs
   then generalize by introducing ys, and finally quantify over ys.
   Each generalization should be motivated by the previous failed
   proof attempt.
*)

fun itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"itrev [] ys = ys" |
"itrev (x#xs) ys = itrev xs (x#ys)"

lemma "itrev xs ys = rev xs @ ys"
apply(induction xs arbitrary: ys)
apply(auto)
done

subsection "Computation Induction"

fun sep :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"sep a [] = []" |
"sep a [x] = [x]" |
"sep a (x#y#zs) = x # a # sep a (y#zs)"

lemma "map f (sep a xs) = sep (f a) (map f xs)"
apply(induction a xs rule: sep.induct)
apply auto
done

end


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

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

datatype Nat = Z | S "Nat"

fun len :: "'a list => Nat" where
  "len (nil2) = Z"
| "len (cons2 y xs) = S (len xs)"

fun filter :: "('a => bool) => 'a list => 'a list" where
  "filter x (nil2) = nil2"
| "filter x (cons2 z xs) =
     (if x z then cons2 z (filter x xs) else filter x xs)"

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

theorem property0 :
  "t2 (len (filter p xs)) (len xs)"
  oops

end


section \<open>The Datatype of Lazy Natural Numbers\<close>

theory LNat
imports Prelude
begin

(* ----------------------------------------------------------------------- *)
section \<open>Type definition and the basics\<close>
(* ----------------------------------------------------------------------- *)

text \<open>
  Defined using the 'domain' command. Generates a bottom element (\<open>\<bottom>\<close>) and an order (\<open>\<sqsubseteq>\<close>),
  which are used to define zero and \<open>\<le>\<close>.
\<close>
domain lnat = lnsuc (lazy lnpred::lnat)

instantiation lnat :: "{ord, zero}"
begin
  definition lnzero_def: "(0::lnat) \<equiv> \<bottom>"
  definition lnless_def: "(m::lnat) < n \<equiv> m \<sqsubseteq> n \<and> m \<noteq> n"
  definition lnle_def:   "(m::lnat) \<le> n \<equiv> m \<sqsubseteq> n"
instance ..
end

text \<open>define @{term lntake} as an abbreviation for @{term lnat_take},
  which is generated by the \<open>domain\<close> command\<close>
abbreviation
  lntake :: "nat \<Rightarrow> lnat \<rightarrow> lnat"
    where "lntake \<equiv> lnat_take"

text \<open>eliminate double successors in @{term lntake} arguments\<close>
lemma lntake_more[simp]:
  "lntake (Suc n)\<cdot>(lnsuc\<cdot>k) = lnsuc\<cdot>(lntake n\<cdot>k)"
by (induct_tac n, auto)

(* ----------------------------------------------------------------------- *)
section \<open>Definitions\<close>
(* ----------------------------------------------------------------------- *)
text \<open>\<open>\<infinity>\<close> is the maximum of all @{term lnat}s\<close>
definition Inf'  ::  "lnat"   ("\<infinity>") where
"Inf' \<equiv> fix\<cdot>lnsuc"

text \<open>A natural number @{term n} is represented by @{term "Fin n"}\<close>
definition Fin   ::  "nat \<Rightarrow> lnat" where
"Fin k \<equiv> lntake k\<cdot>\<infinity>"

text \<open>Determine the minimum of the given two @{term lnat}s\<close>
definition lnmin ::  "lnat \<rightarrow> lnat \<rightarrow> lnat" where
"lnmin \<equiv> fix\<cdot>(\<Lambda> h. strictify\<cdot>(\<Lambda> m. strictify\<cdot>(\<Lambda> n.
                     lnsuc\<cdot>(h\<cdot>(lnpred\<cdot>m)\<cdot>(lnpred\<cdot>n)))))"

abbreviation lnatGreater :: "lnat \<Rightarrow> lnat \<Rightarrow> bool" (infix ">\<^sup>l" 65) where
"n >\<^sup>l m \<equiv>  n \<ge> lnsuc\<cdot>m"

abbreviation lnatLess :: "lnat \<Rightarrow> lnat \<Rightarrow> bool" (infix "<\<^sup>l" 65) where
"n <\<^sup>l m \<equiv>  lnsuc\<cdot>n \<le> m"

instantiation lnat :: plus
begin
  definition plus_lnat:: "lnat \<Rightarrow> lnat \<Rightarrow> lnat"  where
    "plus_lnat ln1 ln2 \<equiv> if (ln1 = \<infinity> \<or> ln2=\<infinity>) then \<infinity> else Fin ((inv Fin) ln1 + (inv Fin) ln2)"

  (*definition lnat_plus2:: "lnat \<rightarrow> lnat \<rightarrow> lnat" where
    "lnat_plus2 \<equiv> \<Lambda> ln1 ln2. (if (ln1 = \<infinity> \<or> ln2=\<infinity>) then \<infinity> else Fin ((inv Fin) ln1 + (inv Fin) ln2))"

  definition lnat_plus_moreIdiotic :: "lnat \<rightarrow> lnat \<rightarrow> lnat" where
    "lnat_plus_moreIdiotic = fix\<cdot>(\<Lambda> h. (\<Lambda> m. ( \<Lambda> n.
                           if m = 0 then n else h\<cdot>(lnpred\<cdot>m)\<cdot>(lnsuc\<cdot>n))))"*)
instance
  by(intro_classes)
end

(* ----------------------------------------------------------------------- *)
section \<open>Some basic lemmas\<close>
(* ----------------------------------------------------------------------- *)

(* ----------------------------------------------------------------------- *)
subsection
  \<open>Brief characterization of
     \<open>Fin\<close>, \<open>\<infinity>\<close>, \<open>\<le>\<close> and \<open><\<close>
\<close>
(* ----------------------------------------------------------------------- *)

text \<open>x is smaller then lnsuc x.\<close>
lemma less_lnsuc[simp]: "x \<le> lnsuc\<cdot>x"
apply (subst lnle_def)
by (rule lnat.induct [of _ x], auto)

text \<open>\<open>\<infinity>\<close> is a fix point of @{term lnsuc}\<close>
lemma fold_inf[simp]: "lnsuc\<cdot>\<infinity> = \<infinity>"
by (unfold Inf'_def, subst fix_eq2 [THEN sym], simp+)

text \<open>x is smaller then \<infinity>.\<close>
lemma inf_ub[simp]: "x \<le> \<infinity>"
apply (subst lnle_def)
apply (rule lnat.induct [of _ x], auto)
apply (subst fold_inf [THEN sym])
by (rule monofun_cfun_arg)

text \<open>0 is the bottom element.\<close>
lemma Fin_02bot: "Fin 0 = \<bottom>"
by (simp add: Fin_def)

text \<open>\<open>\<le>\<close> on lnats is antisymmetric\<close>
lemma lnat_po_eq_conv:
  "(x \<le> y \<and> y \<le> x) = ((x::lnat) = y)"
apply (auto simp add: lnle_def)
by (rule po_eq_conv [THEN iffD2], simp)

text \<open>lnsuc of x is not equal 0.\<close>
lemma lnsuc_neq_0[simp]: "lnsuc\<cdot>x \<noteq> 0"
by (simp add: lnzero_def)

text \<open>Similar to the lemma above.\<close>
lemma lnsuc_neq_0_rev[simp]: "0 \<noteq> lnsuc\<cdot>x"
by (simp add: lnzero_def)

text \<open>0 is not equal \<infinity>.\<close>
lemma Inf'_neq_0[simp]: "0 \<noteq> \<infinity>"
apply (subst fold_inf [THEN sym])
by (rule notI, simp del: fold_inf)

text \<open>Similar to the lemma above.\<close>
lemma Inf'_neq_0_rev[simp]: "\<infinity> \<noteq> 0"
by (rule notI, drule sym, simp)

text \<open>Successors are equal, so are the numbers themselves.\<close>
lemma inject_lnsuc[simp]: "(lnsuc\<cdot>x = lnsuc\<cdot>y) = (x = y)"
by (rule lnat.injects)

text \<open>Take lemma.\<close>

text \<open>A property of lnsuc.\<close>
lemma Fin_Suc[simp]: "lnsuc\<cdot>(Fin k) = Fin (Suc k)"
by (simp add: Fin_def)

text \<open>A property of 0.\<close>
lemma Fin_0[simp]: "(Fin k = 0) = (k = 0)"
apply (induct_tac k, auto simp add: lnzero_def)
by (simp add: Fin_def)+

text \<open>Injectivity of Fin.\<close>
lemma inject_Fin[simp]: "(Fin n = Fin k) = (n = k)"
apply (rule spec [of _ k], induct_tac n, auto)
by (case_tac x, auto simp add: Fin_def)+

text \<open>If a lnat cannot be reached by @{term "lnat_take"}, it behaves like \<open>\<infinity>\<close>\<close>
lemma nreach_lnat_lemma:
  "\<forall>x. (\<forall>j. lnat_take j\<cdot>x \<noteq> x) \<longrightarrow> lnat_take k\<cdot>x = lnat_take k\<cdot>\<infinity>"
apply (induct_tac k, auto)
apply (rule_tac y=x in lnat.exhaust, auto simp add: lnzero_def)
apply (erule_tac x="lnat" in allE, auto)
by (erule_tac x="Suc j" in allE, auto)

text \<open>If a lnat cannot be reached by @{term "lnat_take"}, it
  is \<open>\<infinity>\<close>.\<close>
lemma nreach_lnat:
  "(\<forall>j. lntake j\<cdot>x \<noteq> x) \<Longrightarrow> x = \<infinity>"
apply (rule lnat.take_lemma)
by (rule nreach_lnat_lemma [rule_format],simp)

text \<open>Every finite lnat can be reached by @{term lntake}\<close>
lemma nreach_lnat_rev:
  "x \<noteq> \<infinity> \<Longrightarrow> \<exists>n. lntake n\<cdot>x = x"
apply (rule ccontr, auto)
by (drule nreach_lnat, simp)

text \<open>If a lnat is reachable by @{term lntake}, it is finite\<close>
lemma exFin_take:
  "\<forall>x. lntake j\<cdot>x = x \<longrightarrow> (\<exists>k. x = Fin k)"
apply (induct_tac j, auto)
apply (rule_tac x="0" in exI,simp add: Fin_def)
apply (rule_tac y=x in lnat.exhaust, auto)
by (rule_tac x="0" in exI, simp add: Fin_def)

text \<open>If a predicate holds for both finite lnats and for \<open>\<infinity>\<close>,
  it holds for every lnat\<close>
lemma lncases:
  "\<And>x P. \<lbrakk>x = \<infinity> \<Longrightarrow> P; \<And>k. x = Fin k \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
apply (case_tac "x = \<infinity>", auto)
apply (drule nreach_lnat_rev, auto)
by (drule exFin_take [rule_format],auto)

text \<open>Only \<open>\<infinity>\<close> is greater or equal to \<open>\<infinity>\<close>\<close>
lemma inf_less_eq[simp]: "(\<infinity> \<le> x) = (x = \<infinity>)"
apply (auto, rule lnat_po_eq_conv [THEN iffD1])
by (rule conjI, auto)

text \<open>Bottom is 0.\<close>
lemma bot_is_0: "(\<bottom>::lnat) = 0"
by (simp add: lnzero_def)

text \<open>Fin k \<le> 0 holds only for k = 0.\<close>
lemma lnle_Fin_0[simp]: "(Fin k \<le> 0) = (k = 0)"
apply (simp add: lnzero_def lnle_def)
by (subst bot_is_0, simp)

text \<open>\<open>\<le>\<close> on lnats is antisymmetric\<close>
lemma less2eq: "\<lbrakk>x \<le> y; y \<le> x\<rbrakk> \<Longrightarrow> (x :: lnat) = y"
by (rule lnat_po_eq_conv [THEN iffD1], simp)

text \<open>If a number is smaller than @{term i}, its predecessor is
  also smaller than @{term i}\<close>
lemma Fin_leq_Suc_leq: "Fin (Suc n) \<le> i \<Longrightarrow> Fin n \<le> i"
apply (simp add: lnle_def)
apply (rule below_trans, auto)
apply (simp only: Fin_def)
apply (rule monofun_cfun_fun)
by (rule chainE,simp)

text \<open>\<open>\<le>\<close> on lnats and on nats\<close>
lemma less2nat_lemma: "\<forall>k. (Fin n \<le> Fin k) \<longrightarrow> (n \<le> k)"
apply (induct_tac n, auto)
apply (case_tac "n=k", simp)
apply (subgoal_tac "Fin k \<le> Fin (Suc k)")
apply (drule less2eq, auto)
apply (subst lnle_def)
apply (rule chainE)
apply (simp add: Fin_def)
apply (erule_tac x="k" in allE,auto)
by (drule Fin_leq_Suc_leq, simp)

text \<open>If Fin n \<le> Fin k then n \<le> k.\<close>
lemma less2nat[simp]: "(Fin n \<le> Fin k) = (n \<le> k)"
apply (rule iffI)
apply (rule less2nat_lemma [rule_format], assumption)
apply (simp add: lnle_def)
apply (rule chain_mono)
by (simp add: Fin_def,auto)

text \<open>lnsuc x is \<infinity> iff x is \<infinity>.\<close>
lemma [simp]: "(lnsuc\<cdot>x = \<infinity>) = (x = \<infinity>)"
apply (rule iffI)
by (rule lnat.injects [THEN iffD1], simp+)

text \<open>A finite number is not \<infinity>.\<close>
lemma Fin_neq_inf[simp]: "Fin k \<noteq> \<infinity>"
apply (induct_tac k, auto)
apply (simp add: Fin_def bot_is_0)
by (simp add: Fin_Suc [THEN sym] del: Fin_Suc)

text \<open>If lnsuc x \<le> lnsuc y then x \<le> y.\<close>
lemma lnsuc_lnle_emb[simp]:  "(lnsuc\<cdot>x \<le> lnsuc\<cdot>y) = (x \<le> y)"
apply (rule_tac x=x in lncases, simp)
by (rule_tac x=y in lncases, auto)

text \<open>0 is the smallest element.\<close>
lemma [simp]: "0 \<le> (x::lnat)"
by (simp add: lnzero_def lnle_def)

text \<open>If n \<le> 0 then n = 0.\<close>
lemma [simp]: "((n::lnat) \<le> 0) = (n = 0)"
by (rule iffI, rule_tac x=n in lncases, auto)

text \<open>If x \<sqsubseteq> y then x \<le> y.\<close>
lemma lnle_conv[simp]: "((x::lnat) \<sqsubseteq> y) = (x \<le> y)"
by (subst lnle_def,simp)

text \<open>transitivity of \<open>\<le>\<close>\<close>
lemma trans_lnle:
  "\<lbrakk>x \<le> y; y \<le> z\<rbrakk> \<Longrightarrow> (x::lnat) \<le> z"
by (subst lnle_def, rule_tac y = y in below_trans, simp+)

text \<open>reflexivity of \<open>\<le>\<close>\<close>
lemma refl_lnle[simp]: "(x::lnat) \<le> x"
by (subst lnle_def,rule below_refl)

text \<open>0 < \<infinity>.\<close>
lemma Zero_lnless_infty[simp]: "0 < \<infinity>"
by (auto simp add: lnless_def)

text \<open>Except for 0, every lnat has a predecessor\<close>
lemma gr_0[simp]: "(0 < j) = (\<exists>k. j = lnsuc\<cdot>k)"
apply (auto simp add: lnless_def)
apply (rule_tac y=j in lnat.exhaust)
by (simp add: lnzero_def, auto)

(*---*)
section \<open>Some basic lemmas on \<open><\<close>\<close>
(*---*)

text \<open>0 < lnsuc\<cdot>k\<close>
lemma [simp]: "0 < lnsuc\<cdot>k"
by (auto simp add: lnless_def)

text \<open>0 < Fin (Suc k)\<close>
lemma [simp]: "0 < Fin (Suc k)"
by (simp add: Fin_Suc [THEN sym] del: Fin_Suc)

text \<open>Fin k < \<infinity>\<close>
lemma [simp]: "Fin k < \<infinity>"
by (auto simp add: lnless_def)

text \<open>If Fin k < Fin n then k < n.\<close>
lemma [simp]: "(Fin k < Fin n) = (k < n)"
by (auto simp add: lnless_def)

lemma trans_lnless:
  "\<lbrakk>x < y; y < z\<rbrakk> \<Longrightarrow> (x::lnat) < z"
apply (auto simp add: lnless_def)
apply (rule trans_lnle, auto)
by (simp add: lnat_po_eq_conv [THEN iffD1])

text \<open>If lnsuc\<cdot>n < lnsuc\<cdot>k then n < k\<close>
lemma [simp]: "(lnsuc\<cdot>n < lnsuc\<cdot>k) = (n < k)"
by (auto simp add: lnless_def)

text \<open>lnsuc k is not smaller then 0.\<close>
lemma [simp]: "\<not> lnsuc\<cdot>k < 0"
by (simp add: lnless_def)

text \<open>\<infinity> is not smaller then anything.\<close>
lemma [simp]: "\<not> \<infinity> < i"
by (auto simp add: lnless_def)

(*---*)
section \<open>Relationship between Fin and \<open>\<infinity>\<close>\<close>
(*---*)

text \<open>Every non-infinite number is finite\<close>
lemma ninf2Fin: "x \<noteq> \<infinity> \<Longrightarrow> \<exists>k. x = Fin k"
by (rule_tac x=x in lncases, auto)

lemma assumes "ln = lnsuc\<cdot>ln"
  shows "ln = \<infinity>"
using assms ninf2Fin by force

text \<open>Every non-finite number is infinite\<close>
lemma infI: "\<forall>k. x \<noteq> Fin k \<Longrightarrow> x = \<infinity>"
by (rule lncases [of x], auto)

text \<open>Every number below @{term "Fin k"} is finite\<close>
lemma below_fin_imp_ninf: "x \<sqsubseteq> Fin k \<Longrightarrow> x \<noteq> \<infinity>"
by (rule lncases [of "x"], simp_all)

text \<open>\<open>\<infinity>\<close> is not finite\<close>
lemma [simp]: "\<infinity> \<noteq> Fin k"
by (rule notI, drule sym, simp)

text \<open>\<open>\<infinity>\<close> is strictly greater than all finite lnats\<close>
lemma [simp]: "\<not> (\<infinity> \<le> Fin k)"
by (rule notI, auto)

text \<open>An unbounded number is infinite\<close>
lemma inf_belowI: "\<forall>k. Fin k \<sqsubseteq> x \<Longrightarrow> x = \<infinity>"
proof (rule lncases [of x], simp)
  fix k assume "x = Fin k" and "\<forall>k. Fin k \<sqsubseteq> x"
  hence "Fin (Suc k) \<sqsubseteq> Fin k" by simp
  thus ?thesis by simp
qed

(* ----------------------------------------------------------------------- *)
subsection \<open>Induction rules\<close>
(* ----------------------------------------------------------------------- *)

text \<open>admissibile predicates on lnats can be proved inductively\<close>
lemma lnat_ind: "\<And>P x. \<lbrakk>adm P; P 0; \<And>l. P l \<Longrightarrow> P (lnsuc\<cdot>l)\<rbrakk> \<Longrightarrow> P x"
apply (rule lnat.induct, simp)
by (simp add: lnzero_def, auto)

(* ----------------------------------------------------------------------- *)
subsection \<open>Basic lemmas on @{term lmin}\<close>
(* ----------------------------------------------------------------------- *)

text \<open>lnmin\<cdot>0\<cdot>n = 0\<close>
lemma strict_lnmin_fst[simp]: "lnmin\<cdot>0\<cdot>n = 0"
apply (subst lnmin_def [THEN fix_eq2])
by (simp add: lnzero_def)

text \<open>lnmin\<cdot>m\<cdot>0 = 0\<close>
lemma strict_lnmin_snd[simp]: "lnmin\<cdot>m\<cdot>0 = 0"
apply (subst lnmin_def [THEN fix_eq2], auto)
apply (rule lnat.induct [of _ m], simp)
by (simp add: lnzero_def)+

text \<open>Relationship between lnmin and lnsuc.\<close>
lemma lnmin_lnsuc[simp]: "lnmin\<cdot>(lnsuc\<cdot>m)\<cdot>(lnsuc\<cdot>n) = lnsuc\<cdot>(lnmin\<cdot>m\<cdot>n)"
by (subst lnmin_def [THEN fix_eq2], simp)

text \<open>lnmin\<cdot>\<infinity>\<cdot>n = n\<close>
lemma lnmin_fst_inf[simp]: "lnmin\<cdot>\<infinity>\<cdot>n = n"
apply (rule lnat_ind [of _ n], auto)
apply (subst fold_inf [THEN sym])
by (simp del: fold_inf)

text \<open>lnmin\<cdot>m\<cdot>\<infinity> = m\<close>
lemma lnmin_snd_inf[simp]: "lnmin\<cdot>m\<cdot>\<infinity> = m"
apply (rule lnat_ind [of _ m], auto)
apply (subst fold_inf [THEN sym])
by (simp del: fold_inf)

text \<open>Fin 0 = 0\<close>
lemma [simp]: "Fin 0 = 0"
by simp

text \<open>lnmin\<cdot>(Fin j)\<cdot>(Fin k) = Fin (min j k)"\<close>
lemma lnmin_fin[simp]: "lnmin\<cdot>(Fin j)\<cdot>(Fin k) = Fin (min j k)"
apply (rule_tac x=k in spec)
apply (induct_tac j, auto)
apply (case_tac x, auto)
by (simp add: Fin_def lnzero_def)

lemma lub_mono2: "\<lbrakk>chain (X::nat\<Rightarrow>lnat); chain (Y::nat\<Rightarrow>lnat); \<And>i. X i \<le> Y i\<rbrakk>
    \<Longrightarrow> (\<Squnion>i. X i) \<le> (\<Squnion>i. Y i)"
using lnle_conv lub_mono by blast

text \<open>In an infinite chain, one can find for every element a bigger element
  in the chain\<close>
lemma inf_chainl2:
  "\<lbrakk>chain Y; \<not> finite_chain Y\<rbrakk> \<Longrightarrow> \<exists>j. Y k \<sqsubseteq> Y j \<and> Y k \<noteq> Y j"
apply (auto simp add: finite_chain_def max_in_chain_def)
apply (erule_tac x="k" in allE, auto)
apply (frule_tac i=k and j=j in chain_mono, assumption)
by (rule_tac x="j" in exI, simp)

text \<open>For constant chains, the first element is the maximum\<close>
lemma max_in_chainI2: "\<lbrakk>chain Y; \<forall>i. Y i = k\<rbrakk> \<Longrightarrow> max_in_chain 0 Y"
by (rule max_in_chainI, simp)

text \<open>In an infinite chain, there is no maximum\<close>
lemma finite_chainl1: "\<lbrakk>chain Y; \<not> finite_chain Y\<rbrakk> \<Longrightarrow> \<not> max_in_chain k Y"
apply (rule notI)
by (simp add: finite_chain_def)

text \<open>In an inifinite lnat chain, one can find for every lnat a bigger element
  in the chain\<close>
lemma inf_chainl3:
  "\<lbrakk>chain Y; \<not> finite_chain Y\<rbrakk> \<Longrightarrow> \<exists>j. (Fin k) \<sqsubseteq> Y j \<and> Fin k \<noteq> Y j"
apply (induct_tac k, simp+)
apply (case_tac "\<forall>i. Y i = \<bottom>")
apply (frule_tac k="\<bottom>" in max_in_chainI2, assumption)
apply (drule_tac k="0" in finite_chainl1, assumption, clarify)
apply (simp, erule exE)
apply (rule_tac x="i" in exI)
apply (simp add: lnzero_def)
apply (erule exE, erule conjE)
apply (frule_tac k="j" in finite_chainl1, assumption)
apply (simp add: max_in_chain_def)
apply (erule exE, erule conjE)
apply (rule_tac x="ja" in exI)
apply (rule_tac x="Y j" in lncases, simp+)
apply (drule_tac i="j" and j="ja" in chain_mono, assumption, simp+)
apply (rule_tac x="Y ja" in lncases, simp+)
by (drule_tac i="j" and j="ja" in chain_mono, assumption, simp+)

text \<open>The least upper bound of an infinite lnat chain is \<open>\<infinity>\<close>\<close>
lemma unique_inf_lub: "\<lbrakk>chain Y; \<not> finite_chain Y\<rbrakk> \<Longrightarrow> Lub Y = \<infinity>"
apply (rule ccontr, drule ninf2Fin, erule exE)
apply (frule_tac k="k" in inf_chainl3, assumption)
apply (erule exE, simp)
apply (erule conjE)
apply (drule_tac x="j" in is_ub_thelub, simp)
by (rule_tac x="Y j" in lncases, simp+)

text \<open>Every finite lnat is compact\<close>
lemma compact_Fin: "compact (Fin k)"
apply (rule compactI)
apply (rule admI)
apply (case_tac "finite_chain Y")
apply (simp add: finite_chain_def)
apply (erule exE)
apply (drule lub_finch1 [THEN lub_eqI], simp, simp)
apply (frule unique_inf_lub, assumption)
apply (subgoal_tac "range Y <| Fin k")
apply (drule_tac x="Fin k" in is_lub_thelub, simp+)
apply (rule ub_rangeI, simp)
apply (erule_tac x="i" in allE)
by (rule_tac x="Y i" in lncases, simp+)

text \<open>If the outputs of a continuous function for finite inputs are
  bounded, the output for \<open>\<infinity>\<close> has the same bound\<close>
lemma lnat_adml1[simp]: "adm (\<lambda>x. f\<cdot>x \<le> Fin n)"
apply (subst lnle_def)
apply (rule admI)
apply (subst contlub_cfun_arg, assumption)
apply (rule is_lub_thelub, rule chain_monofun, assumption)
by (rule ub_rangeI, simp)

text \<open>If a continuous function returns \<open>\<infinity>\<close> for all finite
  inputs, it also returns \<open>\<infinity>\<close> for input \<open>\<infinity>\<close>\<close>
lemma lnat_adnl2[simp]: "adm (\<lambda>x. f\<cdot>x = \<infinity>)"
apply (rule admI)
apply (subst contlub_cfun_arg, assumption)
apply (rule po_eq_conv [THEN iffD2])
apply (rule conjI)
apply (rule is_lub_thelub, rule chain_monofun, assumption)
apply (rule ub_rangeI, simp)
apply (erule_tac x="SOME x. True" in allE)
apply (drule sym, erule ssubst)
by (rule is_ub_thelub, rule chain_monofun)

text \<open>l \<le> Fin k \<Longrightarrow> l \<noteq> \<infinity>\<close>
lemma notinfI3: "l \<le> Fin k \<Longrightarrow> l \<noteq> \<infinity>"
by (rule_tac x="l" in lncases, simp+)

text \<open>Lifting to discrete cpo\<close>

definition lnsucu ::"lnat u \<rightarrow> lnat u" where
"lnsucu \<equiv> strictify\<cdot>(\<Lambda> n. up\<cdot>(fup\<cdot>lnsuc\<cdot>n))"

definition upinf  ::"lnat u" (* ("\<infinity>\<^isub>u") *) where
"upinf \<equiv> up\<cdot>\<infinity>"

text \<open>lnsucu\<cdot>\<bottom> = \<bottom>\<close>
lemma [simp]: "lnsucu\<cdot>\<bottom> = \<bottom>"
by (simp add: lnsucu_def)

text \<open>lnsucu\<cdot>(up\<cdot>(Fin n)) = up\<cdot>(Fin (Suc n))\<close>
lemma [simp]: "lnsucu\<cdot>(up\<cdot>(Fin n)) = up\<cdot>(Fin (Suc n))"
by (simp add: lnsucu_def)

text \<open>lnsucu\<cdot>(upinf) = upinf\<close>
lemma [simp]: "lnsucu\<cdot>(upinf) = upinf"
by (simp add: lnsucu_def upinf_def)

text \<open>We prove the cases lemma for the lifted lnat u\<close>
lemma lnatu_cases:
  "\<And>n P. \<lbrakk>n = upinf \<Longrightarrow> P; \<And>k. n = up\<cdot>(Fin k) \<Longrightarrow> P; n = \<bottom> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
apply (erule upE, auto simp add: upinf_def)
by (rule_tac x="x" in lncases, auto)

text \<open>up\<cdot>(Fin k) \<noteq> upinf\<close>
lemma [simp]: "up\<cdot>(Fin k) \<noteq> upinf"
by (simp add: upinf_def)

text \<open>up\<cdot>(Fin k) \<noteq> \<bottom>\<close>
lemma [simp]: "up\<cdot>(Fin k) \<noteq> \<bottom>"
by simp

text \<open>upinf \<noteq> \<bottom>\<close>
lemma [simp]: "upinf \<noteq> \<bottom>"
by (simp add: upinf_def)

text \<open>lnsucu\<cdot>lu \<noteq> up\<cdot>0\<close>
lemma [simp]: "lnsucu\<cdot>lu \<noteq> up\<cdot>0"
apply (rule_tac n="lu" in lnatu_cases)
apply (auto simp add: upinf_def)
by (simp add: lnsucu_def)

text \<open>(lnsucu\<cdot>l = up\<cdot>(Fin (Suc n))) = (l = up\<cdot>(Fin n))\<close>
lemma [simp]: "(lnsucu\<cdot>l = up\<cdot>(Fin (Suc n))) = (l = up\<cdot>(Fin n))"
apply (rule_tac n="l" in lnatu_cases)
apply (simp add: upinf_def)
by (auto simp add: lnsucu_def)

text \<open>(lnsuc\<cdot>n = Fin (Suc k)) = (n = Fin k)\<close>
lemma [simp]: "(lnsuc\<cdot>n = Fin (Suc k)) = (n = Fin k)"
by (simp add: Fin_Suc [THEN sym] del: Fin_Suc)

text \<open>(lnsuc\<cdot>n \<le> Fin (Suc k)) = (n \<le> Fin k)\<close>
lemma [simp]: "(lnsuc\<cdot>n \<le> Fin (Suc k)) = (n \<le> Fin k)"
by (simp add: Fin_Suc [THEN sym] del: Fin_Suc)

text \<open>(lnsuc\<cdot>n < Fin (Suc k)) = (n < Fin k)\<close>
lemma [simp]: "(lnsuc\<cdot>n < Fin (Suc k)) = (n < Fin k)"
by (simp add: Fin_Suc [THEN sym] del: Fin_Suc)

text \<open>(Fin (Suc n) \<le> lnsuc\<cdot>l) = (Fin n \<le> l)\<close>
lemma [simp]: "(Fin (Suc n) \<le> lnsuc\<cdot>l) = (Fin n \<le> l)"
by (simp add: Fin_Suc [THEN sym] del: Fin_Suc)

text \<open>(Fin (Suc n) < lnsuc\<cdot>l) = (Fin n < l)\<close>
lemma [simp]: "(Fin (Suc n) < lnsuc\<cdot>l) = (Fin n < l)"
by (simp add: Fin_Suc [THEN sym] del: Fin_Suc)

text \<open>\<not> Fin (Suc n) < 0\<close>
lemma [simp]: "\<not> Fin (Suc n) < 0"
by (simp add: Fin_Suc [THEN sym] del: Fin_Suc)

text \<open>\<not> Fin (Suc n) \<le> 0\<close>
lemma [simp]: "\<not> Fin (Suc n) \<le> 0"
by (simp add: Fin_Suc [THEN sym] del: Fin_Suc)

text \<open>\<exists>x. Fin x < 0 \<Longrightarrow> False\<close>
lemma [simp]: "\<exists>x. Fin x < 0 \<Longrightarrow> False"
by (simp add: lnless_def)

text \<open>l \<noteq> 0 \<Longrightarrow> Fin (Suc 0) \<le> l\<close>
lemma neq02Suclnle: "l \<noteq> 0 \<Longrightarrow> Fin (Suc 0) \<le> l"
by (rule_tac x="l" in lncases, simp+)

text \<open>(Fin k) < y \<Longrightarrow> Fin (Suc k) \<le> y\<close>
lemma less2lnleD: "(Fin k) < y \<Longrightarrow> Fin (Suc k) \<le> y"
by (rule_tac x="y" in lncases, simp+)

(* ----------------------------------------------------------------------- *)
subsection \<open>Basic lemmas on @{term lmin}\<close>
(* ----------------------------------------------------------------------- *)

text\<open>Instanciate lnat as a linorder to use min/max\<close>
instantiation lnat :: linorder
begin
  instance
  apply(intro_classes)
  using lnat_po_eq_conv lnle_def lnless_def apply blast
  apply simp
  using trans_lnle apply blast
  using lnat_po_eq_conv apply blast
  by (metis inf_ub less2nat linear ninf2Fin)
end

text\<open>A lazy natural number is smaller than its successor\<close>
lemma ln_less[simp]: assumes "ln<\<infinity>"
  shows "ln < lnsuc\<cdot>ln"
proof -
  have "ln \<le> lnsuc\<cdot>ln" by simp
  obtain n where "Fin n = ln" by (metis assms dual_order.strict_implies_not_eq infI)
  have "Fin n < Fin (Suc n)" by force
  thus ?thesis using \<open>Fin n = ln\<close> by auto
qed

lemma lnle2le: "m < lnsuc\<cdot>n \<Longrightarrow> m \<le> n"
  apply (case_tac "m=\<infinity>", auto)
  by (metis Fin_Suc less2lnleD lncases lnsuc_lnle_emb)

lemma le2lnle: "m < \<infinity> \<Longrightarrow> lnsuc\<cdot>m \<le> n \<Longrightarrow> m < n"
  by (metis dual_order.strict_iff_order dual_order.trans leD ln_less)

(*few lemmas to simp min*)
text\<open>\<infinity> is greater than or equal to any lazy natural number\<close>
lemma [simp]: fixes ln :: lnat
  shows "min \<infinity> ln = ln"
by (simp add: min_def)

lemma [simp]: fixes ln :: lnat
  shows "min ln \<infinity> = ln"
by (simp add: min_def)

text\<open>0 is less than or equal to any lazy natural number\<close>
lemma [simp]: fixes ln :: lnat
  shows "min ln 0 = 0"
by (simp add: min_def)

lemma [simp]: fixes ln :: lnat
  shows "min 0 ln = 0"
by (simp add: min_def)

lemma min_rek: assumes  "z = min x (lnsuc\<cdot>z)"
  shows "z = x"
  apply(rule ccontr, cases "x < z")
   apply (metis assms dual_order.irrefl min_less_iff_conj)
  by (metis assms inf_ub ln_less lnle_def lnless_def min_def)

lemma lnat_well_h1:
  "[| n < Fin m; \<And>k. n = Fin k ==> k < m ==> P |] ==> P"
by (metis less2nat less_le lncases notinfI3)

lemma lnat_well_h2:
  "[| n < \<infinity>; \<And>k. n = Fin k ==> P |] ==> P"
using lncases by auto

lemma lnat_well:
  assumes prem: "\<And>n. \<forall>m::lnat. m < n --> P m ==> P n" shows "P n"
proof -
  have P_lnat: "\<And>k. P (Fin k)"
    apply (rule nat_less_induct)
    apply (rule prem, clarify)
    apply (erule lnat_well_h1, simp)
    done
  show ?thesis
  proof (induct n)
    next show "adm P" by (metis P_lnat adm_upward inf_ub lnat_well_h2 less_le_trans prem)
    next show "P \<bottom>" by (metis Fin_02bot P_lnat)
    then show "\<And>n. P n \<Longrightarrow> P (lnsuc\<cdot>n)" by (metis Fin_Suc P_lnat lncases)
  qed
qed

instance lnat :: wellorder
proof
  fix P and n
  assume hyp: "(\<And>n::lnat. (\<And>m::lnat. m < n ==> P m) ==> P n)"
  show "P n" by (blast intro: lnat_well hyp)
qed

(* ----------------------------------------------------------------------- *)
subsection \<open>Basic lemmas on @{term lnat_plus}\<close>
(* ----------------------------------------------------------------------- *)

text \<open>Plus on nats behaves the same as on lnats.\<close>
lemma lnat_plus_fin [simp]: "(Fin n) + (Fin m) = Fin (n + m)"
  apply(simp add: plus_lnat_def)
  by (metis UNIV_I f_inv_into_f image_eqI inject_Fin)

text \<open>0 + 0 = 0.\<close>
lemma plus_lnat0_0:"Fin 0 + Fin 0 = Fin 0"
  apply(simp add: plus_lnat_def)
  apply(simp add: Fin_def inv_def)
  apply(rule_tac someI_ex)
  using Fin_def lnle_Fin_0 by auto

text \<open>0 is a right neutral element of + on lnats.\<close>
lemma plus_lnat0_r[simp]:"(0::lnat) + n = n"
  apply(simp add: plus_lnat_def)
  by (metis Fin_0 Inf'_neq_0_rev add_cancel_right_left plus_lnat_def lnat_plus_fin ninf2Fin)

text \<open>0 is a left neutral element of + on lnats.\<close>
lemma plus_lnat0_l:"m + (0::lnat) = m"
  apply(simp add: plus_lnat_def)
  by (metis (mono_tags, lifting) Fin_0 UNIV_I add.right_neutral f_inv_into_f image_eqI plus_lnat_def plus_lnat0_r)

text \<open>m + \<infinity> = \<infinity>.\<close>
lemma plus_lnatInf_l[simp]:"m + \<infinity> = \<infinity>"
  by(simp add: plus_lnat_def)

text \<open>\<infinity> + n = \<infinity>.\<close>
lemma plus_lnatInf_r:"\<infinity> + n = \<infinity>"
  by(simp add: plus_lnat_def)

text \<open>+ on lnats is commutative.\<close>
lemma lnat_plus_commu:"(ln1::lnat) + ln2 = ln2 + ln1"
  by(simp add: plus_lnat_def)

text \<open>+ is associative.\<close>
instance lnat:: semigroup_add
  apply(intro_classes)
  apply(simp add: plus_lnat_def)
  by (smt add.left_commute f_inv_into_f inject_Fin natl2 rangeI)

text\<open>+ is commutative.\<close>
instance lnat:: ab_semigroup_add
  apply(intro_classes)
  by (simp add: lnat_plus_commu)

text\<open>+ is zero neutral.\<close>
instance lnat:: monoid_add
  apply(intro_classes)
  apply (simp)
  by (simp add: plus_lnat0_l)

text\<open>Define a 1 element in lnat.\<close>
instantiation lnat :: one
begin
definition one_lnat:: "lnat" where
  "one_lnat = Fin 1"

  instance ..
end

text\<open>This 1 element is the successor of 0.\<close>
lemma one_def: "1 = lnsuc\<cdot>0"
   by (metis Fin_02bot Fin_Suc One_nat_def lnzero_def one_lnat_def)

lemma lnat_1_inf [simp]: "1 < \<infinity>"
  unfolding one_lnat_def
  by simp

text\<open>Adding 1 to an lnat ln1 yields the same result as the successor of ln1.\<close>
lemma lnat_plus_suc: "ln1 + 1 = lnsuc\<cdot>ln1"
  apply(simp add: plus_lnat_def)
  by (metis Fin_Suc Inf'_neq_0_rev One_nat_def Suc_def2 f_inv_into_f fold_inf inf_ub inject_Fin inject_lnsuc less_le lnat_well_h2 one_def one_lnat_def rangeI)

text\<open>Applying lnsuc to the first or second element of the addition yields the same result.\<close>
lemma lnat_plus_lnsuc: "ln1 + (lnsuc\<cdot>ln2) = (lnsuc\<cdot>ln1) + ln2"
  apply(simp add: plus_lnat_def)
  proof -
    have f1: "\<And>f n. f (inv f (f (n::nat)::lnat)) = f n"
      by (simp add: f_inv_into_f)
    have "\<And>l. Fin (inv Fin l) = l \<or> \<infinity> = l"
      by (metis (no_types) f_inv_into_f ninf2Fin rangeI)
    then have f2: "\<And>l. inv Fin (lnsuc\<cdot>l) = Suc (inv Fin l) \<or> \<infinity> = l"
      using f1 by (metis (no_types) Fin_Suc inject_Fin)
    then have "\<And>n l. n + inv Fin (lnsuc\<cdot>l) = inv Fin l + Suc n \<or> \<infinity> = l"
      by simp
    then show "ln1 \<noteq> \<infinity> \<and> ln2 \<noteq> \<infinity> \<longrightarrow> inv Fin ln1 + inv Fin (lnsuc\<cdot>ln2) = inv Fin (lnsuc\<cdot>ln1) + inv Fin ln2"
      using f2 by (metis (no_types) natl2)
  qed

lemma min_adm[simp]: fixes y::lnat
  shows "adm (\<lambda>x. min y (g\<cdot>x) \<sqsubseteq> h\<cdot>x)"
proof (rule admI)
  fix Y
  assume Y_ch: "chain Y"  and as: "\<forall>i. min y (g\<cdot>(Y i)) \<sqsubseteq> h\<cdot>(Y i)"
  have h1:"finite_chain Y \<Longrightarrow> min y (g\<cdot>(\<Squnion>i. Y i)) \<sqsubseteq> h\<cdot>(\<Squnion>i. Y i)"
    using Y_ch as l42 by force
  have "\<not>finite_chain Y \<Longrightarrow> min y (g\<cdot>(\<Squnion>i. Y i)) \<sqsubseteq> h\<cdot>(\<Squnion>i. Y i)"
  proof (cases "g\<cdot>(\<Squnion>i. Y i) \<sqsubseteq> y")
    case True
    hence "\<And>i. g\<cdot>(Y i) \<sqsubseteq> y"
      using Y_ch is_ub_thelub monofun_cfun_arg rev_below_trans by blast
    then show ?thesis
      by (metis (no_types, lifting) Y_ch as ch2ch_Rep_cfunR contlub_cfun_arg lnle_conv lub_below_iff lub_mono min_absorb2)
  next
    case False
    then show ?thesis
      by (metis Y_ch as below_lub ch2ch_Rep_cfunR contlub_cfun_arg lnle_conv lub_below min.commute min_def)
  qed
  thus "min y (g\<cdot>(\<Squnion>i. Y i)) \<sqsubseteq> h\<cdot>(\<Squnion>i. Y i)"
    using h1 by blast
qed

lemma min_adm2[simp]: fixes y::lnat
  shows "adm (\<lambda>x. min (g\<cdot>x) y \<sqsubseteq> h\<cdot>x)"
  apply(subst min.commute)
  using min_adm by blast

lemma lub_sml_eq:"\<lbrakk>chain (Y::nat\<Rightarrow>lnat); \<And>i. x \<le> Y i\<rbrakk> \<Longrightarrow> x \<le> (\<Squnion>i. Y i)"
  using l42 unique_inf_lub by force

text\<open>The lub of a chain in minimum is the minimum of the lub.\<close>
lemma min_lub:" chain Y \<Longrightarrow> (\<Squnion>i::nat. min (x::lnat) (Y i)) = min (x) (\<Squnion>i::nat. (Y i))"
  apply (case_tac "x=\<infinity>", simp_all)
  apply (case_tac "finite_chain Y")
proof -
  assume a1: "chain Y"
  assume a2: "finite_chain Y"
  then have "monofun (min x)"
    by (metis (mono_tags, lifting) lnle_conv min.idem min.semilattice_order_axioms monofunI
        semilattice_order.mono semilattice_order.orderI)
  then show ?thesis
    using a2 a1 by (metis (no_types) finite_chain_lub)
next
  assume a0:"chain Y"
  assume a1:"\<not> finite_chain Y"
  assume a2:"x \<noteq> \<infinity>"
  have h0:"\<forall>i. \<exists>j\<ge>i. Y i \<sqsubseteq> Y j"
  by blast
  then have"(\<Squnion>i. min x (Y i)) = x"
  proof -
    have f1: "\<And>n. min x (Y n) \<sqsubseteq> x"
      by (metis (lifting) lnle_def min.bounded_iff order_refl)
    then have f2: "\<And>n. min x (Y n) = x \<or> Y n \<sqsubseteq> x"
      by (metis (lifting) min_def)
    have f3: "\<infinity> \<notsqsubseteq> x"
      by (metis (lifting) a2 inf_less_eq lnle_def)
    have "Lub Y = \<infinity>"
      by (meson a0 a1 unique_inf_lub)
    then obtain nn :: "(nat \<Rightarrow> lnat) \<Rightarrow> lnat \<Rightarrow> nat" where
      f4: "min x (Y (nn Y x)) = x \<or> \<infinity> \<sqsubseteq> x"
      using f2 by (metis (no_types) a0 lub_below_iff)
    have "\<forall>f n. \<exists>na. (f (na::nat)::lnat) \<notsqsubseteq> f n \<or> Lub f = f n"
      by (metis lub_chain_maxelem)
    then show ?thesis
      using f4 f3 f1 by (metis (full_types))
    qed
  then show ?thesis
    by (simp add: a0 a1 unique_inf_lub)
qed

text\<open>Reversed Version of min_lub: The minimum of the lub is the lub of a chain in a minimum.\<close>
lemma min_lub_rev:"chain Y \<Longrightarrow>  min (x) (\<Squnion>i::nat. (Y i)) = (\<Squnion>i::nat. min (x::lnat) (Y i)) "
  using min_lub by auto

text\<open>\<le> relation between two chains in a minimum is as well preserved by their lubs.\<close>
lemma lub_min_mono: "\<lbrakk>chain (X::nat\<Rightarrow>lnat); chain (Y::nat\<Rightarrow>lnat); \<And>i. min x (X i) \<le> Y i\<rbrakk>
    \<Longrightarrow> min x (\<Squnion>i. X i) \<le> (\<Squnion>i. Y i)"
  by (metis dual_order.trans is_ub_thelub lnle_def lub_mono2 min_le_iff_disj)

text\<open>Twisted version of lub_min_mono: \<le> rel. between two chains in minimum is preserved by lubs.\<close>
lemma lub_min_mono2: "\<lbrakk>chain (X::nat\<Rightarrow>lnat); chain (Y::nat\<Rightarrow>lnat); \<And>i. min (X i) y \<le> Y i\<rbrakk>
    \<Longrightarrow> min (\<Squnion>i. X i) y \<le> (\<Squnion>i. Y i)"
  by (metis dual_order.trans is_ub_thelub lnle_def lub_mono2 min_le_iff_disj)

lemma lessequal_addition: assumes "a \<le> b" and "c \<le> d" shows "a + c \<le> b + (d :: lnat)"
proof -
  have "b = \<infinity> \<Longrightarrow> a + c \<le> b + d"
    by (simp add: plus_lnatInf_r)
  moreover
  have "d = \<infinity> \<Longrightarrow> a + c \<le> b + d"
    by (simp add: plus_lnatInf_r)
  moreover
  have "a = \<infinity> \<Longrightarrow> a + c \<le> b + d"
    using assms(1) plus_lnatInf_r by auto
  moreover
  have "c = \<infinity> \<Longrightarrow> a + c \<le> b + d"
    using assms(2) plus_lnatInf_r by auto
  moreover
  have "a \<noteq> \<infinity> \<Longrightarrow> b \<noteq> \<infinity> \<Longrightarrow> c \<noteq> \<infinity> \<Longrightarrow> d \<noteq> \<infinity> \<Longrightarrow> a + c \<le> b + d"
  proof -
    assume "a \<noteq> \<infinity>"
    then obtain m where m_def: "Fin m = a"
      using infI by force
    assume "b \<noteq> \<infinity>"
    then obtain n where n_def: "Fin n = b"
      using infI by force
    assume "c \<noteq> \<infinity>"
    then obtain x where x_def: "Fin x = c"
      using infI by force
    assume "d \<noteq> \<infinity>"
    then obtain y where y_def: "Fin y = d"
      using infI by force
    show ?thesis
      using assms m_def n_def x_def y_def by auto
    qed
  then show "a + c \<le> b + d"
    using calculation by blast
qed

lemma lnmin_eqasmthmin: assumes "a = b" and "a \<le> c" shows "a = lnmin\<cdot>b\<cdot>c"
proof -
  have "a = \<infinity> \<Longrightarrow> a = lnmin\<cdot>b\<cdot>c"
    using assms by auto
  moreover
  have "b = \<infinity> \<Longrightarrow> a = lnmin\<cdot>b\<cdot>c"
    using assms by auto
  moreover
  have "c = \<infinity> \<Longrightarrow> a = lnmin\<cdot>b\<cdot>c"
    using assms by auto
  moreover
  have "a \<noteq> \<infinity> \<Longrightarrow> b \<noteq> \<infinity> \<Longrightarrow> c \<noteq> \<infinity> \<Longrightarrow>  a = lnmin\<cdot>b\<cdot>c"
    by (metis assms less2nat lncases lnmin_fin min.order_iff)

  then show ?thesis
    using calculation by blast
qed

lemma lnmin_asso: "lnmin\<cdot>x\<cdot>y = lnmin\<cdot>y\<cdot>x"
proof -
  have "x = \<infinity> \<Longrightarrow> lnmin\<cdot>x\<cdot>y = lnmin\<cdot>y\<cdot>x"
    by simp
  moreover
  have "y = \<infinity> \<Longrightarrow> lnmin\<cdot>x\<cdot>y = lnmin\<cdot>y\<cdot>x"
    by simp
  moreover
  have "x \<noteq> \<infinity> \<Longrightarrow> y \<noteq> \<infinity> \<Longrightarrow> lnmin\<cdot>x\<cdot>y = lnmin\<cdot>y\<cdot>x"
    by (metis (full_types) lncases lnmin_fin min.commute)
  then show ?thesis
    using calculation by blast
qed

lemma lnmin_smaller_addition: "lnmin\<cdot>x\<cdot>y \<le> x + y"
proof -
  have "x = \<infinity> \<Longrightarrow> lnmin\<cdot>x\<cdot>y \<le> x + y"
    by (simp add: plus_lnatInf_r)
  moreover
  have "y = \<infinity> \<Longrightarrow> lnmin\<cdot>x\<cdot>y \<le> x + y"
    by simp
  moreover
  have "x \<noteq> \<infinity> \<Longrightarrow> y \<noteq> \<infinity> \<Longrightarrow> lnmin\<cdot>x\<cdot>y \<le> x + y"
    by (metis bot_is_0 lessequal_addition linear lnle_def lnmin_asso lnmin_eqasmthmin minimal plus_lnat0_l)
  then show ?thesis
    using calculation by blast
qed

lemma lnat_no_chain: fixes Y:: " nat \<Rightarrow> lnat"
  assumes "range Y = UNIV"
  shows "\<not>chain Y"
proof (rule ccontr)
  assume "\<not>\<not>chain Y"
  obtain i where "Y i = \<infinity>"
    by (metis assms surj_def)
  hence "max_in_chain i Y"
    by (metis \<open>\<not>\<not>chain Y\<close> inf_less_eq is_ub_thelub lnle_conv max_in_chainI3)
  hence "finite (range Y)"
    using Prelude.finite_chainI \<open>\<not> \<not> chain Y\<close> finch_imp_finite_range by blast
  thus False
    by (metis (mono_tags, hide_lams) Fin_neq_inf assms ex_new_if_finite  finite_imageI infinite_UNIV_nat inject_Fin lncases rangeI)
qed

text \<open>If the left summand is smaller then {@term \<infinity>}, then the right summand is unqiuely
        determined by the result of {@term +}\<close>
lemma plus_unique_r:
  fixes "l"
  assumes "m < \<infinity>"
  and "(l::lnat) = m + n"
  and "(l::lnat) = m + p"
shows "n = p"
  using assms apply(induction l, simp_all)
  apply (smt add_left_imp_eq fold_inf inject_Fin less_lnsuc lnat.sel_rews(2) lnat_plus_suc neq_iff notinfI3 plus_lnat_def triv_admI)
  using assms apply(induction m, simp_all)
  apply (simp_all add: bot_is_0)
  apply (smt add.left_commute lnat_plus_commu plus_lnat0_l triv_admI)
  apply (metis add.left_commute plus_lnat0_l)
  apply (case_tac "l = \<infinity>")
  apply simp_all
proof -
  fix la :: lnat
  assume a1: "m + n \<noteq> \<infinity>"
  assume a2: "m + p = m + n"
  have f3: "n = 0 + n"
  by auto
  have f4: "\<forall>l la. if l = \<infinity> \<or> la = \<infinity> then l + la = \<infinity> else l + la = Fin (inv Fin l + inv Fin la)"
  using plus_lnat_def by presburger
    have f5: "0 \<noteq> \<infinity> \<and> n \<noteq> \<infinity>"
      using a1 by force
    have f6: "m \<noteq> \<infinity> \<and> p \<noteq> \<infinity>"
      using f4 a2 a1 by metis
    then have f7: "Fin (inv Fin m + inv Fin p) = m + n"
      using f4 a2 by simp
    have "m \<noteq> \<infinity> \<and> n \<noteq> \<infinity>"
      using f4 a1 by fastforce
    then have "inv Fin p = inv Fin n"
      using f7 f4 by simp
    then have "n = 0 + p"
      using f6 f5 f4 f3 by presburger
    then show ?thesis
  by auto
qed

text \<open>If the right summand is smaller then {@term \<infinity>}, then the left summand is unqiuely
        determined by the result of {@term +}\<close>
lemma plus_unique_l:
  fixes "l"
  assumes "m < \<infinity>"
  and "(l::lnat) = n + m"
  and "(l::lnat) = p + m"
shows "n = p"
  using assms plus_unique_r
  by (metis lnat_plus_commu)

text\<open>Declares Fin and {@term \<infinity>} as constructors for lnat. This is useful for patterns that use constructors\<close>
setup \<open>Sign.mandatory_path "SBv3"\<close>
old_rep_datatype Fin Inf'
  apply (metis ninf2Fin)
  by simp+

end