(*  Author:     Tobias Nipkow, 2007

A simple certificate based checker for q-free dlo formulae.
Certificate is cycle.
*)

theory CertDlo
imports QEdlo
begin

fun cyclerec :: "nat \<Rightarrow> nat \<Rightarrow> atom list \<Rightarrow> bool" where
"cyclerec i j [] = (i=j)" |
"cyclerec i j (Less m n # fs) = (j=m & cyclerec i n fs)" |
"cyclerec i j (Eq m n # fs) = (if j=m then cyclerec i n fs
                               else if j=n then cyclerec i m fs else False)"

definition cycle :: "atom list \<Rightarrow> nat list \<Rightarrow> bool" where
"cycle fs is =
 ((\<forall>i\<in>set is. i < length fs) \<and>
  (case map (nth fs) is of Less i j # fs' \<Rightarrow> cyclerec i j fs' | _ \<Rightarrow> False))"

definition
"cyclic_dnf ass = (EX iss. list_all2 cycle ass iss)"

lemma refute_I:
  "~ Logic.interpret h (Neg f) e \<Longrightarrow> Logic.interpret h f e"
by simp

lemma cyclerecD: fixes xs :: "'a :: dlo list" shows
 "\<lbrakk> cyclerec i j as; xs!i < xs!j\<rbrakk> \<Longrightarrow> \<exists>a\<in>set as. \<not> I\<^sub>d\<^sub>l\<^sub>o a xs"
apply(induct as arbitrary: j)
 apply (simp)
apply(case_tac a)
apply(auto split:split_if_asm)
done

lemma cycleD: fixes xs :: "'a :: dlo list" shows
 "cycle as is \<Longrightarrow> \<not> DLO.I (list_conj (map Atom as)) xs"
apply rule
apply (simp add:cycle_def map_eq_Cons_conv split:list.splits atom.splits)
apply auto
apply(drule_tac xs = xs in cyclerecD)
apply(drule_tac x = "as!z" in bspec)
apply (erule nth_mem)
apply fastforce
apply fastforce
done

lemma cyclic_dnfD: "qfree f \<Longrightarrow> cyclic_dnf (dnf(DLO.nnf f)) \<Longrightarrow> ~DLO.I f xs"
apply(subst DLO.I_nnf[unfolded nnf_def, symmetric])
apply(subst DLO.I_dnf[symmetric])
apply(erule DLO.nqfree_nnf[unfolded nnf_def])
apply(auto simp add:cyclic_dnf_def list_all2_iff in_set_conv_nth)
apply(drule_tac x="(dnf(DLO.nnf f) ! i, iss!i)" in bspec)
apply (auto simp:set_zip)
apply(drule_tac xs=xs in cycleD)
apply auto
done

end


theory PositionsExt
  imports "SpecExt" "LexerExt"
begin

section {* Positions in Values *}

fun
  at :: "val \<Rightarrow> nat list \<Rightarrow> val"
where
  "at v [] = v"
| "at (Left v) (0#ps)= at v ps"
| "at (Right v) (Suc 0#ps)= at v ps"
| "at (Seq v1 v2) (0#ps)= at v1 ps"
| "at (Seq v1 v2) (Suc 0#ps)= at v2 ps"
| "at (Stars vs) (n#ps)= at (nth vs n) ps"

fun Pos :: "val \<Rightarrow> (nat list) set"
where
  "Pos (Void) = {[]}"
| "Pos (Char c) = {[]}"
| "Pos (Left v) = {[]} \<union> {0#ps | ps. ps \<in> Pos v}"
| "Pos (Right v) = {[]} \<union> {1#ps | ps. ps \<in> Pos v}"
| "Pos (Seq v1 v2) = {[]} \<union> {0#ps | ps. ps \<in> Pos v1} \<union> {1#ps | ps. ps \<in> Pos v2}"
| "Pos (Stars []) = {[]}"
| "Pos (Stars (v#vs)) = {[]} \<union> {0#ps | ps. ps \<in> Pos v} \<union> {Suc n#ps | n ps. n#ps \<in> Pos (Stars vs)}"

lemma Pos_stars:
  "Pos (Stars vs) = {[]} \<union> (\<Union>n < length vs. {n#ps | ps. ps \<in> Pos (vs ! n)})"
apply(induct vs)
apply(auto simp add: insert_ident less_Suc_eq_0_disj)
done

lemma Pos_empty:
  shows "[] \<in> Pos v"
by (induct v rule: Pos.induct)(auto)

abbreviation
  "intlen vs \<equiv> int (length vs)"

definition pflat_len :: "val \<Rightarrow> nat list => int"
where
  "pflat_len v p \<equiv> (if p \<in> Pos v then intlen (flat (at v p)) else -1)"

lemma pflat_len_simps:
  shows "pflat_len (Seq v1 v2) (0#p) = pflat_len v1 p"
  and   "pflat_len (Seq v1 v2) (Suc 0#p) = pflat_len v2 p"
  and   "pflat_len (Left v) (0#p) = pflat_len v p"
  and   "pflat_len (Left v) (Suc 0#p) = -1"
  and   "pflat_len (Right v) (Suc 0#p) = pflat_len v p"
  and   "pflat_len (Right v) (0#p) = -1"
  and   "pflat_len (Stars (v#vs)) (Suc n#p) = pflat_len (Stars vs) (n#p)"
  and   "pflat_len (Stars (v#vs)) (0#p) = pflat_len v p"
  and   "pflat_len v [] = intlen (flat v)"
by (auto simp add: pflat_len_def Pos_empty)

lemma pflat_len_Stars_simps:
  assumes "n < length vs"
  shows "pflat_len (Stars vs) (n#p) = pflat_len (vs!n) p"
using assms
apply(induct vs arbitrary: n p)
apply(auto simp add: less_Suc_eq_0_disj pflat_len_simps)
done

lemma pflat_len_outside:
  assumes "p \<notin> Pos v1"
  shows "pflat_len v1 p = -1 "
using assms by (simp add: pflat_len_def)

section {* Orderings *}

definition prefix_list:: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" ("_ \<sqsubseteq>pre _" [60,59] 60)
where
  "ps1 \<sqsubseteq>pre ps2 \<equiv> \<exists>ps'. ps1 @ps' = ps2"

definition sprefix_list:: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" ("_ \<sqsubset>spre _" [60,59] 60)
where
  "ps1 \<sqsubset>spre ps2 \<equiv> ps1 \<sqsubseteq>pre ps2 \<and> ps1 \<noteq> ps2"

inductive lex_list :: "nat list \<Rightarrow> nat list \<Rightarrow> bool" ("_ \<sqsubset>lex _" [60,59] 60)
where
  "[] \<sqsubset>lex (p#ps)"
| "ps1 \<sqsubset>lex ps2 \<Longrightarrow> (p#ps1) \<sqsubset>lex (p#ps2)"
| "p1 < p2 \<Longrightarrow> (p1#ps1) \<sqsubset>lex (p2#ps2)"

lemma lex_irrfl:
  fixes ps1 ps2 :: "nat list"
  assumes "ps1 \<sqsubset>lex ps2"
  shows "ps1 \<noteq> ps2"
using assms
by(induct rule: lex_list.induct)(auto)

lemma lex_simps [simp]:
  fixes xs ys :: "nat list"
  shows "[] \<sqsubset>lex ys \<longleftrightarrow> ys \<noteq> []"
  and   "xs \<sqsubset>lex [] \<longleftrightarrow> False"
  and   "(x # xs) \<sqsubset>lex (y # ys) \<longleftrightarrow> (x < y \<or> (x = y \<and> xs \<sqsubset>lex ys))"
by (auto simp add: neq_Nil_conv elim: lex_list.cases intro: lex_list.intros)

lemma lex_trans:
  fixes ps1 ps2 ps3 :: "nat list"
  assumes "ps1 \<sqsubset>lex ps2" "ps2 \<sqsubset>lex ps3"
  shows "ps1 \<sqsubset>lex ps3"
using assms
by (induct arbitrary: ps3 rule: lex_list.induct)
   (auto elim: lex_list.cases)

lemma lex_trichotomous:
  fixes p q :: "nat list"
  shows "p = q \<or> p \<sqsubset>lex q \<or> q \<sqsubset>lex p"
apply(induct p arbitrary: q)
apply(auto elim: lex_list.cases)
apply(case_tac q)
apply(auto)
done

section {* POSIX Ordering of Values According to Okui \& Suzuki *}

definition PosOrd:: "val \<Rightarrow> nat list \<Rightarrow> val \<Rightarrow> bool" ("_ \<sqsubset>val _ _" [60, 60, 59] 60)
where
  "v1 \<sqsubset>val p v2 \<equiv> pflat_len v1 p > pflat_len v2 p \<and>
                   (\<forall>q \<in> Pos v1 \<union> Pos v2. q \<sqsubset>lex p \<longrightarrow> pflat_len v1 q = pflat_len v2 q)"

lemma PosOrd_def2:
  shows "v1 \<sqsubset>val p v2 \<longleftrightarrow>
         pflat_len v1 p > pflat_len v2 p \<and>
         (\<forall>q \<in> Pos v1. q \<sqsubset>lex p \<longrightarrow> pflat_len v1 q = pflat_len v2 q) \<and>
         (\<forall>q \<in> Pos v2. q \<sqsubset>lex p \<longrightarrow> pflat_len v1 q = pflat_len v2 q)"
unfolding PosOrd_def
apply(auto)
done

definition PosOrd_ex:: "val \<Rightarrow> val \<Rightarrow> bool" ("_ :\<sqsubset>val _" [60, 59] 60)
where
  "v1 :\<sqsubset>val v2 \<equiv> \<exists>p. v1 \<sqsubset>val p v2"

definition PosOrd_ex_eq:: "val \<Rightarrow> val \<Rightarrow> bool" ("_ :\<sqsubseteq>val _" [60, 59] 60)
where
  "v1 :\<sqsubseteq>val v2 \<equiv> v1 :\<sqsubset>val v2 \<or> v1 = v2"

lemma PosOrd_trans:
  assumes "v1 :\<sqsubset>val v2" "v2 :\<sqsubset>val v3"
  shows "v1 :\<sqsubset>val v3"
proof -
  from assms obtain p p'
    where as: "v1 \<sqsubset>val p v2" "v2 \<sqsubset>val p' v3" unfolding PosOrd_ex_def by blast
  then have pos: "p \<in> Pos v1" "p' \<in> Pos v2" unfolding PosOrd_def pflat_len_def
    by (smt not_int_zless_negative)+
  have "p = p' \<or> p \<sqsubset>lex p' \<or> p' \<sqsubset>lex p"
    by (rule lex_trichotomous)
  moreover
    { assume "p = p'"
      with as have "v1 \<sqsubset>val p v3" unfolding PosOrd_def pflat_len_def
      by (smt Un_iff)
      then have " v1 :\<sqsubset>val v3" unfolding PosOrd_ex_def by blast
    }
  moreover
    { assume "p \<sqsubset>lex p'"
      with as have "v1 \<sqsubset>val p v3" unfolding PosOrd_def pflat_len_def
      by (smt Un_iff lex_trans)
      then have " v1 :\<sqsubset>val v3" unfolding PosOrd_ex_def by blast
    }
  moreover
    { assume "p' \<sqsubset>lex p"
      with as have "v1 \<sqsubset>val p' v3" unfolding PosOrd_def
      by (smt Un_iff lex_trans pflat_len_def)
      then have "v1 :\<sqsubset>val v3" unfolding PosOrd_ex_def by blast
    }
  ultimately show "v1 :\<sqsubset>val v3" by blast
qed

lemma PosOrd_irrefl:
  assumes "v :\<sqsubset>val v"
  shows "False"
using assms unfolding PosOrd_ex_def PosOrd_def
by auto

lemma PosOrd_assym:
  assumes "v1 :\<sqsubset>val v2"
  shows "\<not>(v2 :\<sqsubset>val v1)"
using assms
using PosOrd_irrefl PosOrd_trans by blast

(*
  :\<sqsubseteq>val and :\<sqsubset>val are partial orders.
*)

lemma PosOrd_ordering:
  shows "ordering (\<lambda>v1 v2. v1 :\<sqsubseteq>val v2) (\<lambda> v1 v2. v1 :\<sqsubset>val v2)"
unfolding ordering_def PosOrd_ex_eq_def
apply(auto)
using PosOrd_irrefl apply blast
using PosOrd_assym apply blast
using PosOrd_trans by blast

lemma PosOrd_order:
  shows "class.order (\<lambda>v1 v2. v1 :\<sqsubseteq>val v2) (\<lambda> v1 v2. v1 :\<sqsubset>val v2)"
using PosOrd_ordering
apply(simp add: class.order_def class.preorder_def class.order_axioms_def)
unfolding ordering_def
by blast

lemma PosOrd_ex_eq2:
  shows "v1 :\<sqsubset>val v2 \<longleftrightarrow> (v1 :\<sqsubseteq>val v2 \<and> v1 \<noteq> v2)"
using PosOrd_ordering
unfolding ordering_def
by auto

lemma PosOrdeq_trans:
  assumes "v1 :\<sqsubseteq>val v2" "v2 :\<sqsubseteq>val v3"
  shows "v1 :\<sqsubseteq>val v3"
using assms PosOrd_ordering
unfolding ordering_def
by blast

lemma PosOrdeq_antisym:
  assumes "v1 :\<sqsubseteq>val v2" "v2 :\<sqsubseteq>val v1"
  shows "v1 = v2"
using assms PosOrd_ordering
unfolding ordering_def
by blast

lemma PosOrdeq_refl:
  shows "v :\<sqsubseteq>val v"
unfolding PosOrd_ex_eq_def
by auto

lemma PosOrd_shorterE:
  assumes "v1 :\<sqsubset>val v2"
  shows "length (flat v2) \<le> length (flat v1)"
using assms unfolding PosOrd_ex_def PosOrd_def
apply(auto)
apply(case_tac p)
apply(simp add: pflat_len_simps)
apply(drule_tac x="[]" in bspec)
apply(simp add: Pos_empty)
apply(simp add: pflat_len_simps)
done

lemma PosOrd_shorterI:
  assumes "length (flat v2) < length (flat v1)"
  shows "v1 :\<sqsubset>val v2"
unfolding PosOrd_ex_def PosOrd_def pflat_len_def
using assms Pos_empty by force

lemma PosOrd_spreI:
  assumes "flat v' \<sqsubset>spre flat v"
  shows "v :\<sqsubset>val v'"
using assms
apply(rule_tac PosOrd_shorterI)
unfolding prefix_list_def sprefix_list_def
by (metis append_Nil2 append_eq_conv_conj drop_all le_less_linear)

lemma pflat_len_inside:
  assumes "pflat_len v2 p < pflat_len v1 p"
  shows "p \<in> Pos v1"
using assms
unfolding pflat_len_def
by (auto split: if_splits)

lemma PosOrd_Left_Right:
  assumes "flat v1 = flat v2"
  shows "Left v1 :\<sqsubset>val Right v2"
unfolding PosOrd_ex_def
apply(rule_tac x="[0]" in exI)
apply(auto simp add: PosOrd_def pflat_len_simps assms)
done

lemma PosOrd_LeftE:
  assumes "Left v1 :\<sqsubset>val Left v2" "flat v1 = flat v2"
  shows "v1 :\<sqsubset>val v2"
using assms
unfolding PosOrd_ex_def PosOrd_def2
apply(auto simp add: pflat_len_simps)
apply(frule pflat_len_inside)
apply(auto simp add: pflat_len_simps)
by (metis lex_simps(3) pflat_len_simps(3))

lemma PosOrd_LeftI:
  assumes "v1 :\<sqsubset>val v2" "flat v1 = flat v2"
  shows  "Left v1 :\<sqsubset>val Left v2"
using assms
unfolding PosOrd_ex_def PosOrd_def2
apply(auto simp add: pflat_len_simps)
by (metis less_numeral_extra(3) lex_simps(3) pflat_len_simps(3))

lemma PosOrd_Left_eq:
  assumes "flat v1 = flat v2"
  shows "Left v1 :\<sqsubset>val Left v2 \<longleftrightarrow> v1 :\<sqsubset>val v2"
using assms PosOrd_LeftE PosOrd_LeftI
by blast

lemma PosOrd_RightE:
  assumes "Right v1 :\<sqsubset>val Right v2" "flat v1 = flat v2"
  shows "v1 :\<sqsubset>val v2"
using assms
unfolding PosOrd_ex_def PosOrd_def2
apply(auto simp add: pflat_len_simps)
apply(frule pflat_len_inside)
apply(auto simp add: pflat_len_simps)
by (metis lex_simps(3) pflat_len_simps(5))

lemma PosOrd_RightI:
  assumes "v1 :\<sqsubset>val v2" "flat v1 = flat v2"
  shows  "Right v1 :\<sqsubset>val Right v2"
using assms
unfolding PosOrd_ex_def PosOrd_def2
apply(auto simp add: pflat_len_simps)
by (metis lex_simps(3) nat_neq_iff pflat_len_simps(5))

lemma PosOrd_Right_eq:
  assumes "flat v1 = flat v2"
  shows "Right v1 :\<sqsubset>val Right v2 \<longleftrightarrow> v1 :\<sqsubset>val v2"
using assms PosOrd_RightE PosOrd_RightI
by blast

lemma PosOrd_SeqI1:
  assumes "v1 :\<sqsubset>val w1" "flat (Seq v1 v2) = flat (Seq w1 w2)"
  shows "Seq v1 v2 :\<sqsubset>val Seq w1 w2"
using assms(1)
apply(subst (asm) PosOrd_ex_def)
apply(subst (asm) PosOrd_def)
apply(clarify)
apply(subst PosOrd_ex_def)
apply(rule_tac x="0#p" in exI)
apply(subst PosOrd_def)
apply(rule conjI)
apply(simp add: pflat_len_simps)
apply(rule ballI)
apply(rule impI)
apply(simp only: Pos.simps)
apply(auto)[1]
apply(simp add: pflat_len_simps)
apply(auto simp add: pflat_len_simps)
using assms(2)
apply(simp)
apply(metis length_append of_nat_add)
done

lemma PosOrd_SeqI2:
  assumes "v2 :\<sqsubset>val w2" "flat v2 = flat w2"
  shows "Seq v v2 :\<sqsubset>val Seq v w2"
using assms(1)
apply(subst (asm) PosOrd_ex_def)
apply(subst (asm) PosOrd_def)
apply(clarify)
apply(subst PosOrd_ex_def)
apply(rule_tac x="Suc 0#p" in exI)
apply(subst PosOrd_def)
apply(rule conjI)
apply(simp add: pflat_len_simps)
apply(rule ballI)
apply(rule impI)
apply(simp only: Pos.simps)
apply(auto)[1]
apply(simp add: pflat_len_simps)
using assms(2)
apply(simp)
apply(auto simp add: pflat_len_simps)
done

lemma PosOrd_Seq_eq:
  assumes "flat v2 = flat w2"
  shows "(Seq v v2) :\<sqsubset>val (Seq v w2) \<longleftrightarrow> v2 :\<sqsubset>val w2"
using assms
apply(auto)
prefer 2
apply(simp add: PosOrd_SeqI2)
apply(simp add: PosOrd_ex_def)
apply(auto)
apply(case_tac p)
apply(simp add: PosOrd_def pflat_len_simps)
apply(case_tac a)
apply(simp add: PosOrd_def pflat_len_simps)
apply(clarify)
apply(case_tac nat)
prefer 2
apply(simp add: PosOrd_def pflat_len_simps pflat_len_outside)
apply(rule_tac x="list" in exI)
apply(auto simp add: PosOrd_def2 pflat_len_simps)
apply(smt Collect_disj_eq lex_list.intros(2) mem_Collect_eq pflat_len_simps(2))
apply(smt Collect_disj_eq lex_list.intros(2) mem_Collect_eq pflat_len_simps(2))
done

lemma PosOrd_StarsI:
  assumes "v1 :\<sqsubset>val v2" "flats (v1#vs1) = flats (v2#vs2)"
  shows "Stars (v1#vs1) :\<sqsubset>val Stars (v2#vs2)"
using assms(1)
apply(subst (asm) PosOrd_ex_def)
apply(subst (asm) PosOrd_def)
apply(clarify)
apply(subst PosOrd_ex_def)
apply(subst PosOrd_def)
apply(rule_tac x="0#p" in exI)
apply(simp add: pflat_len_Stars_simps pflat_len_simps)
using assms(2)
apply(simp add: pflat_len_simps)
apply(auto simp add: pflat_len_Stars_simps pflat_len_simps)
by (metis length_append of_nat_add)

lemma PosOrd_StarsI2:
  assumes "Stars vs1 :\<sqsubset>val Stars vs2" "flats vs1 = flats vs2"
  shows "Stars (v#vs1) :\<sqsubset>val Stars (v#vs2)"
using assms(1)
apply(subst (asm) PosOrd_ex_def)
apply(subst (asm) PosOrd_def)
apply(clarify)
apply(subst PosOrd_ex_def)
apply(subst PosOrd_def)
apply(case_tac p)
apply(simp add: pflat_len_simps)
apply(rule_tac x="Suc a#list" in exI)
apply(auto simp add: pflat_len_Stars_simps pflat_len_simps assms(2))
done

lemma PosOrd_Stars_appendI:
  assumes "Stars vs1 :\<sqsubset>val Stars vs2" "flat (Stars vs1) = flat (Stars vs2)"
  shows "Stars (vs @ vs1) :\<sqsubset>val Stars (vs @ vs2)"
using assms
apply(induct vs)
apply(simp)
apply(simp add: PosOrd_StarsI2)
done

lemma PosOrd_eq_Stars_zipI:
  assumes "\<forall>(v1, v2) \<in> set (zip vs1 vs2). v1 :\<sqsubseteq>val v2"
     "length vs1 = length vs2" "flats vs1 = flats vs2"
  shows "Stars vs1 :\<sqsubseteq>val Stars vs2"
  using assms
  apply(induct vs1 arbitrary: vs2)
   apply(case_tac vs2)
apply(simp add: PosOrd_ex_eq_def)
   apply(simp)
  apply(case_tac vs2)
   apply(simp)
  apply(simp)
  apply(auto)
apply(subst (asm) (2)PosOrd_ex_eq_def)
  apply(auto)
   apply(subst PosOrd_ex_eq_def)
   apply(rule disjI1)
   apply(rule PosOrd_StarsI)
    apply(simp)
   apply(simp)
  using PosOrd_StarsI2 PosOrd_ex_eq_def by fastforce

lemma PosOrd_StarsE2:
  assumes "Stars (v # vs1) :\<sqsubset>val Stars (v # vs2)"
  shows "Stars vs1 :\<sqsubset>val Stars vs2"
using assms
apply(subst (asm) PosOrd_ex_def)
apply(erule exE)
apply(case_tac p)
apply(simp)
apply(simp add: PosOrd_def pflat_len_simps)
apply(subst PosOrd_ex_def)
apply(rule_tac x="[]" in exI)
apply(simp add: PosOrd_def pflat_len_simps Pos_empty)
apply(simp)
apply(case_tac a)
apply(clarify)
apply(auto simp add: pflat_len_simps PosOrd_def pflat_len_def split: if_splits)[1]
apply(clarify)
apply(simp add: PosOrd_ex_def)
apply(rule_tac x="nat#list" in exI)
apply(auto simp add: PosOrd_def pflat_len_simps)[1]
apply(case_tac q)
apply(simp add: PosOrd_def pflat_len_simps)
apply(clarify)
apply(drule_tac x="Suc a # lista" in bspec)
apply(simp)
apply(auto simp add: PosOrd_def pflat_len_simps)[1]
apply(case_tac q)
apply(simp add: PosOrd_def pflat_len_simps)
apply(clarify)
apply(drule_tac x="Suc a # lista" in bspec)
apply(simp)
apply(auto simp add: PosOrd_def pflat_len_simps)[1]
done

lemma PosOrd_Stars_appendE:
  assumes "Stars (vs @ vs1) :\<sqsubset>val Stars (vs @ vs2)"
  shows "Stars vs1 :\<sqsubset>val Stars vs2"
using assms
apply(induct vs)
apply(simp)
apply(simp add: PosOrd_StarsE2)
done

lemma PosOrd_Stars_append_eq:
  assumes "flats vs1 = flats vs2"
  shows "Stars (vs @ vs1) :\<sqsubset>val Stars (vs @ vs2) \<longleftrightarrow> Stars vs1 :\<sqsubset>val Stars vs2"
using assms
apply(rule_tac iffI)
apply(erule PosOrd_Stars_appendE)
apply(rule PosOrd_Stars_appendI)
apply(auto)
done

lemma PosOrd_almost_trichotomous:
  shows "v1 :\<sqsubset>val v2 \<or> v2 :\<sqsubset>val v1 \<or> (length (flat v1) = length (flat v2))"
apply(auto simp add: PosOrd_ex_def)
apply(auto simp add: PosOrd_def)
apply(rule_tac x="[]" in exI)
apply(auto simp add: Pos_empty pflat_len_simps)
apply(drule_tac x="[]" in spec)
apply(auto simp add: Pos_empty pflat_len_simps)
done

section {* The Posix Value is smaller than any other Value *}

lemma Posix_PosOrd:
  assumes "s \<in> r \<rightarrow> v1" "v2 \<in> LV r s"
  shows "v1 :\<sqsubseteq>val v2"
using assms
proof (induct arbitrary: v2 rule: Posix.induct)
  case (Posix_ONE v)
  have "v \<in> LV ONE []" by fact
  then have "v = Void"
    by (simp add: LV_simps)
  then show "Void :\<sqsubseteq>val v"
    by (simp add: PosOrd_ex_eq_def)
next
  case (Posix_CHAR c v)
  have "v \<in> LV (CHAR c) [c]" by fact
  then have "v = Char c"
    by (simp add: LV_simps)
  then show "Char c :\<sqsubseteq>val v"
    by (simp add: PosOrd_ex_eq_def)
next
  case (Posix_ALT1 s r1 v r2 v2)
  have as1: "s \<in> r1 \<rightarrow> v" by fact
  have IH: "\<And>v2. v2 \<in> LV r1 s \<Longrightarrow> v :\<sqsubseteq>val v2" by fact
  have "v2 \<in> LV (ALT r1 r2) s" by fact
  then have "\<Turnstile> v2 : ALT r1 r2" "flat v2 = s"
    by(auto simp add: LV_def prefix_list_def)
  then consider
    (Left) v3 where "v2 = Left v3" "\<Turnstile> v3 : r1" "flat v3 = s"
  | (Right) v3 where "v2 = Right v3" "\<Turnstile> v3 : r2" "flat v3 = s"
  by (auto elim: Prf.cases)
  then show "Left v :\<sqsubseteq>val v2"
  proof(cases)
     case (Left v3)
     have "v3 \<in> LV r1 s" using Left(2,3)
       by (auto simp add: LV_def prefix_list_def)
     with IH have "v :\<sqsubseteq>val v3" by simp
     moreover
     have "flat v3 = flat v" using as1 Left(3)
       by (simp add: Posix1(2))
     ultimately have "Left v :\<sqsubseteq>val Left v3"
       by (simp add: PosOrd_ex_eq_def PosOrd_Left_eq)
     then show "Left v :\<sqsubseteq>val v2" unfolding Left .
  next
     case (Right v3)
     have "flat v3 = flat v" using as1 Right(3)
       by (simp add: Posix1(2))
     then have "Left v :\<sqsubseteq>val Right v3"
       unfolding PosOrd_ex_eq_def
       by (simp add: PosOrd_Left_Right)
     then show "Left v :\<sqsubseteq>val v2" unfolding Right .
  qed
next
  case (Posix_ALT2 s r2 v r1 v2)
  have as1: "s \<in> r2 \<rightarrow> v" by fact
  have as2: "s \<notin> L r1" by fact
  have IH: "\<And>v2. v2 \<in> LV r2 s \<Longrightarrow> v :\<sqsubseteq>val v2" by fact
  have "v2 \<in> LV (ALT r1 r2) s" by fact
  then have "\<Turnstile> v2 : ALT r1 r2" "flat v2 = s"
    by(auto simp add: LV_def prefix_list_def)
  then consider
    (Left) v3 where "v2 = Left v3" "\<Turnstile> v3 : r1" "flat v3 = s"
  | (Right) v3 where "v2 = Right v3" "\<Turnstile> v3 : r2" "flat v3 = s"
  by (auto elim: Prf.cases)
  then show "Right v :\<sqsubseteq>val v2"
  proof (cases)
    case (Right v3)
     have "v3 \<in> LV r2 s" using Right(2,3)
       by (auto simp add: LV_def prefix_list_def)
     with IH have "v :\<sqsubseteq>val v3" by simp
     moreover
     have "flat v3 = flat v" using as1 Right(3)
       by (simp add: Posix1(2))
     ultimately have "Right v :\<sqsubseteq>val Right v3"
        by (auto simp add: PosOrd_ex_eq_def PosOrd_RightI)
     then show "Right v :\<sqsubseteq>val v2" unfolding Right .
  next
     case (Left v3)
     have "v3 \<in> LV r1 s" using Left(2,3) as2
       by (auto simp add: LV_def prefix_list_def)
     then have "flat v3 = flat v \<and> \<Turnstile> v3 : r1" using as1 Left(3)
       by (simp add: Posix1(2) LV_def)
     then have "False" using as1 as2 Left
       by (auto simp add: Posix1(2) L_flat_Prf1)
     then show "Right v :\<sqsubseteq>val v2" by simp
  qed
next
  case (Posix_SEQ s1 r1 v1 s2 r2 v2 v3)
  have "s1 \<in> r1 \<rightarrow> v1" "s2 \<in> r2 \<rightarrow> v2" by fact+
  then have as1: "s1 = flat v1" "s2 = flat v2" by (simp_all add: Posix1(2))
  have IH1: "\<And>v3. v3 \<in> LV r1 s1 \<Longrightarrow> v1 :\<sqsubseteq>val v3" by fact
  have IH2: "\<And>v3. v3 \<in> LV r2 s2 \<Longrightarrow> v2 :\<sqsubseteq>val v3" by fact
  have cond: "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L r1 \<and> s\<^sub>4 \<in> L r2)" by fact
  have "v3 \<in> LV (SEQ r1 r2) (s1 @ s2)" by fact
  then obtain v3a v3b where eqs:
    "v3 = Seq v3a v3b" "\<Turnstile> v3a : r1" "\<Turnstile> v3b : r2"
    "flat v3a @ flat v3b = s1 @ s2"
    by (force simp add: prefix_list_def LV_def elim: Prf.cases)
  with cond have "flat v3a \<sqsubseteq>pre s1" unfolding prefix_list_def
    by (smt L_flat_Prf1 append_eq_append_conv2 append_self_conv)
  then have "flat v3a \<sqsubset>spre s1 \<or> (flat v3a = s1 \<and> flat v3b = s2)" using eqs
    by (simp add: sprefix_list_def append_eq_conv_conj)
  then have q2: "v1 :\<sqsubset>val v3a \<or> (flat v3a = s1 \<and> flat v3b = s2)"
    using PosOrd_spreI as1(1) eqs by blast
  then have "v1 :\<sqsubset>val v3a \<or> (v3a \<in> LV r1 s1 \<and> v3b \<in> LV r2 s2)" using eqs(2,3)
    by (auto simp add: LV_def)
  then have "v1 :\<sqsubset>val v3a \<or> (v1 :\<sqsubseteq>val v3a \<and> v2 :\<sqsubseteq>val v3b)" using IH1 IH2 by blast
  then have "Seq v1 v2 :\<sqsubseteq>val Seq v3a v3b" using eqs q2 as1
    unfolding  PosOrd_ex_eq_def by (auto simp add: PosOrd_SeqI1 PosOrd_Seq_eq)
  then show "Seq v1 v2 :\<sqsubseteq>val v3" unfolding eqs by blast
next
  case (Posix_STAR1 s1 r v s2 vs v3)
  have "s1 \<in> r \<rightarrow> v" "s2 \<in> STAR r \<rightarrow> Stars vs" by fact+
  then have as1: "s1 = flat v" "s2 = flat (Stars vs)" by (auto dest: Posix1(2))
  have IH1: "\<And>v3. v3 \<in> LV r s1 \<Longrightarrow> v :\<sqsubseteq>val v3" by fact
  have IH2: "\<And>v3. v3 \<in> LV (STAR r) s2 \<Longrightarrow> Stars vs :\<sqsubseteq>val v3" by fact
  have cond: "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L r \<and> s\<^sub>4 \<in> L (STAR r))" by fact
  have cond2: "flat v \<noteq> []" by fact
  have "v3 \<in> LV (STAR r) (s1 @ s2)" by fact
  then consider
    (NonEmpty) v3a vs3 where "v3 = Stars (v3a # vs3)"
    "\<Turnstile> v3a : r" "\<Turnstile> Stars vs3 : STAR r"
    "flat (Stars (v3a # vs3)) = s1 @ s2"
  | (Empty) "v3 = Stars []"
  unfolding LV_def
  apply(auto)
  apply(erule Prf.cases)
  apply(auto)
  apply(case_tac vs)
  apply(auto intro: Prf.intros)
  done
  then show "Stars (v # vs) :\<sqsubseteq>val v3"
    proof (cases)
      case (NonEmpty v3a vs3)
      have "flat (Stars (v3a # vs3)) = s1 @ s2" using NonEmpty(4) .
      with cond have "flat v3a \<sqsubseteq>pre s1" using NonEmpty(2,3)
        unfolding prefix_list_def
        by (smt L_flat_Prf1 append_Nil2 append_eq_append_conv2 flat.simps(7))
      then have "flat v3a \<sqsubset>spre s1 \<or> (flat v3a = s1 \<and> flat (Stars vs3) = s2)" using NonEmpty(4)
        by (simp add: sprefix_list_def append_eq_conv_conj)
      then have q2: "v :\<sqsubset>val v3a \<or> (flat v3a = s1 \<and> flat (Stars vs3) = s2)"
        using PosOrd_spreI as1(1) NonEmpty(4) by blast
      then have "v :\<sqsubset>val v3a \<or> (v3a \<in> LV r s1 \<and> Stars vs3 \<in> LV (STAR r) s2)"
        using NonEmpty(2,3) by (auto simp add: LV_def)
      then have "v :\<sqsubset>val v3a \<or> (v :\<sqsubseteq>val v3a \<and> Stars vs :\<sqsubseteq>val Stars vs3)" using IH1 IH2 by blast
      then have "v :\<sqsubset>val v3a \<or> (v = v3a \<and> Stars vs :\<sqsubseteq>val Stars vs3)"
         unfolding PosOrd_ex_eq_def by auto
      then have "Stars (v # vs) :\<sqsubseteq>val Stars (v3a # vs3)" using NonEmpty(4) q2 as1
        unfolding  PosOrd_ex_eq_def
        using PosOrd_StarsI PosOrd_StarsI2 by auto
      then show "Stars (v # vs) :\<sqsubseteq>val v3" unfolding NonEmpty by blast
    next
      case Empty
      have "v3 = Stars []" by fact
      then show "Stars (v # vs) :\<sqsubseteq>val v3"
      unfolding PosOrd_ex_eq_def using cond2
      by (simp add: PosOrd_shorterI)
    qed
next
  case (Posix_STAR2 r v2)
  have "v2 \<in> LV (STAR r) []" by fact
  then have "v2 = Stars []"
    unfolding LV_def by (auto elim: Prf.cases)
  then show "Stars [] :\<sqsubseteq>val v2"
    by (simp add: PosOrd_ex_eq_def)
next
  case (Posix_NTIMES1 s1 r v s2 n vs v3)
  have "s1 \<in> r \<rightarrow> v" "s2 \<in> NTIMES r (n - 1) \<rightarrow> Stars vs" by fact+
  then have as1: "s1 = flat v" "s2 = flats vs" by (auto dest: Posix1(2))
  have IH1: "\<And>v3. v3 \<in> LV r s1 \<Longrightarrow> v :\<sqsubseteq>val v3" by fact
  have IH2: "\<And>v3. v3 \<in> LV (NTIMES r (n - 1)) s2 \<Longrightarrow> Stars vs :\<sqsubseteq>val v3" by fact
  have cond: "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L r \<and> s\<^sub>4 \<in> L (NTIMES r (n - 1)))" by fact
  have cond2: "flat v \<noteq> []" by fact
  have "v3 \<in> LV (NTIMES r n) (s1 @ s2)" by fact
  then consider
    (NonEmpty) v3a vs3 where "v3 = Stars (v3a # vs3)"
    "\<Turnstile> v3a : r" "\<Turnstile> Stars vs3 : NTIMES r (n - 1)"
    "flats (v3a # vs3) = s1 @ s2"
  | (Empty) "v3 = Stars []"
  unfolding LV_def
  apply(auto)
  apply(erule Prf.cases)
             apply(auto)
  apply(case_tac vs1)
   apply(auto intro: Prf.intros)
   apply(case_tac vs2)
    apply(auto intro: Prf.intros)
  apply (simp add: as1(1) cond2 flats_empty)
  by (simp add: Prf.intros(8))
  then show "Stars (v # vs) :\<sqsubseteq>val v3"
    proof (cases)
      case (NonEmpty v3a vs3)
      have "flats (v3a # vs3) = s1 @ s2" using NonEmpty(4) .
      with cond have "flat v3a \<sqsubseteq>pre s1" using NonEmpty(2,3)
        unfolding prefix_list_def
        by (smt L_flat_Prf1 append_Nil2 append_eq_append_conv2 flat.simps(7) flat_Stars)
      then have "flat v3a \<sqsubset>spre s1 \<or> (flat v3a = s1 \<and> flat (Stars vs3) = s2)" using NonEmpty(4)
        by (simp add: sprefix_list_def append_eq_conv_conj)
      then have q2: "v :\<sqsubset>val v3a \<or> (flat v3a = s1 \<and> flat (Stars vs3) = s2)"
        using PosOrd_spreI as1(1) NonEmpty(4) by blast
      then have "v :\<sqsubset>val v3a \<or> (v3a \<in> LV r s1 \<and> Stars vs3 \<in> LV (NTIMES r (n - 1)) s2)"
        using NonEmpty(2,3) by (auto simp add: LV_def)
      then have "v :\<sqsubset>val v3a \<or> (v :\<sqsubseteq>val v3a \<and> Stars vs :\<sqsubseteq>val Stars vs3)" using IH1 IH2 by blast
      then have "v :\<sqsubset>val v3a \<or> (v = v3a \<and> Stars vs :\<sqsubseteq>val Stars vs3)"
         unfolding PosOrd_ex_eq_def by auto
      then have "Stars (v # vs) :\<sqsubseteq>val Stars (v3a # vs3)" using NonEmpty(4) q2 as1
        unfolding  PosOrd_ex_eq_def
        using PosOrd_StarsI PosOrd_StarsI2 by auto
      then show "Stars (v # vs) :\<sqsubseteq>val v3" unfolding NonEmpty by blast
    next
      case Empty
      have "v3 = Stars []" by fact
      then show "Stars (v # vs) :\<sqsubseteq>val v3"
      unfolding PosOrd_ex_eq_def using cond2
      by (simp add: PosOrd_shorterI)
  qed
next
  case (Posix_NTIMES2 vs r n v2)
  then show "Stars vs :\<sqsubseteq>val v2"
    apply(simp add: LV_def)
    apply(auto)
    apply(erule Prf_elims)
    apply(auto)
    apply(rule PosOrd_eq_Stars_zipI)
      prefer 2
      apply(simp)
     prefer 2
     apply (metis Posix1(2) flats_empty)
    apply(auto)
    by (meson in_set_zipE)
next
  case (Posix_UPNTIMES2 r n v2)
    then show "Stars [] :\<sqsubseteq>val v2"
    apply(simp add: LV_def)
      apply(auto)
    apply(erule Prf_elims)
      apply(auto)
      unfolding PosOrd_ex_eq_def by simp
next
  case (Posix_UPNTIMES1 s1 r v s2 n vs v3)
  have "s1 \<in> r \<rightarrow> v" "s2 \<in> UPNTIMES r (n - 1) \<rightarrow> Stars vs" by fact+
  then have as1: "s1 = flat v" "s2 = flat (Stars vs)" by (auto dest: Posix1(2))
  have IH1: "\<And>v3. v3 \<in> LV r s1 \<Longrightarrow> v :\<sqsubseteq>val v3" by fact
  have IH2: "\<And>v3. v3 \<in> LV (UPNTIMES r (n - 1)) s2 \<Longrightarrow> Stars vs :\<sqsubseteq>val v3" by fact
  have cond: "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L r \<and> s\<^sub>4 \<in> L (UPNTIMES r (n - 1)))" by fact
  have cond2: "flat v \<noteq> []" by fact
  have "v3 \<in> LV (UPNTIMES r n) (s1 @ s2)" by fact
  then consider
    (NonEmpty) v3a vs3 where "v3 = Stars (v3a # vs3)"
    "\<Turnstile> v3a : r" "\<Turnstile> Stars vs3 : UPNTIMES r (n - 1)"
    "flats (v3a # vs3) = s1 @ s2"
  | (Empty) "v3 = Stars []"
  unfolding LV_def
  apply(auto)
  apply(erule Prf.cases)
  apply(auto)
  apply(case_tac vs)
   apply(auto intro: Prf.intros)
  by (simp add: Prf.intros(7) as1(1) cond2)
  then show "Stars (v # vs) :\<sqsubseteq>val v3"
    proof (cases)
      case (NonEmpty v3a vs3)
      have "flats (v3a # vs3) = s1 @ s2" using NonEmpty(4) .
      with cond have "flat v3a \<sqsubseteq>pre s1" using NonEmpty(2,3)
        unfolding prefix_list_def
        apply(simp)
        apply(simp add: append_eq_append_conv2)
        apply(auto)
        by (metis L_flat_Prf1 One_nat_def cond flat_Stars)
      then have "flat v3a \<sqsubset>spre s1 \<or> (flat v3a = s1 \<and> flat (Stars vs3) = s2)" using NonEmpty(4)
        by (simp add: sprefix_list_def append_eq_conv_conj)
      then have q2: "v :\<sqsubset>val v3a \<or> (flat v3a = s1 \<and> flat (Stars vs3) = s2)"
        using PosOrd_spreI as1(1) NonEmpty(4) by blast
      then have "v :\<sqsubset>val v3a \<or> (v3a \<in> LV r s1 \<and> Stars vs3 \<in> LV (UPNTIMES r (n - 1)) s2)"
        using NonEmpty(2,3) by (auto simp add: LV_def)
      then have "v :\<sqsubset>val v3a \<or> (v :\<sqsubseteq>val v3a \<and> Stars vs :\<sqsubseteq>val Stars vs3)" using IH1 IH2 by blast
      then have "v :\<sqsubset>val v3a \<or> (v = v3a \<and> Stars vs :\<sqsubseteq>val Stars vs3)"
         unfolding PosOrd_ex_eq_def by auto
      then have "Stars (v # vs) :\<sqsubseteq>val Stars (v3a # vs3)" using NonEmpty(4) q2 as1
        unfolding  PosOrd_ex_eq_def
        using PosOrd_StarsI PosOrd_StarsI2 by auto
      then show "Stars (v # vs) :\<sqsubseteq>val v3" unfolding NonEmpty by blast
    next
      case Empty
      have "v3 = Stars []" by fact
      then show "Stars (v # vs) :\<sqsubseteq>val v3"
      unfolding PosOrd_ex_eq_def using cond2
      by (simp add: PosOrd_shorterI)
  qed
next
  case (Posix_FROMNTIMES2 vs r n v2)
    then show "Stars vs :\<sqsubseteq>val v2"
    apply(simp add: LV_def)
      apply(auto)
    apply(erule Prf_elims)
       apply(auto)
        apply(rule PosOrd_eq_Stars_zipI)
      prefer 2
      apply(simp)
     prefer 2
     apply (metis Posix1(2) flats_empty)
    apply(auto)
      by (meson in_set_zipE)
next
  case (Posix_FROMNTIMES1 s1 r v s2 n vs v3)
  have "s1 \<in> r \<rightarrow> v" "s2 \<in> FROMNTIMES r (n - 1) \<rightarrow> Stars vs" by fact+
  then have as1: "s1 = flat v" "s2 = flats vs" by (auto dest: Posix1(2))
  have IH1: "\<And>v3. v3 \<in> LV r s1 \<Longrightarrow> v :\<sqsubseteq>val v3" by fact
  have IH2: "\<And>v3. v3 \<in> LV (FROMNTIMES r (n - 1)) s2 \<Longrightarrow> Stars vs :\<sqsubseteq>val v3" by fact
  have cond: "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L r \<and> s\<^sub>4 \<in> L (FROMNTIMES r (n - 1)))" by fact
  have cond2: "flat v \<noteq> []" by fact
  have "v3 \<in> LV (FROMNTIMES r n) (s1 @ s2)" by fact
  then consider
    (NonEmpty) v3a vs3 where "v3 = Stars (v3a # vs3)"
    "\<Turnstile> v3a : r" "\<Turnstile> Stars vs3 : FROMNTIMES r (n - 1)"
    "flats (v3a # vs3) = s1 @ s2"
  | (Empty) "v3 = Stars []"
  unfolding LV_def
  apply(auto)
  apply(erule Prf.cases)
             apply(auto)
  apply(case_tac vs1)
   apply(auto intro: Prf.intros)
   apply(case_tac vs2)
    apply(auto intro: Prf.intros)
    apply (simp add: as1(1) cond2 flats_empty)
  apply (simp add: Prf.intros)
  apply(case_tac vs)
   apply(auto)
  using Posix_FROMNTIMES1.hyps(6) Prf.intros(10) by auto
  then show "Stars (v # vs) :\<sqsubseteq>val v3"
    proof (cases)
      case (NonEmpty v3a vs3)
      have "flats (v3a # vs3) = s1 @ s2" using NonEmpty(4) .
      with cond have "flat v3a \<sqsubseteq>pre s1" using NonEmpty(2,3)
        unfolding prefix_list_def
        by (smt L_flat_Prf1 append_Nil2 append_eq_append_conv2 flat.simps(7) flat_Stars)
      then have "flat v3a \<sqsubset>spre s1 \<or> (flat v3a = s1 \<and> flat (Stars vs3) = s2)" using NonEmpty(4)
        by (simp add: sprefix_list_def append_eq_conv_conj)
      then have q2: "v :\<sqsubset>val v3a \<or> (flat v3a = s1 \<and> flat (Stars vs3) = s2)"
        using PosOrd_spreI as1(1) NonEmpty(4) by blast
      then have "v :\<sqsubset>val v3a \<or> (v3a \<in> LV r s1 \<and> Stars vs3 \<in> LV (FROMNTIMES r (n - 1)) s2)"
        using NonEmpty(2,3) by (auto simp add: LV_def)
      then have "v :\<sqsubset>val v3a \<or> (v :\<sqsubseteq>val v3a \<and> Stars vs :\<sqsubseteq>val Stars vs3)" using IH1 IH2 by blast
      then have "v :\<sqsubset>val v3a \<or> (v = v3a \<and> Stars vs :\<sqsubseteq>val Stars vs3)"
         unfolding PosOrd_ex_eq_def by auto
      then have "Stars (v # vs) :\<sqsubseteq>val Stars (v3a # vs3)" using NonEmpty(4) q2 as1
        unfolding  PosOrd_ex_eq_def
        using PosOrd_StarsI PosOrd_StarsI2 by auto
      then show "Stars (v # vs) :\<sqsubseteq>val v3" unfolding NonEmpty by blast
    next
      case Empty
      have "v3 = Stars []" by fact
      then show "Stars (v # vs) :\<sqsubseteq>val v3"
      unfolding PosOrd_ex_eq_def using cond2
      by (simp add: PosOrd_shorterI)
  qed
next
  case (Posix_FROMNTIMES3 s1 r v s2 vs v3)
      have "s1 \<in> r \<rightarrow> v" "s2 \<in> STAR r \<rightarrow> Stars vs" by fact+
  then have as1: "s1 = flat v" "s2 = flat (Stars vs)" by (auto dest: Posix1(2))
  have IH1: "\<And>v3. v3 \<in> LV r s1 \<Longrightarrow> v :\<sqsubseteq>val v3" by fact
  have IH2: "\<And>v3. v3 \<in> LV (STAR r) s2 \<Longrightarrow> Stars vs :\<sqsubseteq>val v3" by fact
  have cond: "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L r \<and> s\<^sub>4 \<in> L (STAR r))" by fact
  have cond2: "flat v \<noteq> []" by fact
  have "v3 \<in> LV (FROMNTIMES r 0) (s1 @ s2)" by fact
  then consider
    (NonEmpty) v3a vs3 where "v3 = Stars (v3a # vs3)"
    "\<Turnstile> v3a : r" "\<Turnstile> Stars vs3 : STAR r"
    "flat (Stars (v3a # vs3)) = s1 @ s2"
  | (Empty) "v3 = Stars []"
  unfolding LV_def
  apply(auto)
  apply(erule Prf.cases)
  apply(auto)
  apply(case_tac vs)
  apply(auto intro: Prf.intros)
  done
  then show "Stars (v # vs) :\<sqsubseteq>val v3"
    proof (cases)
      case (NonEmpty v3a vs3)
      have "flat (Stars (v3a # vs3)) = s1 @ s2" using NonEmpty(4) .
      with cond have "flat v3a \<sqsubseteq>pre s1" using NonEmpty(2,3)
        unfolding prefix_list_def
        by (smt L_flat_Prf1 append_Nil2 append_eq_append_conv2 flat.simps(7))
      then have "flat v3a \<sqsubset>spre s1 \<or> (flat v3a = s1 \<and> flat (Stars vs3) = s2)" using NonEmpty(4)
        by (simp add: sprefix_list_def append_eq_conv_conj)
      then have q2: "v :\<sqsubset>val v3a \<or> (flat v3a = s1 \<and> flat (Stars vs3) = s2)"
        using PosOrd_spreI as1(1) NonEmpty(4) by blast
      then have "v :\<sqsubset>val v3a \<or> (v3a \<in> LV r s1 \<and> Stars vs3 \<in> LV (STAR r) s2)"
        using NonEmpty(2,3) by (auto simp add: LV_def)
      then have "v :\<sqsubset>val v3a \<or> (v :\<sqsubseteq>val v3a \<and> Stars vs :\<sqsubseteq>val Stars vs3)" using IH1 IH2 by blast
      then have "v :\<sqsubset>val v3a \<or> (v = v3a \<and> Stars vs :\<sqsubseteq>val Stars vs3)"
         unfolding PosOrd_ex_eq_def by auto
      then have "Stars (v # vs) :\<sqsubseteq>val Stars (v3a # vs3)" using NonEmpty(4) q2 as1
        unfolding  PosOrd_ex_eq_def
        using PosOrd_StarsI PosOrd_StarsI2 by auto
      then show "Stars (v # vs) :\<sqsubseteq>val v3" unfolding NonEmpty by blast
    next
      case Empty
      have "v3 = Stars []" by fact
      then show "Stars (v # vs) :\<sqsubseteq>val v3"
      unfolding PosOrd_ex_eq_def using cond2
      by (simp add: PosOrd_shorterI)
    qed
next
  case (Posix_NMTIMES2 vs r n m v2)
  then show "Stars vs :\<sqsubseteq>val v2"
    apply(auto simp add: LV_def)
    apply(erule Prf_elims)
     apply(simp)
     apply(rule PosOrd_eq_Stars_zipI)
       apply(auto)
     apply (meson in_set_zipE)
    by (metis Posix1(2) flats_empty)
next
  case (Posix_NMTIMES1 s1 r v s2 n m vs v3)
  have "s1 \<in> r \<rightarrow> v" "s2 \<in> NMTIMES r (n - 1) (m - 1) \<rightarrow> Stars vs" by fact+
  then have as1: "s1 = flat v" "s2 = flats vs" by (auto dest: Posix1(2))
  have IH1: "\<And>v3. v3 \<in> LV r s1 \<Longrightarrow> v :\<sqsubseteq>val v3" by fact
  have IH2: "\<And>v3. v3 \<in> LV (NMTIMES r (n - 1) (m - 1)) s2 \<Longrightarrow> Stars vs :\<sqsubseteq>val v3" by fact
  have cond: "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L r \<and> s\<^sub>4 \<in> L (NMTIMES r (n - 1) (m - 1)))" by fact
  have cond2: "flat v \<noteq> []" by fact
  have "v3 \<in> LV (NMTIMES r n m) (s1 @ s2)" by fact
  then consider
    (NonEmpty) v3a vs3 where "v3 = Stars (v3a # vs3)"
    "\<Turnstile> v3a : r" "\<Turnstile> Stars vs3 : NMTIMES r (n - 1) (m - 1)"
    "flats (v3a # vs3) = s1 @ s2"
  | (Empty) "v3 = Stars []"
  unfolding LV_def
  apply(auto)
  apply(erule Prf.cases)
             apply(auto)
  apply(case_tac n)
    apply(auto intro: Prf.intros)
   apply(case_tac vs1)
    apply(auto intro: Prf.intros)
   apply (simp add: as1(1) cond2 flats_empty)
   apply (simp add: Prf.intros(11))
  apply(case_tac n)
   apply(simp)
  using Posix_NMTIMES1.hyps(6) apply blast
  apply(simp)
  apply(case_tac vs)
   apply(auto)
  by (simp add: Prf.intros(12))
  then show "Stars (v # vs) :\<sqsubseteq>val v3"
    proof (cases)
      case (NonEmpty v3a vs3)
      have "flats (v3a # vs3) = s1 @ s2" using NonEmpty(4) .
      with cond have "flat v3a \<sqsubseteq>pre s1" using NonEmpty(2,3)
        unfolding prefix_list_def
        by (smt L_flat_Prf1 append_Nil2 append_eq_append_conv2 flat.simps(7) flat_Stars)
      then have "flat v3a \<sqsubset>spre s1 \<or> (flat v3a = s1 \<and> flat (Stars vs3) = s2)" using NonEmpty(4)
        by (simp add: sprefix_list_def append_eq_conv_conj)
      then have q2: "v :\<sqsubset>val v3a \<or> (flat v3a = s1 \<and> flat (Stars vs3) = s2)"
        using PosOrd_spreI as1(1) NonEmpty(4) by blast
      then have "v :\<sqsubset>val v3a \<or> (v3a \<in> LV r s1 \<and> Stars vs3 \<in> LV (NMTIMES r (n - 1) (m - 1)) s2)"
        using NonEmpty(2,3) by (auto simp add: LV_def)
      then have "v :\<sqsubset>val v3a \<or> (v :\<sqsubseteq>val v3a \<and> Stars vs :\<sqsubseteq>val Stars vs3)" using IH1 IH2 by blast
      then have "v :\<sqsubset>val v3a \<or> (v = v3a \<and> Stars vs :\<sqsubseteq>val Stars vs3)"
         unfolding PosOrd_ex_eq_def by auto
      then have "Stars (v # vs) :\<sqsubseteq>val Stars (v3a # vs3)" using NonEmpty(4) q2 as1
        unfolding  PosOrd_ex_eq_def
        using PosOrd_StarsI PosOrd_StarsI2 by auto
      then show "Stars (v # vs) :\<sqsubseteq>val v3" unfolding NonEmpty by blast
    next
      case Empty
      have "v3 = Stars []" by fact
      then show "Stars (v # vs) :\<sqsubseteq>val v3"
      unfolding PosOrd_ex_eq_def using cond2
      by (simp add: PosOrd_shorterI)
  qed
next
  case (Posix_NMTIMES3 s1 r v s2 m vs v3)
  have "s1 \<in> r \<rightarrow> v" "s2 \<in> UPNTIMES r (m - 1) \<rightarrow> Stars vs" by fact+
  then have as1: "s1 = flat v" "s2 = flat (Stars vs)" by (auto dest: Posix1(2))
  have IH1: "\<And>v3. v3 \<in> LV r s1 \<Longrightarrow> v :\<sqsubseteq>val v3" by fact
  have IH2: "\<And>v3. v3 \<in> LV (UPNTIMES r (m - 1)) s2 \<Longrightarrow> Stars vs :\<sqsubseteq>val v3" by fact
  have cond: "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L r \<and> s\<^sub>4 \<in> L (UPNTIMES r (m - 1)))" by fact
  have cond2: "flat v \<noteq> []" by fact
  have "v3 \<in> LV (NMTIMES r 0 m) (s1 @ s2)" by fact
  then consider
    (NonEmpty) v3a vs3 where "v3 = Stars (v3a # vs3)"
    "\<Turnstile> v3a : r" "\<Turnstile> Stars vs3 : UPNTIMES r (m - 1)"
    "flats (v3a # vs3) = s1 @ s2"
  | (Empty) "v3 = Stars []"
  unfolding LV_def
  apply(auto)
  apply(erule Prf.cases)
  apply(auto)
  apply(case_tac vs)
   apply(auto intro: Prf.intros)
  by (simp add: Prf.intros(7) as1(1) cond2)
  then show "Stars (v # vs) :\<sqsubseteq>val v3"
    proof (cases)
      case (NonEmpty v3a vs3)
      have "flats (v3a # vs3) = s1 @ s2" using NonEmpty(4) .
      with cond have "flat v3a \<sqsubseteq>pre s1" using NonEmpty(2,3)
        unfolding prefix_list_def
        apply(simp)
        apply(simp add: append_eq_append_conv2)
        apply(auto)
        by (metis L_flat_Prf1 One_nat_def cond flat_Stars)
      then have "flat v3a \<sqsubset>spre s1 \<or> (flat v3a = s1 \<and> flat (Stars vs3) = s2)" using NonEmpty(4)
        by (simp add: sprefix_list_def append_eq_conv_conj)
      then have q2: "v :\<sqsubset>val v3a \<or> (flat v3a = s1 \<and> flat (Stars vs3) = s2)"
        using PosOrd_spreI as1(1) NonEmpty(4) by blast
      then have "v :\<sqsubset>val v3a \<or> (v3a \<in> LV r s1 \<and> Stars vs3 \<in> LV (UPNTIMES r (m - 1)) s2)"
        using NonEmpty(2,3) by (auto simp add: LV_def)
      then have "v :\<sqsubset>val v3a \<or> (v :\<sqsubseteq>val v3a \<and> Stars vs :\<sqsubseteq>val Stars vs3)" using IH1 IH2 by blast
      then have "v :\<sqsubset>val v3a \<or> (v = v3a \<and> Stars vs :\<sqsubseteq>val Stars vs3)"
         unfolding PosOrd_ex_eq_def by auto
      then have "Stars (v # vs) :\<sqsubseteq>val Stars (v3a # vs3)" using NonEmpty(4) q2 as1
        unfolding  PosOrd_ex_eq_def
        using PosOrd_StarsI PosOrd_StarsI2 by auto
      then show "Stars (v # vs) :\<sqsubseteq>val v3" unfolding NonEmpty by blast
    next
      case Empty
      have "v3 = Stars []" by fact
      then show "Stars (v # vs) :\<sqsubseteq>val v3"
      unfolding PosOrd_ex_eq_def using cond2
      by (simp add: PosOrd_shorterI)
  qed
qed

lemma Posix_PosOrd_reverse:
  assumes "s \<in> r \<rightarrow> v1"
  shows "\<not>(\<exists>v2 \<in> LV r s. v2 :\<sqsubset>val v1)"
using assms
by (metis Posix_PosOrd less_irrefl PosOrd_def
    PosOrd_ex_eq_def PosOrd_ex_def PosOrd_trans)

lemma PosOrd_Posix:
  assumes "v1 \<in> LV r s" "\<forall>v\<^sub>2 \<in> LV r s. \<not> v\<^sub>2 :\<sqsubset>val v1"
  shows "s \<in> r \<rightarrow> v1"
proof -
  have "s \<in> L r" using assms(1) unfolding LV_def
    using L_flat_Prf1 by blast
  then obtain vposix where vp: "s \<in> r \<rightarrow> vposix"
    using lexer_correct_Some by blast
  with assms(1) have "vposix :\<sqsubseteq>val v1" by (simp add: Posix_PosOrd)
  then have "vposix = v1 \<or> vposix :\<sqsubset>val v1" unfolding PosOrd_ex_eq2 by auto
  moreover
    { assume "vposix :\<sqsubset>val v1"
      moreover
      have "vposix \<in> LV r s" using vp
         using Posix_LV by blast
      ultimately have "False" using assms(2) by blast
    }
  ultimately show "s \<in> r \<rightarrow> v1" using vp by blast
qed

lemma Least_existence:
  assumes "LV r s \<noteq> {}"
  shows " \<exists>vmin \<in> LV r s. \<forall>v \<in> LV r s. vmin :\<sqsubseteq>val v"
proof -
  from assms
  obtain vposix where "s \<in> r \<rightarrow> vposix"
  unfolding LV_def
  using L_flat_Prf1 lexer_correct_Some by blast
  then have "\<forall>v \<in> LV r s. vposix :\<sqsubseteq>val v"
    by (simp add: Posix_PosOrd)
  then show "\<exists>vmin \<in> LV r s. \<forall>v \<in> LV r s. vmin :\<sqsubseteq>val v"
    using Posix_LV \<open>s \<in> r \<rightarrow> vposix\<close> by blast
qed

lemma Least_existence1:
  assumes "LV r s \<noteq> {}"
  shows " \<exists>!vmin \<in> LV r s. \<forall>v \<in> LV r s. vmin :\<sqsubseteq>val v"
using Least_existence[OF assms] assms
  using PosOrdeq_antisym by blast

lemma Least_existence1_pre:
  assumes "LV r s \<noteq> {}"
  shows " \<exists>!vmin \<in> LV r s. \<forall>v \<in> (LV r s \<union> {v'. flat v' \<sqsubset>spre s}). vmin :\<sqsubseteq>val v"
using Least_existence[OF assms] assms
apply -
apply(erule bexE)
apply(rule_tac a="vmin" in ex1I)
apply(auto)[1]
apply (metis PosOrd_Posix PosOrd_ex_eq2 PosOrd_spreI PosOrdeq_antisym Posix1(2))
apply(auto)[1]
apply(simp add: PosOrdeq_antisym)
done

lemma
  shows "partial_order_on UNIV {(v1, v2). v1 :\<sqsubseteq>val v2}"
apply(simp add: partial_order_on_def)
apply(simp add: preorder_on_def refl_on_def)
apply(simp add: PosOrdeq_refl)
apply(auto)
apply(rule transI)
apply(auto intro: PosOrdeq_trans)[1]
apply(rule antisymI)
apply(simp add: PosOrdeq_antisym)
done

lemma
 "wf {(v1, v2). v1 :\<sqsubset>val v2 \<and> v1 \<in> LV r s \<and> v2 \<in> LV r s}"
apply(rule finite_acyclic_wf)
prefer 2
apply(simp add: acyclic_def)
apply(induct_tac rule: trancl.induct)
     apply(auto)[1]
    prefer 3

oops

unused_thms

end


theory mp1_isar
imports Main
begin

(* lemma problem1: "(A \<and> B) \<longrightarrow> (B \<and> A)" *)
thm conjE (* \<lbrakk>?P \<and> ?Q; \<lbrakk>?P; ?Q\<rbrakk> \<Longrightarrow> ?R\<rbrakk> \<Longrightarrow> ?R *)
thm conjI (* \<lbrakk>?P; ?Q\<rbrakk> \<Longrightarrow> ?P \<and> ?Q *)

lemma problem1_attempt5:
  shows"(A \<and> B) \<longrightarrow> (B \<and> A)"
proof (rule impI)
  assume "A \<and> B"
  show "B \<and> A" using `A \<and> B`
  proof (rule conjE)
    assume B and A
    show "B \<and> A" using `B` `A` by (rule conjI)
  qed
qed

(*
lemma problem1_attempt6:
  shows"(A \<and> B) \<longrightarrow> (B \<and> A)"
proof (rule impI)
  assume "A \<and> B"
  show "B \<and> A" using `A \<and> B`
  proof -
    apply (rule conjE)
    assume B and A
    show "B \<and> A" using `B` `A` by (rule conjI)
  qed
qed
*)

(* lemma problem2: "(A \<or> B) \<longrightarrow> (B \<or> A)" *)

thm disjE (* \<lbrakk>?P \<or> ?Q; ?P \<Longrightarrow> ?R; ?Q \<Longrightarrow> ?R\<rbrakk> \<Longrightarrow> ?R *)
thm disjI1 (* ?P \<Longrightarrow> ?P \<or> ?Q *)

lemma
  shows "(A \<or> B) \<longrightarrow> (B \<or> A)"
proof
  assume "A \<or> B"
  show "B \<or> A" using `A \<or> B`
  proof (rule disjE)
    show "A \<Longrightarrow> B \<or> A" by (rule disjI2)
    show "B \<Longrightarrow> B \<or> A" by (rule disjI1)
  qed
qed

(* lemma problem3: "(A \<and> B) \<longrightarrow> ((\<not>B) \<longrightarrow> (\<not>A))" *)
thm notI (* (?P \<Longrightarrow> False) \<Longrightarrow> \<not> ?P *)
thm notE (* \<lbrakk>\<not> ?P; ?P\<rbrakk> \<Longrightarrow> ?R *)
thm conjE (* \<lbrakk>?P \<and> ?Q; \<lbrakk>?P; ?Q\<rbrakk> \<Longrightarrow> ?R\<rbrakk> \<Longrightarrow> ?R *)
lemma
  shows "(A \<and> B) \<longrightarrow> ((\<not>B) \<longrightarrow> (\<not>A))"
proof (rule impI)
  assume AnB: "A \<and> B"
  have A: "A" using AnB by (rule conjE)
  have B: "B" using AnB by (rule conjE)
  show nB2nA: "(\<not>B) \<longrightarrow> (\<not>A)" proof (rule impI)
    assume nB: "\<not> B"
    show "\<not> A" proof (rule notI)
      from nB B show "False" by (rule notE)
    qed
  qed
qed

(* lemma problem5: "((A \<and> B) \<longrightarrow> C) \<longrightarrow> (A \<longrightarrow> (B \<longrightarrow> C))" *)
thm impE (* *)
lemma my_mp: "\<lbrakk>A;A\<longrightarrow>B\<rbrakk>\<Longrightarrow>B" by (erule impE)
thm impI

lemma "\<lbrakk>A \<Longrightarrow> B \<Longrightarrow> C \<rbrakk> \<Longrightarrow> (A \<longrightarrow> B \<longrightarrow> C)"
  apply (rule impI)
  apply (rule impI)
  by assumption

lemma
  shows "((A \<and> B) \<longrightarrow> C) \<longrightarrow> (A \<longrightarrow> (B \<longrightarrow> C))"
proof (rule impI)
  assume AnBiC: "(A \<and> B) \<longrightarrow> C"
  have A2B2C: "A \<Longrightarrow> B \<Longrightarrow> C" using AnBiC proof-
    assume A: A and B: B
    have AnB: "A \<and> B" using A B by (rule conjI)
    show C: "C" using AnB AnBiC by (rule my_mp)
  qed
  have Big2Big: "\<lbrakk>A \<Longrightarrow> B \<Longrightarrow> C \<rbrakk> \<Longrightarrow> (A \<longrightarrow> B \<longrightarrow> C)" proof (rule impI)
    show "\<lbrakk>\<lbrakk>A; B\<rbrakk> \<Longrightarrow> C; A\<rbrakk> \<Longrightarrow> B \<longrightarrow> C" proof (rule impI)
      show "\<lbrakk>\<lbrakk>A; B\<rbrakk> \<Longrightarrow> C; A; B\<rbrakk> \<Longrightarrow> C" by assumption
    qed
  qed
  (* show "(A \<longrightarrow> B \<longrightarrow> C)" using A2B2C Big2Big by (drule my_mp) *)
  oops

end


section "Immutable Arrays with Code Generation"

theory IArray
imports Main
begin

text{* Immutable arrays are lists wrapped up in an additional constructor.
There are no update operations. Hence code generation can safely implement
this type by efficient target language arrays.  Currently only SML is
provided. Should be extended to other target languages and more operations.

Note that arrays cannot be printed directly but only by turning them into
lists first. Arrays could be converted back into lists for printing if they
were wrapped up in an additional constructor. *}

datatype 'a iarray = IArray "'a list"

primrec list_of :: "'a iarray \<Rightarrow> 'a list" where
"list_of (IArray xs) = xs"
hide_const (open) list_of

definition of_fun :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a iarray" where
[simp]: "of_fun f n = IArray (map f [0..<n])"
hide_const (open) of_fun

definition sub :: "'a iarray \<Rightarrow> nat \<Rightarrow> 'a" (infixl "!!" 100) where
[simp]: "as !! n = IArray.list_of as ! n"
hide_const (open) sub

definition length :: "'a iarray \<Rightarrow> nat" where
[simp]: "length as = List.length (IArray.list_of as)"
hide_const (open) length

fun all :: "('a \<Rightarrow> bool) \<Rightarrow> 'a iarray \<Rightarrow> bool" where
"all p (IArray as) = (ALL a : set as. p a)"
hide_const (open) all

fun exists :: "('a \<Rightarrow> bool) \<Rightarrow> 'a iarray \<Rightarrow> bool" where
"exists p (IArray as) = (EX a : set as. p a)"
hide_const (open) exists

lemma list_of_code [code]:
"IArray.list_of as = map (\<lambda>n. as !! n) [0 ..< IArray.length as]"
by (cases as) (simp add: map_nth)

subsection "Code Generation"

code_reserved SML Vector

code_printing
  type_constructor iarray \<rightharpoonup> (SML) "_ Vector.vector"
| constant IArray \<rightharpoonup> (SML) "Vector.fromList"
| constant IArray.all \<rightharpoonup> (SML) "Vector.all"
| constant IArray.exists \<rightharpoonup> (SML) "Vector.exists"

lemma [code]:
  "size_iarray f as = Suc (size_list f (IArray.list_of as))"
  by (cases as) simp

lemma [code]:
  "rec_iarray f as = f (IArray.list_of as)"
  by (cases as) simp

lemma [code]:
  "case_iarray f as = f (IArray.list_of as)"
  by (cases as) simp

lemma [code]:
  "set_iarray as = set (IArray.list_of as)"
  by (case_tac as) auto

lemma [code]:
  "map_iarray f as = IArray (map f (IArray.list_of as))"
  by (case_tac as) auto

lemma [code]:
  "rel_iarray r as bs = list_all2 r (IArray.list_of as) (IArray.list_of bs)"
  by (case_tac as) (case_tac bs, auto)

lemma [code]:
  "HOL.equal as bs \<longleftrightarrow> HOL.equal (IArray.list_of as) (IArray.list_of bs)"
  by (cases as, cases bs) (simp add: equal)

primrec tabulate :: "integer \<times> (integer \<Rightarrow> 'a) \<Rightarrow> 'a iarray" where
  "tabulate (n, f) = IArray (map (f \<circ> integer_of_nat) [0..<nat_of_integer n])"

hide_const (open) tabulate

lemma [code]:
  "IArray.of_fun f n = IArray.tabulate (integer_of_nat n, f \<circ> nat_of_integer)"
  by simp

code_printing
  constant IArray.tabulate \<rightharpoonup> (SML) "Vector.tabulate"

primrec sub' :: "'a iarray \<times> integer \<Rightarrow> 'a" where
  [code del]: "sub' (as, n) = IArray.list_of as ! nat_of_integer n"

hide_const (open) sub'

lemma [code]:
  "IArray.sub' (IArray as, n) = as ! nat_of_integer n"
  by simp

lemma [code]:
  "as !! n = IArray.sub' (as, integer_of_nat n)"
  by simp

code_printing
  constant IArray.sub' \<rightharpoonup> (SML) "Vector.sub"

definition length' :: "'a iarray \<Rightarrow> integer" where
  [code del, simp]: "length' as = integer_of_nat (List.length (IArray.list_of as))"

hide_const (open) length'

lemma [code]:
  "IArray.length' (IArray as) = integer_of_nat (List.length as)"
  by simp

lemma [code]:
  "IArray.length as = nat_of_integer (IArray.length' as)"
  by simp

code_printing
  constant IArray.length' \<rightharpoonup> (SML) "Vector.length"

end


(*  Title:      CTT/ex/Elimination.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge

Some examples taken from P. Martin-L\"of, Intuitionistic type theory
(Bibliopolis, 1984).
*)

section "Examples with elimination rules"

theory Elimination
imports "../CTT"
begin

text "This finds the functions fst and snd!"

schematic_lemma [folded basic_defs]: "A type \<Longrightarrow> ?a : (A*A) --> A"
apply pc
done

schematic_lemma [folded basic_defs]: "A type \<Longrightarrow> ?a : (A*A) --> A"
apply pc
back
done

text "Double negation of the Excluded Middle"
schematic_lemma "A type \<Longrightarrow> ?a : ((A + (A-->F)) --> F) --> F"
apply intr
apply (rule ProdE)
apply assumption
apply pc
done

schematic_lemma "\<lbrakk>A type; B type\<rbrakk> \<Longrightarrow> ?a : (A*B) \<longrightarrow> (B*A)"
apply pc
done
(*The sequent version (ITT) could produce an interesting alternative
  by backtracking.  No longer.*)

text "Binary sums and products"
schematic_lemma "\<lbrakk>A type; B type; C type\<rbrakk> \<Longrightarrow> ?a : (A+B --> C) --> (A-->C) * (B-->C)"
apply pc
done

(*A distributive law*)
schematic_lemma "\<lbrakk>A type; B type; C type\<rbrakk> \<Longrightarrow> ?a : A * (B+C)  -->  (A*B + A*C)"
apply pc
done

(*more general version, same proof*)
schematic_lemma
  assumes "A type"
    and "\<And>x. x:A \<Longrightarrow> B(x) type"
    and "\<And>x. x:A \<Longrightarrow> C(x) type"
  shows "?a : (SUM x:A. B(x) + C(x)) --> (SUM x:A. B(x)) + (SUM x:A. C(x))"
apply (pc assms)
done

text "Construction of the currying functional"
schematic_lemma "\<lbrakk>A type; B type; C type\<rbrakk> \<Longrightarrow> ?a : (A*B --> C) --> (A--> (B-->C))"
apply pc
done

(*more general goal with same proof*)
schematic_lemma
  assumes "A type"
    and "\<And>x. x:A \<Longrightarrow> B(x) type"
    and "\<And>z. z: (SUM x:A. B(x)) \<Longrightarrow> C(z) type"
  shows "?a : PROD f: (PROD z : (SUM x:A . B(x)) . C(z)).
                      (PROD x:A . PROD y:B(x) . C(<x,y>))"
apply (pc assms)
done

text "Martin-Lof (1984), page 48: axiom of sum-elimination (uncurry)"
schematic_lemma "\<lbrakk>A type; B type; C type\<rbrakk> \<Longrightarrow> ?a : (A --> (B-->C)) --> (A*B --> C)"
apply pc
done

(*more general goal with same proof*)
schematic_lemma
  assumes "A type"
    and "\<And>x. x:A \<Longrightarrow> B(x) type"
    and "\<And>z. z: (SUM x:A . B(x)) \<Longrightarrow> C(z) type"
  shows "?a : (PROD x:A . PROD y:B(x) . C(<x,y>))
        --> (PROD z : (SUM x:A . B(x)) . C(z))"
apply (pc assms)
done

text "Function application"
schematic_lemma "\<lbrakk>A type; B type\<rbrakk> \<Longrightarrow> ?a : ((A --> B) * A) --> B"
apply pc
done

text "Basic test of quantifier reasoning"
schematic_lemma
  assumes "A type"
    and "B type"
    and "\<And>x y. \<lbrakk>x:A; y:B\<rbrakk> \<Longrightarrow> C(x,y) type"
  shows
    "?a :     (SUM y:B . PROD x:A . C(x,y))
          --> (PROD x:A . SUM y:B . C(x,y))"
apply (pc assms)
done

text "Martin-Lof (1984) pages 36-7: the combinator S"
schematic_lemma
  assumes "A type"
    and "\<And>x. x:A \<Longrightarrow> B(x) type"
    and "\<And>x y. \<lbrakk>x:A; y:B(x)\<rbrakk> \<Longrightarrow> C(x,y) type"
  shows "?a :    (PROD x:A. PROD y:B(x). C(x,y))
             --> (PROD f: (PROD x:A. B(x)). PROD x:A. C(x, f`x))"
apply (pc assms)
done

text "Martin-Lof (1984) page 58: the axiom of disjunction elimination"
schematic_lemma
  assumes "A type"
    and "B type"
    and "\<And>z. z: A+B \<Longrightarrow> C(z) type"
  shows "?a : (PROD x:A. C(inl(x))) --> (PROD y:B. C(inr(y)))
          --> (PROD z: A+B. C(z))"
apply (pc assms)
done

(*towards AXIOM OF CHOICE*)
schematic_lemma [folded basic_defs]:
  "\<lbrakk>A type; B type; C type\<rbrakk> \<Longrightarrow> ?a : (A --> B*C) --> (A-->B) * (A-->C)"
apply pc
done

(*Martin-Lof (1984) page 50*)
text "AXIOM OF CHOICE!  Delicate use of elimination rules"
schematic_lemma
  assumes "A type"
    and "\<And>x. x:A \<Longrightarrow> B(x) type"
    and "\<And>x y. \<lbrakk>x:A; y:B(x)\<rbrakk> \<Longrightarrow> C(x,y) type"
  shows "?a : PROD h: (PROD x:A. SUM y:B(x). C(x,y)).
                         (SUM f: (PROD x:A. B(x)). PROD x:A. C(x, f`x))"
apply (intr assms)
prefer 2 apply add_mp
prefer 2 apply add_mp
apply (erule SumE_fst)
apply (rule replace_type)
apply (rule subst_eqtyparg)
apply (rule comp_rls)
apply (rule_tac [4] SumE_snd)
apply (typechk SumE_fst assms)
done

text "Axiom of choice.  Proof without fst, snd.  Harder still!"
schematic_lemma [folded basic_defs]:
  assumes "A type"
    and "\<And>x. x:A \<Longrightarrow> B(x) type"
    and "\<And>x y. \<lbrakk>x:A; y:B(x)\<rbrakk> \<Longrightarrow> C(x,y) type"
  shows "?a : PROD h: (PROD x:A. SUM y:B(x). C(x,y)).
                         (SUM f: (PROD x:A. B(x)). PROD x:A. C(x, f`x))"
apply (intr assms)
(*Must not use add_mp as subst_prodE hides the construction.*)
apply (rule ProdE [THEN SumE])
apply assumption
apply assumption
apply assumption
apply (rule replace_type)
apply (rule subst_eqtyparg)
apply (rule comp_rls)
apply (erule_tac [4] ProdE [THEN SumE])
apply (typechk assms)
apply (rule replace_type)
apply (rule subst_eqtyparg)
apply (rule comp_rls)
apply (typechk assms)
apply assumption
done

text "Example of sequent_style deduction"
(*When splitting z:A*B, the assumption C(z) is affected;  ?a becomes
    lam u. split(u,\<lambda>v w.split(v,\<lambda>x y.lam z. <x,<y,z>>) ` w)     *)
schematic_lemma
  assumes "A type"
    and "B type"
    and "\<And>z. z:A*B \<Longrightarrow> C(z) type"
  shows "?a : (SUM z:A*B. C(z)) --> (SUM u:A. SUM v:B. C(<u,v>))"
apply (rule intr_rls)
apply (tactic {* biresolve_tac safe_brls 2 *})
(*Now must convert assumption C(z) into antecedent C(<kd,ke>) *)
apply (rule_tac [2] a = "y" in ProdE)
apply (typechk assms)
apply (rule SumE, assumption)
apply intr
defer 1
apply assumption+
apply (typechk assms)
done

end


(*  Title:       The Applicative Recursive Path Order for Lambda-Free Higher-Order Terms
    Author:      Jasmin Blanchette <jasmin.blanchette at inria.fr>, 2016
    Maintainer:  Jasmin Blanchette <jasmin.blanchette at inria.fr>
*)

section \<open>The Applicative Recursive Path Order for Lambda-Free Higher-Order Terms\<close>

theory Lambda_Free_RPO_App
imports Lambda_Free_Term Extension_Orders
abbrevs ">t" = ">\<^sub>t"
  and "\<ge>t" = "\<ge>\<^sub>t"
begin

text \<open>
This theory defines the applicative recursive path order (RPO), a variant of RPO
for \<open>\<lambda>\<close>-free higher-order terms. It corresponds to the order obtained by
applying the standard first-order RPO on the applicative encoding of higher-order
terms and assigning the lowest precedence to the application symbol.
\<close>

locale rpo_app = gt_sym "(>\<^sub>s)"
    for gt_sym :: "'s \<Rightarrow> 's \<Rightarrow> bool" (infix ">\<^sub>s" 50) +
  fixes ext :: "(('s, 'v) tm \<Rightarrow> ('s, 'v) tm \<Rightarrow> bool) \<Rightarrow> ('s, 'v) tm list \<Rightarrow> ('s, 'v) tm list \<Rightarrow> bool"
  assumes
    ext_ext_trans_before_irrefl: "ext_trans_before_irrefl ext" and
    ext_ext_compat_list: "ext_compat_list ext"
begin

lemma ext_mono[mono]: "gt \<le> gt' \<Longrightarrow> ext gt \<le> ext gt'"
  by (simp add: ext.mono ext_ext_compat_list[unfolded ext_compat_list_def, THEN conjunct1])

inductive gt :: "('s, 'v) tm \<Rightarrow> ('s, 'v) tm \<Rightarrow> bool" (infix ">\<^sub>t" 50) where
  gt_sub: "is_App t \<Longrightarrow> (fun t >\<^sub>t s \<or> fun t = s) \<or> (arg t >\<^sub>t s \<or> arg t = s) \<Longrightarrow> t >\<^sub>t s"
| gt_sym_sym: "g >\<^sub>s f \<Longrightarrow> Hd (Sym g) >\<^sub>t Hd (Sym f)"
| gt_sym_app: "Hd (Sym g) >\<^sub>t s1 \<Longrightarrow> Hd (Sym g) >\<^sub>t s2 \<Longrightarrow> Hd (Sym g) >\<^sub>t App s1 s2"
| gt_app_app: "ext (>\<^sub>t) [t1, t2] [s1, s2] \<Longrightarrow> App t1 t2 >\<^sub>t s1 \<Longrightarrow> App t1 t2 >\<^sub>t s2 \<Longrightarrow>
    App t1 t2 >\<^sub>t App s1 s2"

abbreviation ge :: "('s, 'v) tm \<Rightarrow> ('s, 'v) tm \<Rightarrow> bool" (infix "\<ge>\<^sub>t" 50) where
  "t \<ge>\<^sub>t s \<equiv> t >\<^sub>t s \<or> t = s"

end

end


section \<open> UTP Variables \<close>

theory utp_var
  imports
  "UTP-Toolkit.utp_toolkit"
  utp_parser_utils
begin

text \<open> In this first UTP theory we set up variables, which are are built on lenses~\cite{Foster09,Foster16a}.
  A large part of this theory is setting up the parser for UTP variable syntax. \<close>

subsection \<open> Initial syntax setup \<close>

text \<open> We will overload the square order relation with refinement and also the lattice operators so
  we will turn off these notations. \<close>

purge_notation
  Order.le (infixl "\<sqsubseteq>\<index>" 50) and
  Lattice.sup ("\<Squnion>\<index>_" [90] 90) and
  Lattice.inf ("\<Sqinter>\<index>_" [90] 90) and
  Lattice.join (infixl "\<squnion>\<index>" 65) and
  Lattice.meet (infixl "\<sqinter>\<index>" 70) and
  Set.member ("op :") and
  Set.member ("(_/ : _)" [51, 51] 50) and
  disj  (infixr "|" 30) and
  conj  (infixr "&" 35)

declare fst_vwb_lens [simp]
declare snd_vwb_lens [simp]
declare comp_vwb_lens [simp]
declare lens_indep_left_ext [simp]
declare lens_indep_right_ext [simp]
declare lens_comp_quotient [simp]
declare plus_lens_distr [THEN sym, simp]

subsection \<open> Variable foundations \<close>

text \<open> This theory describes the foundational structure of UTP variables, upon which the rest
  of our model rests. We start by defining alphabets, which following~\cite{Feliachi2010,Feliachi2012}
  in this shallow model are simply represented as types @{typ "'\<alpha>"}, though by convention usually a record
  type where each field corresponds to a variable. UTP variables in this frame are simply modelled
  as lenses @{typ "'a \<Longrightarrow> '\<alpha>"}, where the view type @{typ "'a"} is the variable type, and the
  source type \<open>'\<alpha>\<close> is the alphabet or state-space type.

  We define some lifting functions for variables to create input and output variables.
  These simply lift the alphabet to a tuple type since relations will ultimately be defined
  by a tuple alphabet.
\<close>

definition in_var :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> ('a \<Longrightarrow> '\<alpha> \<times> '\<beta>)" where
[lens_defs]: "in_var x = x ;\<^sub>L fst\<^sub>L"

definition out_var :: "('a \<Longrightarrow> '\<beta>) \<Rightarrow> ('a \<Longrightarrow> '\<alpha> \<times> '\<beta>)" where
[lens_defs]: "out_var x = x ;\<^sub>L snd\<^sub>L"

text \<open> Variables can also be used to effectively define sets of variables. Here we define the
  the universal alphabet ($\Sigma$) to be the bijective lens @{term "1\<^sub>L"}. This characterises
  the whole of the source type, and thus is effectively the set of all alphabet variables. \<close>

abbreviation (input) univ_alpha :: "('\<alpha> \<Longrightarrow> '\<alpha>)" ("\<Sigma>") where
"univ_alpha \<equiv> 1\<^sub>L"

text \<open> The next construct is vacuous and simply exists to help the parser distinguish predicate
  variables from input and output variables. \<close>

definition pr_var :: "('a \<Longrightarrow> '\<beta>) \<Rightarrow> ('a \<Longrightarrow> '\<beta>)" where
[lens_defs]: "pr_var x = x"

subsection \<open> Variable lens properties \<close>

text \<open> We can now easily show that our UTP variable construction are various classes of
  well-behaved lens .\<close>

lemma in_var_weak_lens [simp]:
  "weak_lens x \<Longrightarrow> weak_lens (in_var x)"
  by (simp add: comp_weak_lens in_var_def)

lemma in_var_semi_uvar [simp]:
  "mwb_lens x \<Longrightarrow> mwb_lens (in_var x)"
  by (simp add: comp_mwb_lens in_var_def)

lemma pr_var_weak_lens [simp]:
  "weak_lens x \<Longrightarrow> weak_lens (pr_var x)"
  by (simp add: pr_var_def)

lemma pr_var_mwb_lens [simp]:
  "mwb_lens x \<Longrightarrow> mwb_lens (pr_var x)"
  by (simp add: pr_var_def)

lemma pr_var_vwb_lens [simp]:
  "vwb_lens x \<Longrightarrow> vwb_lens (pr_var x)"
  by (simp add: pr_var_def)

lemma in_var_uvar [simp]:
  "vwb_lens x \<Longrightarrow> vwb_lens (in_var x)"
  by (simp add: in_var_def)

lemma out_var_weak_lens [simp]:
  "weak_lens x \<Longrightarrow> weak_lens (out_var x)"
  by (simp add: comp_weak_lens out_var_def)

lemma out_var_semi_uvar [simp]:
  "mwb_lens x \<Longrightarrow> mwb_lens (out_var x)"
  by (simp add: comp_mwb_lens out_var_def)

lemma out_var_uvar [simp]:
  "vwb_lens x \<Longrightarrow> vwb_lens (out_var x)"
  by (simp add: out_var_def)

text \<open> Moreover, we can show that input and output variables are independent, since they refer
  to different sections of the alphabet. \<close>

lemma out_in_indep [simp]:
  "out_var x \<bowtie> in_var y"
  by (simp add: lens_indep_def in_var_def out_var_def fst_lens_def snd_lens_def lens_comp_def)

lemma in_var_indep [simp]:
  "x \<bowtie> y \<Longrightarrow> in_var x \<bowtie> in_var y"
  by (simp add: in_var_def out_var_def)

lemma out_var_indep [simp]:
  "x \<bowtie> y \<Longrightarrow> out_var x \<bowtie> out_var y"
  by (simp add: out_var_def)

lemma pr_var_indeps [simp]:
  "x \<bowtie> y \<Longrightarrow> pr_var x \<bowtie> y"
  "x \<bowtie> y \<Longrightarrow> x \<bowtie> pr_var y"
  by (simp_all add: pr_var_def)

lemma prod_lens_indep_in_var [simp]:
  "a \<bowtie> x \<Longrightarrow> a \<times>\<^sub>L b \<bowtie> in_var x"
  by (metis in_var_def in_var_indep out_in_indep out_var_def plus_pres_lens_indep prod_as_plus)

lemma prod_lens_indep_out_var [simp]:
  "b \<bowtie> x \<Longrightarrow> a \<times>\<^sub>L b \<bowtie> out_var x"
  by (metis in_out_indep in_var_def out_var_def out_var_indep plus_pres_lens_indep prod_as_plus)

lemma in_var_pr_var [simp]:
  "in_var (pr_var x) = in_var x"
  by (simp add: pr_var_def)

lemma out_var_pr_var [simp]:
  "out_var (pr_var x) = out_var x"
  by (simp add: pr_var_def)

lemma pr_var_idem [simp]:
  "pr_var (pr_var x) = pr_var x"
  by (simp add: pr_var_def)

lemma pr_var_lens_plus [simp]:
  "pr_var (x +\<^sub>L y) = (x +\<^sub>L y)"
  by (simp add: pr_var_def)

lemma pr_var_lens_comp_1 [simp]:
  "pr_var x ;\<^sub>L y = pr_var (x ;\<^sub>L y)"
  by (simp add: pr_var_def)

lemma in_var_plus [simp]: "in_var (x +\<^sub>L y) = in_var x +\<^sub>L in_var y"
  by (simp add: in_var_def)

lemma out_var_plus [simp]: "out_var (x +\<^sub>L y) = out_var x +\<^sub>L out_var y"
  by (simp add: out_var_def)

text \<open> Similar properties follow for sublens \<close>

lemma in_var_sublens [simp]:
  "y \<subseteq>\<^sub>L x \<Longrightarrow> in_var y \<subseteq>\<^sub>L in_var x"
  by (metis (no_types, hide_lams) in_var_def lens_comp_assoc sublens_def)

lemma out_var_sublens [simp]:
  "y \<subseteq>\<^sub>L x \<Longrightarrow> out_var y \<subseteq>\<^sub>L out_var x"
  by (metis (no_types, hide_lams) out_var_def lens_comp_assoc sublens_def)

lemma pr_var_sublens [simp]:
  "y \<subseteq>\<^sub>L x \<Longrightarrow> pr_var y \<subseteq>\<^sub>L pr_var x"
  by (simp add: pr_var_def)

subsection \<open> Lens simplifications \<close>

text \<open> We also define some lookup abstraction simplifications. \<close>

lemma var_lookup_in [simp]: "lens_get (in_var x) (A, A') = lens_get x A"
  by (simp add: in_var_def fst_lens_def lens_comp_def)

lemma var_lookup_out [simp]: "lens_get (out_var x) (A, A') = lens_get x A'"
  by (simp add: out_var_def snd_lens_def lens_comp_def)

lemma var_update_in [simp]: "lens_put (in_var x) (A, A') v = (lens_put x A v, A')"
  by (simp add: in_var_def fst_lens_def lens_comp_def)

lemma var_update_out [simp]: "lens_put (out_var x) (A, A') v = (A, lens_put x A' v)"
  by (simp add: out_var_def snd_lens_def lens_comp_def)

lemma get_lens_plus [simp]: "get\<^bsub>x +\<^sub>L y\<^esub> s = (get\<^bsub>x\<^esub> s, get\<^bsub>y\<^esub> s)"
  by (simp add: lens_defs)

subsection \<open> Syntax translations \<close>

text \<open> In order to support nice syntax for variables, we here set up some translations. The first
  step is to introduce a collection of non-terminals. \<close>

nonterminal svid and svids and svar and svars and salpha

text \<open> These non-terminals correspond to the following syntactic entities. Non-terminal
  @{typ "svid"} is an atomic variable identifier, and @{typ "svids"} is a list of identifier.
  @{typ "svar"} is a decorated variable, such as an input or output variable, and @{typ "svars"} is
  a list of decorated variables. @{typ "salpha"} is an alphabet or set of variables. Such sets can
  be constructed only through lens composition due to typing restrictions. Next we introduce some
  syntax constructors. \<close>

syntax \<comment> \<open> Identifiers \<close>
  "_svid"         :: "id \<Rightarrow> svid" ("_" [999] 999)
  "_svid_unit"    :: "svid \<Rightarrow> svids" ("_")
  "_svid_list"    :: "svid \<Rightarrow> svids \<Rightarrow> svids" ("_,/ _")
  "_svid_alpha"   :: "svid" ("\<^bold>v")
  "_svid_dot"     :: "svid \<Rightarrow> svid \<Rightarrow> svid" ("_:_" [998,999] 998)
  "_mk_svid_list" :: "svids \<Rightarrow> logic" \<comment> \<open> Helper function for summing a list of identifiers \<close>

text \<open> A variable identifier can either be a HOL identifier, the complete set of variables in the
  alphabet $\textbf{v}$, or a composite identifier separated by colons, which
  corresponds to a sort of qualification. The final option is effectively a lens composition. \<close>

syntax \<comment> \<open> Decorations \<close>
  "_spvar"       :: "svid \<Rightarrow> svar" ("&_" [990] 990)
  "_sinvar"      :: "svid \<Rightarrow> svar" ("$_" [990] 990)
  "_soutvar"     :: "svid \<Rightarrow> svar" ("$_\<acute>" [990] 990)

text \<open> A variable can be decorated with an ampersand, to indicate it is a predicate variable, with
  a dollar to indicate its an unprimed relational variable, or a dollar and ``acute'' symbol to
  indicate its a primed relational variable. Isabelle's parser is extensible so additional
  decorations can be and are added later. \<close>

syntax \<comment> \<open> Variable sets \<close>
  "_salphaid"    :: "svid \<Rightarrow> salpha" ("_" [990] 990)
  "_salphavar"   :: "svar \<Rightarrow> salpha" ("_" [990] 990)
  "_salphaparen" :: "salpha \<Rightarrow> salpha" ("'(_')")
  "_salphacomp"  :: "salpha \<Rightarrow> salpha \<Rightarrow> salpha" (infixr ";" 75)
  "_salphaprod"  :: "salpha \<Rightarrow> salpha \<Rightarrow> salpha" (infixr "\<times>" 85)
  "_salpha_all"  :: "salpha" ("\<Sigma>")
  "_salpha_none" :: "salpha" ("\<emptyset>")
  "_svar_nil"    :: "svar \<Rightarrow> svars" ("_")
  "_svar_cons"   :: "svar \<Rightarrow> svars \<Rightarrow> svars" ("_,/ _")
  "_salphaset"   :: "svars \<Rightarrow> salpha" ("{_}")
  "_salphamk"    :: "logic \<Rightarrow> salpha"

text \<open> The terminals of an alphabet are either HOL identifiers or UTP variable identifiers.
  We support two ways of constructing alphabets; by composition of smaller alphabets using
  a semi-colon or by a set-style construction $\{a,b,c\}$ with a list of UTP variables. \<close>

syntax \<comment> \<open> Quotations \<close>
  "_ualpha_set"  :: "svars \<Rightarrow> logic" ("{_}\<^sub>\<alpha>")
  "_svar"        :: "svar \<Rightarrow> logic" ("'(_')\<^sub>v")

text \<open> For various reasons, the syntax constructors above all yield specific grammar categories and
  will not parser at the HOL top level (basically this is to do with us wanting to reuse the syntax
  for expressions). As a result we provide some quotation constructors above.

  Next we need to construct the syntax translations rules. First we need a few polymorphic constants. \<close>

consts
  svar :: "'v \<Rightarrow> 'e"
  ivar :: "'v \<Rightarrow> 'e"
  ovar :: "'v \<Rightarrow> 'e"

adhoc_overloading
  svar pr_var and ivar in_var and ovar out_var

text \<open> The functions above turn a representation of a variable (type @{typ "'v"}), including
  its name and type, into some lens type @{typ "'e"}. @{term "svar"} constructs a predicate variable,
  @{term "ivar"} and input variables, and @{term "ovar"} and output variable. The functions bridge
  between the model and encoding of the variable and its interpretation as a lens in order to integrate it
  into the general lens-based framework. Overriding these functions is then all we need to make
  use of any kind of variables in terms of interfacing it with the system. Although in core UTP
  variables are always modelled using record field, we can overload these constants to allow other
  kinds of variables, such as deep variables with explicit syntax and type information.

  Finally, we set up the translations rules. \<close>

translations
  \<comment> \<open> Identifiers \<close>
  "_svid x" \<rightharpoonup> "x"
  "_svid_alpha" \<rightleftharpoons> "\<Sigma>"
  "_svid_dot x y" \<rightharpoonup> "y ;\<^sub>L x"
  "_mk_svid_list (_svid_unit x)" \<rightharpoonup> "x"
  "_mk_svid_list (_svid_list x xs)" \<rightharpoonup> "x +\<^sub>L _mk_svid_list xs"

  \<comment> \<open> Decorations \<close>
  "_spvar \<Sigma>"  \<leftharpoondown>  "CONST svar CONST id_lens"
  "_sinvar \<Sigma>"  \<leftharpoondown> "CONST ivar 1\<^sub>L"
  "_soutvar \<Sigma>" \<leftharpoondown> "CONST ovar 1\<^sub>L"
  "_spvar (_svid_dot x y)" \<leftharpoondown> "CONST svar (CONST lens_comp y x)"
  "_sinvar (_svid_dot x y)" \<leftharpoondown> "CONST ivar (CONST lens_comp y x)"
  "_soutvar (_svid_dot x y)" \<leftharpoondown> "CONST ovar (CONST lens_comp y x)"
  "_svid_dot (_svid_dot x y) z" \<leftharpoondown> "_svid_dot (CONST lens_comp y x) z"

  "_spvar x" \<rightleftharpoons> "CONST svar x"
  "_sinvar x" \<rightleftharpoons> "CONST ivar x"
  "_soutvar x" \<rightleftharpoons> "CONST ovar x"

  \<comment> \<open> Alphabets \<close>
  "_salphaparen a" \<rightharpoonup> "a"
  "_salphaid x" \<rightharpoonup> "x"
  "_salphacomp x y" \<rightharpoonup> "x +\<^sub>L y"
  "_salphaprod a b" \<rightleftharpoons> "a \<times>\<^sub>L b"
  "_salphavar x" \<rightharpoonup> "x"
  "_svar_nil x" \<rightharpoonup> "x"
  "_svar_cons x xs" \<rightharpoonup> "x +\<^sub>L xs"
  "_salphaset A" \<rightharpoonup> "A"
  "(_svar_cons x (_salphamk y))" \<leftharpoondown> "_salphamk (x +\<^sub>L y)"
  "x" \<leftharpoondown> "_salphamk x"
  "_salpha_all" \<rightleftharpoons> "1\<^sub>L"
  "_salpha_none" \<rightleftharpoons> "0\<^sub>L"

  \<comment> \<open> Quotations \<close>
  "_ualpha_set A" \<rightharpoonup> "A"
  "_svar x" \<rightharpoonup> "x"

text \<open> The translation rules mainly convert syntax into lens constructions, using a mixture
  of lens operators and the bespoke variable definitions. Notably, a colon variable identifier
  qualification becomes a lens composition, and variable sets are constructed using len sum.
  The translation rules are carefully crafted to ensure both parsing and pretty printing.

  Finally we create the following useful utility translation function that allows us to construct a
  UTP variable (lens) type given a return and alphabet type. \<close>

syntax
  "_uvar_ty"      :: "type \<Rightarrow> type \<Rightarrow> type"

parse_translation \<open>
let
  fun uvar_ty_tr [ty] = Syntax.const @{type_syntax lens} $ ty $ Syntax.const @{type_syntax dummy}
    | uvar_ty_tr ts = raise TERM ("uvar_ty_tr", ts);
in [(@{syntax_const "_uvar_ty"}, K uvar_ty_tr)] end
\<close>

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Strong_Early_Bisim
  imports Strong_Early_Sim
begin

lemma monoAux: "A \<subseteq> B \<Longrightarrow> P \<leadsto>[A] Q \<longrightarrow> P \<leadsto>[B] Q"
by(auto intro: Strong_Early_Sim.monotonic)

coinductive_set bisim :: "(pi \<times> pi) set"
where
  step: "\<lbrakk>P \<leadsto>[bisim] Q; (Q, P) \<in> bisim\<rbrakk> \<Longrightarrow> (P, Q) \<in> bisim"
monos monoAux

abbreviation strongBisimJudge (infixr "\<sim>" 65) where "P \<sim> Q \<equiv> (P, Q) \<in> bisim"

lemma bisimCoinductAux[case_names bisim, case_conclusion StrongBisim step, consumes 1]:
  assumes p: "(P, Q) \<in> X"
  and step:  "\<And>P Q. (P, Q) \<in> X \<Longrightarrow> P \<leadsto>[(X \<union> bisim)] Q \<and> (Q, P) \<in> bisim \<union> X"

  shows "P \<sim> Q"
proof -
  have aux: "X \<union> bisim = {(P, Q). (P, Q) \<in> X \<or> P \<sim> Q}" by blast

  from p show ?thesis
    by(coinduct, force dest: step simp add: aux)
qed

lemma bisimCoinduct[consumes 1, case_names cSim cSym]:
  fixes P :: pi
  and   Q :: pi

  assumes "(P, Q) \<in> X"
  and     "\<And>R S. (R, S) \<in> X \<Longrightarrow> R \<leadsto>[(X \<union> bisim)] S"
  and     "\<And>R S. (R, S) \<in> X \<Longrightarrow> (S, R) \<in> X"

  shows "P \<sim> Q"
using assms
by(coinduct rule: bisimCoinductAux) auto

lemma weak_coinduct[case_names bisim, case_conclusion StrongBisim step, consumes 1]:
  assumes p: "(P, Q) \<in> X"
  and step:  "\<And>P Q. (P, Q) \<in> X \<Longrightarrow> P \<leadsto>[X] Q \<and> (Q, P) \<in> X"

  shows "P \<sim> Q"
using p
proof(coinduct rule: bisimCoinductAux)
  case (bisim P)
  from step[OF this] show ?case using Strong_Early_Sim.monotonic by blast
qed

lemma bisimWeakCoinduct[consumes 1, case_names cSim cSym]:
  fixes P :: pi
  and   Q :: pi

  assumes "(P, Q) \<in> X"
  and     "\<And>P Q. (P, Q) \<in> X \<Longrightarrow> P \<leadsto>[X] Q"
  and     "\<And>P Q. (P, Q) \<in> X \<Longrightarrow> (Q, P) \<in> X"

  shows "P \<sim> Q"
using assms
by(coinduct rule: weak_coinduct) auto

lemma bisimE:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<sim> Q"

  shows "P \<leadsto>[bisim] Q"
  and   "Q \<sim> P"
using assms
by(auto intro: bisim.cases)

lemma bisimClosed[eqvt]:
  fixes P :: pi
  and   Q :: pi
  and   p :: "name prm"

  assumes "P \<sim> Q"

  shows "(p \<bullet> P) \<sim> (p \<bullet> Q)"
proof -
  let ?X = "{(p \<bullet> P, p \<bullet> Q) | (p::name prm) P Q. P \<sim> Q}"
  from assms have "(p \<bullet> P, p \<bullet> Q) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: bisimWeakCoinduct)
    case(cSim P Q)
    moreover {
      fix P Q
      fix p::"name prm"
      assume "P \<leadsto>[bisim] Q"

      moreover have "bisim \<subseteq> ?X"
        by(auto, rule_tac x="[]" in exI) auto
      moreover have "eqvt ?X"
        by(auto simp add: eqvt_def pt2[OF pt_name_inst, THEN sym]) blast
      ultimately have "(p \<bullet> P) \<leadsto>[?X] (p \<bullet> Q)"
        by(rule Strong_Early_Sim.eqvtI)
    }
    ultimately show ?case by(blast dest: bisimE)
  next
    case(cSym P Q)
    thus ?case by(blast dest: bisimE)
  qed
qed

lemma eqvt[simp]:
  shows "eqvt bisim"
by(auto simp add: eqvt_def eqvts)

lemma reflexive:
  fixes P :: pi

  shows "P \<sim> P"
proof -
  have "(P, P) \<in> Id" by simp
  then show ?thesis
    by(coinduct rule: bisimWeakCoinduct) (auto intro: Strong_Early_Sim.reflexive)
qed

  assumes PBiSimQ: "P \<sim> Q"
  and     QBiSimR: "Q \<sim> R"

  shows "P \<sim> R"
proof -
  let ?X = "bisim O bisim"
  from assms have "(P, R) \<in> ?X" by blast
  thus ?thesis
  proof(coinduct rule: bisimWeakCoinduct)
    case(cSim P Q)
    moreover {
      fix P Q R
      assume "P \<sim> Q" and "Q \<sim> R"
      hence "P \<leadsto>[bisim] Q" and "Q \<leadsto>[bisim] R"
        by(metis bisimE)+
      moreover from eqvt have "eqvt ?X" by(auto simp add: eqvtTrans)
      moreover have "bisim O bisim \<subseteq> ?X" by auto

      ultimately have "P \<leadsto>[?X] R"
        by(rule Strong_Early_Sim.transitive)
    }
    ultimately show ?case by auto
  next
    case(cSym P Q)
    thus ?case by(auto dest: bisimE)
  qed
qed

end


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

(* Author: Jeremy Dawson, NICTA *)

section \<open>Operation variant for setting and unsetting bits\<close>

theory Generic_set_bit
  imports
    "HOL-Library.Word"
    Bits_Int
    Most_significant_bit
begin

class set_bit = semiring_bits +
  fixes set_bit :: \<open>'a \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> 'a\<close>
  assumes bit_set_bit_iff [bit_simps]:
    \<open>bit (set_bit a m b) n \<longleftrightarrow>
      (if m = n then b else bit a n) \<and> 2 ^ n \<noteq> 0\<close>

lemma set_bit_eq:
  \<open>set_bit a n b = (if b then Bit_Operations.set_bit else unset_bit) n a\<close>
  for a :: \<open>'a::{ring_bit_operations, set_bit}\<close>
  by (rule bit_eqI) (simp add: bit_simps)

instantiation int :: set_bit
begin

definition set_bit_int :: \<open>int \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> int\<close>
  where \<open>set_bit i n b = bin_sc n b i\<close>

instance
  by standard
    (simp_all add: set_bit_int_def bin_nth_sc_gen bit_simps)

end

lemma int_set_bit_0 [simp]: fixes x :: int shows
  "set_bit x 0 b = of_bool b + 2 * (x div 2)"
  by (auto simp add: set_bit_int_def intro: bin_rl_eqI)

lemma int_set_bit_Suc: fixes x :: int shows
  "set_bit x (Suc n) b = of_bool (odd x) + 2 * set_bit (x div 2) n b"
  by (auto simp add: set_bit_int_def intro: bin_rl_eqI)

lemma bin_last_set_bit:
  "odd (set_bit x n b :: int) = (if n > 0 then odd x else b)"
  by (cases n) (simp_all add: int_set_bit_Suc)

lemma bin_rest_set_bit:
  "(set_bit x n b :: int) div 2 = (if n > 0 then set_bit (x div 2) (n - 1) b else x div 2)"
  by (cases n) (simp_all add: int_set_bit_Suc)

lemma int_set_bit_numeral: fixes x :: int shows
  "set_bit x (numeral w) b = of_bool (odd x) + 2 * set_bit (x div 2) (pred_numeral w) b"
  by (simp add: set_bit_int_def)

lemmas int_set_bit_numerals [simp] =
  int_set_bit_numeral[where x="numeral w'"]
  int_set_bit_numeral[where x="- numeral w'"]
  int_set_bit_numeral[where x="Numeral1"]
  int_set_bit_numeral[where x="1"]
  int_set_bit_numeral[where x="0"]
  int_set_bit_Suc[where x="numeral w'"]
  int_set_bit_Suc[where x="- numeral w'"]
  int_set_bit_Suc[where x="Numeral1"]
  int_set_bit_Suc[where x="1"]
  int_set_bit_Suc[where x="0"]
  for w'

lemma msb_set_bit [simp]: "msb (set_bit (x :: int) n b) \<longleftrightarrow> msb x"
by(simp add: msb_conv_bin_sign set_bit_int_def)

instantiation word :: (len) set_bit
begin

definition set_bit_word :: \<open>'a word \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> 'a word\<close>
  where word_set_bit_def: \<open>set_bit a n x = word_of_int (bin_sc n x (uint a))\<close>

instance
  by standard
    (auto simp add: word_set_bit_def bin_nth_sc_gen bit_simps)

end

lemma set_bit_unfold:
  \<open>set_bit w n b = (if b then Bit_Operations.set_bit n w else unset_bit n w)\<close>
  for w :: \<open>'a::len word\<close>
  by (simp add: set_bit_eq)

lemma bit_set_bit_word_iff [bit_simps]:
  \<open>bit (set_bit w m b) n \<longleftrightarrow> (if m = n then n < LENGTH('a) \<and> b else bit w n)\<close>
  for w :: \<open>'a::len word\<close>
  by (auto simp add: bit_simps dest: bit_imp_le_length)

lemma word_set_nth: "set_bit w n (bit w n) = w"
  for w :: "'a::len word"
  by (auto simp: word_test_bit_def word_set_bit_def)

lemma test_bit_set: "bit (set_bit w n x) n \<longleftrightarrow> n < size w \<and> x"
  for w :: "'a::len word"
  by (auto simp add: bit_simps word_size)

lemma test_bit_set_gen:
  "bit (set_bit w n x) m = (if m = n then n < size w \<and> x else bit w m)"
  for w :: "'a::len word"
  apply (unfold word_size word_test_bit_def word_set_bit_def)
  apply (clarsimp simp add: nth_bintr bin_nth_sc_gen)
  apply (auto elim!: test_bit_size [unfolded word_size]
      simp add: word_test_bit_def [symmetric])
  done

lemma word_set_set_same [simp]: "set_bit (set_bit w n x) n y = set_bit w n y"
  for w :: "'a::len word"
  by (rule word_eqI) (simp add : test_bit_set_gen word_size)

lemma word_set_set_diff:
  fixes w :: "'a::len word"
  assumes "m \<noteq> n"
  shows "set_bit (set_bit w m x) n y = set_bit (set_bit w n y) m x"
  by (rule word_eqI) (auto simp: test_bit_set_gen word_size assms)

lemma set_bit_word_of_int: "set_bit (word_of_int x) n b = word_of_int (bin_sc n b x)"
  unfolding word_set_bit_def
  by (rule word_eqI) (simp add: word_size bin_nth_sc_gen nth_bintr bit_simps)

lemma word_set_numeral [simp]:
  "set_bit (numeral bin::'a::len word) n b =
    word_of_int (bin_sc n b (numeral bin))"
  unfolding word_numeral_alt by (rule set_bit_word_of_int)

lemma word_set_neg_numeral [simp]:
  "set_bit (- numeral bin::'a::len word) n b =
    word_of_int (bin_sc n b (- numeral bin))"
  unfolding word_neg_numeral_alt by (rule set_bit_word_of_int)

lemma word_set_bit_0 [simp]: "set_bit 0 n b = word_of_int (bin_sc n b 0)"
  unfolding word_0_wi by (rule set_bit_word_of_int)

lemma word_set_bit_1 [simp]: "set_bit 1 n b = word_of_int (bin_sc n b 1)"
  unfolding word_1_wi by (rule set_bit_word_of_int)

lemma word_set_nth_iff: "set_bit w n b = w \<longleftrightarrow> bit w n = b \<or> n \<ge> size w"
  for w :: "'a::len word"
  apply (rule iffI)
   apply (rule disjCI)
   apply (drule word_eqD)
   apply (erule sym [THEN trans])
   apply (simp add: test_bit_set)
  apply (erule disjE)
   apply clarsimp
  apply (rule word_eqI)
   apply (clarsimp simp add : test_bit_set_gen)
   apply (auto simp add: word_size)
  apply (rule bit_eqI)
  apply (simp add: bit_simps)
  done

lemma word_clr_le: "w \<ge> set_bit w n False"
  for w :: "'a::len word"
  apply (simp add: word_set_bit_def word_le_def)
  apply transfer
  apply (rule order_trans)
   apply (rule bintr_bin_clr_le)
  apply simp
  done

lemma word_set_ge: "w \<le> set_bit w n True"
  for w :: "'a::len word"
  apply (simp add: word_set_bit_def word_le_def)
  apply transfer
  apply (rule order_trans [OF _ bintr_bin_set_ge])
  apply simp
  done

lemma set_bit_beyond:
  "size x \<le> n \<Longrightarrow> set_bit x n b = x" for x :: "'a :: len word"
  by (simp add: word_set_nth_iff)

lemma one_bit_shiftl: "set_bit 0 n True = push_bit n (1 :: 'a :: len word)"
  apply (rule word_eqI)
  apply (auto simp add: word_size bit_simps
              simp del: word_set_bit_0)
  done

lemmas one_bit_pow = trans [OF one_bit_shiftl push_bit_of_1]

end


section \<open>Uniqueness of Laplace Transform\<close>
theory Uniqueness
  imports
    "Existence"
    "Lerch_Lemma"
begin

text \<open>We show uniqueness of the Laplace transform for continuous functions.\<close>

lemma laplace_transform_zero:\<comment> \<open>should also work for piecewise continuous\<close>
  assumes cont_f: "continuous_on {0..} f"
  assumes eo: "exponential_order M a f"
  assumes laplace: "\<And>s. Re s > a \<Longrightarrow> (f has_laplace 0) s"
  assumes "t \<ge> 0"
  shows "f t = 0"
proof -
  define I where "I \<equiv> \<lambda>s k. integral {0..k} (laplace_integrand f s)"
  have bounded_image: "bounded (f ` {0..b})" for b
    by (auto intro!: compact_imp_bounded compact_continuous_image cont_f intro: continuous_on_subset)
  obtain B where B: "\<forall>x\<in>{0..b}. cmod (f x) \<le> B b" for b
    apply atomize_elim
    apply (rule choice)
    using bounded_image[unfolded bounded_iff]
    by auto
  have fi: "f integrable_on {0..b}" for b
    by (auto intro!: integrable_continuous_interval intro: continuous_on_subset cont_f)
  have aint: "complex_set_integrable lebesgue {0..b} (laplace_integrand f s)" for b s
    by (rule laplace_integrand_absolutely_integrable_on_Icc[OF
          AE_BallI[OF bounded_le_Sup[OF bounded_image]] fi])
  have int: "((\<lambda>t. exp (t *\<^sub>R - s) * f t) has_integral I s b) {0 .. b}" for s b
    using aint[of b s]
    unfolding laplace_integrand_def[symmetric] I_def absolutely_integrable_on_def
    by blast
  have I_integral: "Re s > a \<Longrightarrow> (I s \<longlongrightarrow> integral {0..} (laplace_integrand f s)) at_top" for s
    unfolding I_def
    by (metis aint eo improper_integral_at_top laplace_integrand_absolutely_integrable_on_Ici_iff)
  have imp: "(I s \<longlongrightarrow> 0) at_top" if s: "Re s > a" for s
    using I_integral[of s] laplace[unfolded has_laplace_def, rule_format, OF s] s
    unfolding has_laplace_def I_def laplace_integrand_def
    by (simp add: integral_unique)

  define s0 where "s0 = a + 1"
  then have "s0 > a" by auto
  have "\<forall>\<^sub>F x in at_right (0::real). 0 < x \<and> x < 1"
    by (auto intro!: eventually_at_rightI)
  moreover
  from exponential_orderD(2)[OF eo]
  have "\<forall>\<^sub>F t in at_right 0. cmod (f (- ln t)) \<le> M * exp (a * (- ln t))"
    unfolding at_top_mirror filtermap_ln_at_right[symmetric] eventually_filtermap .
  ultimately have "\<forall>\<^sub>F x in at_right 0. cmod ((x powr s0) * f (- ln x)) \<le> M * x powr (s0 - a)"
    (is "\<forall>\<^sub>F x in _. ?l x \<le> ?r x")
  proof eventually_elim
    case x: (elim x)
    then have "cmod ((x powr s0) * f (- ln x)) \<le> x powr s0 * (M * exp (a * (- ln x)))"
      by (intro norm_mult_ineq[THEN order_trans]) (auto intro!: x(2)[THEN order_trans])
    also have "\<dots> = M * x powr (s0 - a)"
      by (simp add: exp_minus ln_inverse divide_simps powr_def mult_exp_exp algebra_simps)
    finally show ?case .
  qed
  then have "((\<lambda>x. x powr s0 * f (- ln x)) \<longlongrightarrow> 0) (at_right 0)"
    by (rule Lim_null_comparison)
      (auto intro!: tendsto_eq_intros \<open>a < s0\<close> eventually_at_rightI zero_less_one)
  moreover have "\<forall>\<^sub>F x in at x. ln x \<le> 0" if "0 < x" "x < 1" for x::real
    using order_tendstoD(1)[OF tendsto_ident_at \<open>0 < x\<close>, of UNIV]
      order_tendstoD(2)[OF tendsto_ident_at \<open>x < 1\<close>, of UNIV]
    by eventually_elim simp
  ultimately have [continuous_intros]:
    "continuous_on {0..1} (\<lambda>x. x powr s0 * f (- ln x))"
    by (intro continuous_on_IccI;
        force intro!: continuous_on_tendsto_compose[OF cont_f] tendsto_eq_intros eventually_at_leftI
        zero_less_one)
  {
    fix n::nat
    let ?i = "(\<lambda>u. u ^ n *\<^sub>R (u powr s0 * f (- ln u)))"
    let ?I = "\<lambda>n b. integral {exp (- b).. 1} ?i"
    have "\<forall>\<^sub>F (b::real) in at_top. b > 0"
      by (simp add: eventually_gt_at_top)
    then have "\<forall>\<^sub>F b in at_top. I (s0 + Suc n) b = ?I n b"
    proof eventually_elim
      case (elim b)
      have eq: "exp (t *\<^sub>R - complex_of_real (s0 + real (Suc n))) * f t =
        complex_of_real (exp (- (real n * t)) * exp (- t) * exp (- (s0 * t))) * f t"
        for t
        by (auto simp: Euler mult_exp_exp algebra_simps simp del: of_real_mult)
      from int[of "s0 + Suc n" b]
      have int': "((\<lambda>t. exp (- (n * t)) * exp (-t) * exp (- (s0 * t)) * f t)
          has_integral I (s0 + Suc n) b) {0..b}"
        (is "(?fe has_integral _) _")
        unfolding eq .
      have "((\<lambda>x. - exp (- x) *\<^sub>R exp (- x) ^ n *\<^sub>R (exp (- x) powr s0 * f (- ln (exp (- x)))))
          has_integral
            integral {exp (- 0)..exp (- b)} ?i - integral {exp (- b)..exp (- 0)} ?i) {0..b}"
        by (rule has_integral_substitution_general[of "{}" 0 b "\<lambda>t. exp(-t)" 0 1 ?i "\<lambda>x. -exp(-x)"])
           (auto intro!: less_imp_le[OF \<open>b > 0\<close>] continuous_intros integrable_continuous_real
             derivative_eq_intros)
      then have "(?fe has_integral ?I n b) {0..b}"
        using \<open>b > 0\<close>
        by (auto simp: algebra_simps mult_exp_exp exp_of_nat_mult[symmetric] scaleR_conv_of_real
            exp_add powr_def of_real_exp has_integral_neg_iff)
      with int' show ?case
        by (rule has_integral_unique)
    qed
    moreover have "(I (s0 + Suc n) \<longlongrightarrow> 0) at_top"
      by (rule imp) (use \<open>s0 > a\<close> in auto)
    ultimately have "(?I n \<longlongrightarrow> 0) at_top"
      by (rule Lim_transform_eventually[rotated])
    then have 1: "((\<lambda>x. integral {exp (ln x)..1} ?i) \<longlongrightarrow> 0) (at_right 0)"
      unfolding at_top_mirror filtermap_ln_at_right[symmetric] filtermap_filtermap filterlim_filtermap
      by simp
    have "\<forall>\<^sub>F x in at_right 0. x > 0"
      by (simp add: eventually_at_filter)
    then have "\<forall>\<^sub>F x in at_right 0. integral {exp (ln x)..1} ?i = integral {x .. 1} ?i"
      by eventually_elim (auto simp:)
    from Lim_transform_eventually[OF 1 this]
    have "((\<lambda>x. integral {x..1} ?i) \<longlongrightarrow> 0) (at_right 0)"
      by simp
    moreover
    have "?i integrable_on {0..1}"
      by (force intro: continuous_intros integrable_continuous_real)
    from continuous_on_Icc_at_rightD[OF indefinite_integral_continuous_1'[OF this] zero_less_one]
    have "((\<lambda>x. integral {x..1} ?i) \<longlongrightarrow> integral {0 .. 1} ?i) (at_right 0)"
      by simp
    ultimately have "integral {0 .. 1} ?i = 0"
      by (rule tendsto_unique[symmetric, rotated]) simp
    then have "(?i has_integral 0) {0 .. 1}"
      using integrable_integral \<open>?i integrable_on {0..1}\<close>
      by (metis (full_types))
  } from lerch_lemma[OF _ this, of "exp (- t)"]
  show "f t = 0" using \<open>t \<ge> 0\<close>
    by (auto intro!: continuous_intros)
qed

lemma exponential_order_eventually_eq: "exponential_order M a f"
  if "exponential_order M a g" "\<And>t. t \<ge> k \<Longrightarrow> f t = g t"
proof -
  have "\<forall>\<^sub>F t in at_top. f t = g t"
    using that
    unfolding eventually_at_top_linorder
    by blast
  with exponential_orderD(2)[OF that(1)]
  have "(\<forall>\<^sub>F t in at_top. norm (f t) \<le> M * exp (a * t))"
    by eventually_elim auto
  with exponential_orderD(1)[OF that(1)]
  show ?thesis
    by (rule exponential_orderI)
qed

lemma exponential_order_uminus_iff:
  "exponential_order M a (\<lambda>x. - f x) = exponential_order M a f"
  by (auto simp: exponential_order_def)

lemma exponential_order_add:
  assumes "exponential_order M a f" "exponential_order M a g"
  shows "exponential_order (2 * M) a (\<lambda>x. f x + g x)"
  using assms
  apply (auto simp: exponential_order_def)
  subgoal premises prems
    using prems(1,3)
    apply (eventually_elim)
    apply (rule norm_triangle_le)
    by linarith
  done

theorem laplace_transform_unique:
  assumes f: "\<And>s. Re s > a \<Longrightarrow> (f has_laplace F) s"
  assumes g: "\<And>s. Re s > b \<Longrightarrow> (g has_laplace F) s"
  assumes [continuous_intros]: "continuous_on {0..} f"
  assumes [continuous_intros]: "continuous_on {0..} g"
  assumes eof: "exponential_order M a f"
  assumes eog: "exponential_order N b g"
  assumes "t \<ge> 0"
  shows "f t = g t"
proof -
  define c where "c = max a b"
  define L where "L = max M N"
  from eof have eof: "exponential_order L c f"
    by (rule exponential_order_mono) (auto simp: L_def c_def)
  from eog have eog: "exponential_order L c (\<lambda>x. - g x)"
    unfolding exponential_order_uminus_iff
    by (rule exponential_order_mono) (auto simp: L_def c_def)
  from exponential_order_add[OF eof eog]
  have eom: "exponential_order (2 * L) c (\<lambda>x. f x - g x)"
    by simp
  have l0: "((\<lambda>x. f x - g x) has_laplace 0) s" if "Re s > c" for s
    using has_laplace_minus[OF f g, of s] that by (simp add: c_def max_def split: if_splits)
  have "f t - g t = 0"
    by (rule laplace_transform_zero[OF _ eom l0 \<open>t \<ge> 0\<close>])
      (auto intro!: continuous_intros)
  then show ?thesis by simp
qed

end