(* Author: Tobias Nipkow *)

subsection "Hoare Logic for Total Correctness"

theory Hoare_Total
imports Hoare_Examples
begin

subsubsection "Hoare Logic for Total Correctness --- Separate Termination Relation"

text{* Note that this definition of total validity @{text"\<Turnstile>\<^sub>t"} only
works if execution is deterministic (which it is in our case). *}

definition hoare_tvalid :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool"
  ("\<Turnstile>\<^sub>t {(1_)}/ (_)/ {(1_)}" 50) where
"\<Turnstile>\<^sub>t {P}c{Q}  \<longleftrightarrow>  (\<forall>s. P s \<longrightarrow> (\<exists>t. (c,s) \<Rightarrow> t \<and> Q t))"

text{* Provability of Hoare triples in the proof system for total
correctness is written @{text"\<turnstile>\<^sub>t {P}c{Q}"} and defined
inductively. The rules for @{text"\<turnstile>\<^sub>t"} differ from those for
@{text"\<turnstile>"} only in the one place where nontermination can arise: the
@{term While}-rule. *}

inductive
  hoaret :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<turnstile>\<^sub>t ({(1_)}/ (_)/ {(1_)})" 50)
where

Skip:  "\<turnstile>\<^sub>t {P} SKIP {P}"  |

Assign:  "\<turnstile>\<^sub>t {\<lambda>s. P(s(x:=aval a s))} x::=a {P}"  |

Seq: "\<lbrakk> \<turnstile>\<^sub>t {P\<^sub>1} c\<^sub>1 {P\<^sub>2}; \<turnstile>\<^sub>t {P\<^sub>2} c\<^sub>2 {P\<^sub>3} \<rbrakk> \<Longrightarrow> \<turnstile>\<^sub>t {P\<^sub>1} c\<^sub>1;;c\<^sub>2 {P\<^sub>3}"  |

If: "\<lbrakk> \<turnstile>\<^sub>t {\<lambda>s. P s \<and> bval b s} c\<^sub>1 {Q}; \<turnstile>\<^sub>t {\<lambda>s. P s \<and> \<not> bval b s} c\<^sub>2 {Q} \<rbrakk>
  \<Longrightarrow> \<turnstile>\<^sub>t {P} IF b THEN c\<^sub>1 ELSE c\<^sub>2 {Q}"  |

While:
  "(\<And>n::nat.
    \<turnstile>\<^sub>t {\<lambda>s. P s \<and> bval b s \<and> T s n} c {\<lambda>s. P s \<and> (\<exists>n'<n. T s n')})
   \<Longrightarrow> \<turnstile>\<^sub>t {\<lambda>s. P s \<and> (\<exists>n. T s n)} WHILE b DO c {\<lambda>s. P s \<and> \<not>bval b s}"  |

conseq: "\<lbrakk> \<forall>s. P' s \<longrightarrow> P s; \<turnstile>\<^sub>t {P}c{Q}; \<forall>s. Q s \<longrightarrow> Q' s  \<rbrakk> \<Longrightarrow>
           \<turnstile>\<^sub>t {P'}c{Q'}"

text{* The @{term While}-rule is like the one for partial correctness but it
requires additionally that with every execution of the loop body some measure
relation @{term[source]"T :: state \<Rightarrow> nat \<Rightarrow> bool"} decreases.
The following functional version is more intuitive: *}

lemma While_fun:
  "\<lbrakk> \<And>n::nat. \<turnstile>\<^sub>t {\<lambda>s. P s \<and> bval b s \<and> n = f s} c {\<lambda>s. P s \<and> f s < n}\<rbrakk>
   \<Longrightarrow> \<turnstile>\<^sub>t {P} WHILE b DO c {\<lambda>s. P s \<and> \<not>bval b s}"
  by (rule While [where T="\<lambda>s n. n = f s", simplified])

text{* Building in the consequence rule: *}

lemma Assign': "\<forall>s. P s \<longrightarrow> Q(s(x:=aval a s)) \<Longrightarrow> \<turnstile>\<^sub>t {P} x ::= a {Q}"
by (simp add: strengthen_pre[OF _ Assign])

lemma While_fun':
assumes "\<And>n::nat. \<turnstile>\<^sub>t {\<lambda>s. P s \<and> bval b s \<and> n = f s} c {\<lambda>s. P s \<and> f s < n}"
    and "\<forall>s. P s \<and> \<not> bval b s \<longrightarrow> Q s"
shows "\<turnstile>\<^sub>t {P} WHILE b DO c {Q}"
by(blast intro: assms(1) weaken_post[OF While_fun assms(2)])

text{* Our standard example: *}

lemma "\<turnstile>\<^sub>t {\<lambda>s. s ''x'' = i} ''y'' ::= N 0;; wsum {\<lambda>s. s ''y'' = sum i}"
apply(rule Seq)
 prefer 2
 apply(rule While_fun' [where P = "\<lambda>s. (s ''y'' = sum i - sum(s ''x''))"
    and f = "\<lambda>s. nat(s ''x'')"])
   apply(rule Seq)
   prefer 2
   apply(rule Assign)
  apply(rule Assign')
  apply simp
 apply(simp)
apply(rule Assign')
apply simp
done

text{* The soundness theorem: *}

theorem hoaret_sound: "\<turnstile>\<^sub>t {P}c{Q}  \<Longrightarrow>  \<Turnstile>\<^sub>t {P}c{Q}"
proof(unfold hoare_tvalid_def, induction rule: hoaret.induct)
  case (While P b T c)
  {
    fix s n
    have "\<lbrakk> P s; T s n \<rbrakk> \<Longrightarrow> \<exists>t. (WHILE b DO c, s) \<Rightarrow> t \<and> P t \<and> \<not> bval b t"
    proof(induction "n" arbitrary: s rule: less_induct)
      case (less n)
      thus ?case by (metis While.IH WhileFalse WhileTrue)
    qed
  }
  thus ?case by auto
next
  case If thus ?case by auto blast
qed fastforce+

text{*
The completeness proof proceeds along the same lines as the one for partial
correctness. First we have to strengthen our notion of weakest precondition
to take termination into account: *}

definition wpt :: "com \<Rightarrow> assn \<Rightarrow> assn" ("wp\<^sub>t") where
"wp\<^sub>t c Q  =  (\<lambda>s. \<exists>t. (c,s) \<Rightarrow> t \<and> Q t)"

lemma [simp]: "wp\<^sub>t (x ::= e) Q = (\<lambda>s. Q(s(x := aval e s)))"
by(auto intro!: ext simp: wpt_def)

lemma [simp]: "wp\<^sub>t (c\<^sub>1;;c\<^sub>2) Q = wp\<^sub>t c\<^sub>1 (wp\<^sub>t c\<^sub>2 Q)"
unfolding wpt_def
apply(rule ext)
apply auto
done

lemma [simp]:
 "wp\<^sub>t (IF b THEN c\<^sub>1 ELSE c\<^sub>2) Q = (\<lambda>s. wp\<^sub>t (if bval b s then c\<^sub>1 else c\<^sub>2) Q s)"
apply(unfold wpt_def)
apply(rule ext)
apply auto
done

text{* Now we define the number of iterations @{term "WHILE b DO c"} needs to
terminate when started in state @{text s}. Because this is a truly partial
function, we define it as an (inductive) relation first: *}

inductive Its :: "bexp \<Rightarrow> com \<Rightarrow> state \<Rightarrow> nat \<Rightarrow> bool" where
Its_0: "\<not> bval b s \<Longrightarrow> Its b c s 0" |
Its_Suc: "\<lbrakk> bval b s;  (c,s) \<Rightarrow> s';  Its b c s' n \<rbrakk> \<Longrightarrow> Its b c s (Suc n)"

text{* The relation is in fact a function: *}

lemma Its_fun: "Its b c s n \<Longrightarrow> Its b c s n' \<Longrightarrow> n=n'"
proof(induction arbitrary: n' rule:Its.induct)
  case Its_0 thus ?case by(metis Its.cases)
next
  case Its_Suc thus ?case by(metis Its.cases big_step_determ)
qed

text{* For all terminating loops, @{const Its} yields a result: *}

lemma WHILE_Its: "(WHILE b DO c,s) \<Rightarrow> t \<Longrightarrow> \<exists>n. Its b c s n"
proof(induction "WHILE b DO c" s t rule: big_step_induct)
  case WhileFalse thus ?case by (metis Its_0)
next
  case WhileTrue thus ?case by (metis Its_Suc)
qed

lemma wpt_is_pre: "\<turnstile>\<^sub>t {wp\<^sub>t c Q} c {Q}"
proof (induction c arbitrary: Q)
  case SKIP show ?case by (auto intro:hoaret.Skip)
next
  case Assign show ?case by (auto intro:hoaret.Assign)
next
  case Seq thus ?case by (auto intro:hoaret.Seq)
next
  case If thus ?case by (auto intro:hoaret.If hoaret.conseq)
next
  case (While b c)
  let ?w = "WHILE b DO c"
  let ?T = "Its b c"
  have "\<forall>s. wp\<^sub>t ?w Q s \<longrightarrow> wp\<^sub>t ?w Q s \<and> (\<exists>n. Its b c s n)"
    unfolding wpt_def by (metis WHILE_Its)
  moreover
  { fix n
    let ?R = "\<lambda>s'. wp\<^sub>t ?w Q s' \<and> (\<exists>n'<n. ?T s' n')"
    { fix s t assume "bval b s" and "?T s n" and "(?w, s) \<Rightarrow> t" and "Q t"
      from `bval b s` and `(?w, s) \<Rightarrow> t` obtain s' where
        "(c,s) \<Rightarrow> s'" "(?w,s') \<Rightarrow> t" by auto
      from `(?w, s') \<Rightarrow> t` obtain n' where "?T s' n'"
        by (blast dest: WHILE_Its)
      with `bval b s` and `(c, s) \<Rightarrow> s'` have "?T s (Suc n')" by (rule Its_Suc)
      with `?T s n` have "n = Suc n'" by (rule Its_fun)
      with `(c,s) \<Rightarrow> s'` and `(?w,s') \<Rightarrow> t` and `Q t` and `?T s' n'`
      have "wp\<^sub>t c ?R s" by (auto simp: wpt_def)
    }
    hence "\<forall>s. wp\<^sub>t ?w Q s \<and> bval b s \<and> ?T s n \<longrightarrow> wp\<^sub>t c ?R s"
      unfolding wpt_def by auto
      (* by (metis WhileE Its_Suc Its_fun WHILE_Its lessI) *)
    note strengthen_pre[OF this While.IH]
  } note hoaret.While[OF this]
  moreover have "\<forall>s. wp\<^sub>t ?w Q s \<and> \<not> bval b s \<longrightarrow> Q s"
    by (auto simp add:wpt_def)
  ultimately show ?case by (rule conseq)
qed

text{*\noindent In the @{term While}-case, @{const Its} provides the obvious
termination argument.

The actual completeness theorem follows directly, in the same manner
as for partial correctness: *}

theorem hoaret_complete: "\<Turnstile>\<^sub>t {P}c{Q} \<Longrightarrow> \<turnstile>\<^sub>t {P}c{Q}"
apply(rule strengthen_pre[OF _ wpt_is_pre])
apply(auto simp: hoare_tvalid_def wpt_def)
done

corollary hoaret_sound_complete: "\<turnstile>\<^sub>t {P}c{Q} \<longleftrightarrow> \<Turnstile>\<^sub>t {P}c{Q}"
by (metis hoaret_sound hoaret_complete)

end


(*  Title:      HOL/Probability/Discrete_Topology.thy
    Author:     Fabian Immler, TU München
*)

theory Discrete_Topology
imports "HOL-Analysis.Analysis"
begin

text \<open>Copy of discrete types with discrete topology. This space is polish.\<close>

typedef 'a discrete = "UNIV::'a set"
morphisms of_discrete discrete
..

instantiation discrete :: (type) metric_space
begin

definition dist_discrete :: "'a discrete \<Rightarrow> 'a discrete \<Rightarrow> real"
  where "dist_discrete n m = (if n = m then 0 else 1)"

definition uniformity_discrete :: "('a discrete \<times> 'a discrete) filter" where
  "(uniformity::('a discrete \<times> 'a discrete) filter) = (INF e\<in>{0 <..}. principal {(x, y). dist x y < e})"

definition "open_discrete" :: "'a discrete set \<Rightarrow> bool" where
  "(open::'a discrete set \<Rightarrow> bool) U \<longleftrightarrow> (\<forall>x\<in>U. eventually (\<lambda>(x', y). x' = x \<longrightarrow> y \<in> U) uniformity)"

instance proof qed (auto simp: uniformity_discrete_def open_discrete_def dist_discrete_def intro: exI[where x=1])
end

lemma open_discrete: "open (S :: 'a discrete set)"
  unfolding open_dist dist_discrete_def by (auto intro!: exI[of _ "1 / 2"])

instance discrete :: (type) complete_space
proof
  fix X::"nat\<Rightarrow>'a discrete" assume "Cauchy X"
  hence "\<exists>n. \<forall>m\<ge>n. X n = X m"
    by (force simp: dist_discrete_def Cauchy_def split: if_split_asm dest:spec[where x=1])
  then guess n ..
  thus "convergent X"
    by (intro convergentI[where L="X n"] tendstoI eventually_sequentiallyI[of n])
       (simp add: dist_discrete_def)
qed

instance discrete :: (countable) countable
proof
  have "inj (\<lambda>c::'a discrete. to_nat (of_discrete c))"
    by (simp add: inj_on_def of_discrete_inject)
  thus "\<exists>f::'a discrete \<Rightarrow> nat. inj f" by blast
qed

instance discrete :: (countable) second_countable_topology
proof
  let ?B = "range (\<lambda>n::'a discrete. {n})"
  have "\<And>S. generate_topology ?B (\<Union>x\<in>S. {x})"
    by (intro generate_topology_Union) (auto intro: generate_topology.intros)
  then have "open = generate_topology ?B"
    by (auto intro!: ext simp: open_discrete)
  moreover have "countable ?B" by simp
  ultimately show "\<exists>B::'a discrete set set. countable B \<and> open = generate_topology B" by blast
qed

instance discrete :: (countable) polish_space ..

end


section \<open>Winning Strategies\<close>

theory WinningStrategy
imports
  Main
  Strategy
begin

context ParityGame begin

text \<open>
  Here we define winning strategies.

  A strategy is winning for player @{term p} from @{term v0} if every maximal @{term \<sigma>}-path
  starting in @{term v0} is winning.
\<close>
definition winning_strategy :: "Player \<Rightarrow> 'a Strategy \<Rightarrow> 'a \<Rightarrow> bool" where
  "winning_strategy p \<sigma> v0 \<equiv> \<forall>P. vmc_path G P v0 p \<sigma> \<longrightarrow> winning_path p P"

lemma winning_strategyI [intro]:
  assumes "\<And>P. vmc_path G P v0 p \<sigma> \<Longrightarrow> winning_path p P"
  shows "winning_strategy p \<sigma> v0"
  unfolding winning_strategy_def using assms by blast

lemma (in vmc_path) paths_hits_winning_strategy_is_winning:
  assumes \<sigma>: "winning_strategy p \<sigma> v"
    and v: "v \<in> lset P"
  shows "winning_path p P"
proof-
  obtain n where n: "enat n < llength P" "P $ n = v" using v by (meson in_lset_conv_lnth)
  interpret P': vmc_path G "ldropn n P" v p \<sigma> using n vmc_path_ldropn by blast
  have "winning_path p (ldropn n P)" using \<sigma> by (simp add: winning_strategy_def P'.vmc_path_axioms)
  thus ?thesis using winning_path_drop_add P_valid n(1) by blast
qed

text \<open>There cannot exist winning strategies for both players for the same node.\<close>

lemma winning_strategy_only_for_one_player:
  assumes \<sigma>: "strategy p \<sigma>" "winning_strategy p \<sigma> v"
    and \<sigma>': "strategy p** \<sigma>'" "winning_strategy p** \<sigma>' v"
    and v: "v \<in> V"
  shows "False"
proof-
  obtain P where "vmc2_path G P v p \<sigma> \<sigma>'" using assms strategy_conforming_path_exists by blast
  then interpret vmc2_path G P v p \<sigma> \<sigma>' .
  have "winning_path p P"
    using paths_hits_winning_strategy_is_winning \<sigma>(2) v0_lset_P by blast
  moreover have "winning_path p** P"
    using comp.paths_hits_winning_strategy_is_winning \<sigma>'(2) v0_lset_P by blast
  ultimately show False using P_valid paths_are_winning_for_one_player by blast
qed

subsection \<open>Deadends\<close>

lemma no_winning_strategy_on_deadends:
  assumes "v \<in> VV p" "deadend v" "strategy p \<sigma>"
  shows "\<not>winning_strategy p \<sigma> v"
proof-
  obtain P where "vmc_path G P v p \<sigma>" using strategy_conforming_path_exists_single assms by blast
  then interpret vmc_path G P v p \<sigma> .
  have "P = LCons v LNil" using P_deadend_v0_LCons \<open>deadend v\<close> by blast
  hence "\<not>winning_path p P" unfolding winning_path_def using \<open>v \<in> VV p\<close> by auto
  thus ?thesis using winning_strategy_def vmc_path_axioms by blast
qed

lemma winning_strategy_on_deadends:
  assumes "v \<in> VV p" "deadend v" "strategy p \<sigma>"
  shows "winning_strategy p** \<sigma> v"
proof
  fix P assume "vmc_path G P v p** \<sigma>"
  then interpret vmc_path G P v "p**" \<sigma> .
  have "P = LCons v LNil" using P_deadend_v0_LCons \<open>deadend v\<close> by blast
  thus "winning_path p** P" unfolding winning_path_def
    using \<open>v \<in> VV p\<close> P_valid paths_are_winning_for_one_player by auto
qed

subsection \<open>Extension Theorems\<close>

lemma strategy_extends_VVp:
  assumes v0: "v0 \<in> VV p" "\<not>deadend v0"
  and \<sigma>: "strategy p \<sigma>" "winning_strategy p \<sigma> v0"
  shows "winning_strategy p \<sigma> (\<sigma> v0)"
proof
  fix P assume "vmc_path G P (\<sigma> v0) p \<sigma>"
  then interpret vmc_path G P "\<sigma> v0" p \<sigma> .
  have "v0\<rightarrow>\<sigma> v0" using v0 \<sigma>(1) strategy_def by blast
  hence "winning_path p (LCons v0 P)"
    using \<sigma>(2) extension_valid_maximal_conforming winning_strategy_def by blast
  thus "winning_path p P" using winning_path_ltl[of p "LCons v0 P"] by simp
qed

lemma strategy_extends_VVpstar:
  assumes v0: "v0 \<in> VV p**" "v0\<rightarrow>w0"
  and \<sigma>: "winning_strategy p \<sigma> v0"
  shows "winning_strategy p \<sigma> w0"
proof
  fix P assume "vmc_path G P w0 p \<sigma>"
  then interpret vmc_path G P w0 p \<sigma> .
  have "winning_path p (LCons v0 P)"
    using extension_valid_maximal_conforming VV_impl1 \<sigma> v0 winning_strategy_def
    by auto
  thus "winning_path p P" using winning_path_ltl[of p "LCons v0 P"] by auto
qed

lemma strategy_extends_backwards_VVpstar:
  assumes v0: "v0 \<in> VV p**"
    and \<sigma>: "strategy p \<sigma>" "\<And>w. v0\<rightarrow>w \<Longrightarrow> winning_strategy p \<sigma> w"
  shows "winning_strategy p \<sigma> v0"
proof
  fix P assume "vmc_path G P v0 p \<sigma>"
  then interpret vmc_path G P v0 p \<sigma> .
  show "winning_path p P" proof (cases)
    assume "deadend v0"
    thus ?thesis using P_deadend_v0_LCons winning_path_def v0 by auto
  next
    assume "\<not>deadend v0"
    then interpret vmc_path_no_deadend G P v0 p \<sigma> by unfold_locales
    interpret ltlP: vmc_path G "ltl P" w0 p \<sigma> using vmc_path_ltl .
    have "winning_path p (ltl P)"
      using \<sigma>(2) v0_edge_w0 vmc_path_ltl winning_strategy_def by blast
    thus "winning_path p P"
      using winning_path_LCons by (metis P_LCons' ltlP.P_LCons ltlP.P_not_null)
  qed
qed

lemma strategy_extends_backwards_VVp:
  assumes v0: "v0 \<in> VV p" "\<sigma> v0 = w" "v0\<rightarrow>w"
    and \<sigma>: "strategy p \<sigma>" "winning_strategy p \<sigma> w"
  shows "winning_strategy p \<sigma> v0"
proof
  fix P assume "vmc_path G P v0 p \<sigma>"
  then interpret vmc_path G P v0 p \<sigma> .
  have "\<not>deadend v0" using \<open>v0\<rightarrow>w\<close> by blast
  then interpret vmc_path_no_deadend G P v0 p \<sigma> by unfold_locales
  have "winning_path p (ltl P)"
    using \<sigma>(2)[unfolded winning_strategy_def] v0(1,2) v0_conforms vmc_path_ltl by presburger
  thus "winning_path p P" using winning_path_LCons by (metis P_LCons Ptl_not_null)
qed

end \<comment> \<open>context ParityGame\<close>

end


section \<open>Straight Line Programs\<close>
theory Straight_Line_Program
imports Affine_Approximation
begin

subsection \<open>Definition\<close>

datatype 'a slp =
  ConsSLP "('a, 'a) euclarith" "'a slp"  (infixr ";slp" 65)
| ReturnSLP "nat list"

primrec interpret_slp::"'a::real_inner slp \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "interpret_slp (ReturnSLP is) = (\<lambda>xs. map (nth xs) is)"
| "interpret_slp (ConsSLP ea eas) =
    (\<lambda>xs. interpret_slp eas (xs @ [interpret_euclarith ea xs]))"

primrec approx_slp::"nat \<Rightarrow> real \<Rightarrow> 'a::executable_euclidean_space slp \<Rightarrow> 'a aform list \<Rightarrow>
    'a aform list option"
where
  "approx_slp p t (ReturnSLP is) xs = (if \<forall>i\<in>set is. i < length xs then Some (map (nth xs) is) else None)"
| "approx_slp p t (ConsSLP ea eas) xs =
    do {
      r \<leftarrow> approx_euclarith_outer p t ea xs;
      approx_slp p t eas (xs @ [r])
    }"

lemma Nil_mem_Joints[intro, simp]: "[] \<in> Joints []"
  by (force simp: Joints_def valuate_def)

lemma map_nth_Joints: "xs \<in> Joints XS \<Longrightarrow> (\<And>i. i \<in> set is \<Longrightarrow> i < length XS) \<Longrightarrow> map (nth xs) is @ xs \<in> Joints (map (nth XS) is @ XS)"
  by (auto simp: Joints_def valuate_def)

lemma map_nth_Joints': "xs \<in> Joints XS \<Longrightarrow> (\<And>i. i \<in> set is \<Longrightarrow> i < length XS) \<Longrightarrow> map (nth xs) is \<in> Joints (map (nth XS) is)"
  by (rule Joints_appendD2[OF map_nth_Joints]) (auto )

lemma approx_slp:
  assumes "approx_slp p t eas XS = Some YS"
  assumes "xs \<in> Joints XS"
  shows "interpret_slp eas xs \<in> Joints (YS)"
  using assms
  by (induction eas arbitrary: xs XS YS)
     (auto simp: bind_eq_Some_conv map_nth_Joints' Joints2_JointsI Joints_imp_length_eq
        dest!: approx_euclarith_outer split: if_split_asm)

subsection \<open>free variable bound\<close>

primrec max_Var_slp::"'a slp \<Rightarrow> nat \<Rightarrow> bool" where
  "max_Var_slp (ReturnSLP rs) n \<longleftrightarrow> (\<forall>r \<in> set rs. r < n)"
| "max_Var_slp (x ;slp slp) n \<longleftrightarrow> max_Var_euclarith x < n \<and> (max_Var_slp slp (Suc n))"

lemma nth_takeI:
  assumes "take (Suc x) ys = take (Suc x) zs"
  assumes "x < length ys"
  assumes "x < length zs"
  shows "ys ! x = zs ! x"
proof -
  from assms
  have "take (Suc x) ys ! x = take (Suc x) zs ! x"
    by simp
  then show ?thesis
    by simp
qed

subsection \<open>Example\<close>

lemma
  fixes y x::real
  shows "interpret_slp
    ( add_ea 1 0   ;slp
      hadamard_ea 0 2 ;slp
      add_ea 3 2   ;slp
      ReturnSLP [3, 4]) [y, x] =
    [y * (x + y), y * (x + y) + (x + y)]"
  by simp

end


theory Refine_Mono_Prover
imports Main Automatic_Refinement.Refine_Lib
begin
  ML_file \<open>refine_mono_prover.ML\<close>

  setup Refine_Mono_Prover.setup
  declaration Refine_Mono_Prover.decl_setup

  method_setup refine_mono =
    \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (
      Refine_Mono_Prover.untriggered_mono_tac ctxt
    ))\<close>
    "Refinement framework: Monotonicity prover"

  locale mono_setup_loc =
    \<comment> \<open>Locale to set up monotonicity prover for given ordering operator\<close>
    fixes le :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
    assumes refl: "le x x"
  begin
    lemma monoI: "(\<And>f g x. (\<And>x. le (f x) (g x)) \<Longrightarrow> le (B f x) (B g x))
      \<Longrightarrow> monotone (fun_ord le) (fun_ord le) B"
      unfolding monotone_def fun_ord_def by blast

    lemma mono_if: "\<lbrakk>le t t'; le e e'\<rbrakk> \<Longrightarrow> le (If b t e) (If b t' e')" by auto
    lemma mono_let: "(\<And>x. le (f x) (f' x)) \<Longrightarrow> le (Let x f) (Let x f')" by auto

    lemmas mono_thms[refine_mono] = monoI mono_if mono_let refl

    declaration \<open>Refine_Mono_Prover.declare_mono_triggers @{thms monoI}\<close>

  end

  interpretation order_mono_setup: mono_setup_loc "(\<le>) :: 'a::preorder \<Rightarrow> _"
    by standard auto

  declaration \<open>Refine_Mono_Prover.declare_mono_triggers @{thms monoI}\<close>

  lemmas [refine_mono] =
    lfp_mono[OF le_funI, THEN le_funD]
    gfp_mono[OF le_funI, THEN le_funD]

end


theory Lmap_literates
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer
codatatype (lset: 'a) Llist =
    lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"

primcorec literates :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a Llist"
where "literates f x = LCons x (literates f (f x))"

primcorec lmap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Llist \<Rightarrow> 'b Llist" where
 "lmap f xs = (case xs of LNil \<Rightarrow> LNil | LCons x xs \<Rightarrow> LCons (f x) (lmap f xs))"

(* Need obs to explore with literates *)
codatatype 'a Lst =
  Emp
  | Cons "'a" "'a Lst"

fun obsLList :: "int \<Rightarrow> 'a Llist \<Rightarrow> 'a Lst" where
"obsLList n s = (if (n \<le> 0) then Emp else Cons (lhd s) (obsLList (n - 1) (ltl s)))"
lemma stuff: "lhd (lmap z (literates y x2)) = z x2"
    by (simp add: Llist.case_eq_if)
(*hipster_obs Llist Lst obsLList literates lmap*)
lemma lemma_a [thy_expl]: "lmap y (literates y z) = literates y (y z)"
apply (coinduction  arbitrary: y z rule: Lmap_literates.Llist.coinduct_strong)
  apply simp
  by (metis (no_types, lifting) Llist.case_eq_if literates.disc_iff literates.simps(2) literates.simps(3))

lemma lemma_aa [thy_expl]: "lmap z (LCons y (literates z x2)) = LCons (z y) (literates z (z x2))"
apply (coinduction  arbitrary: x2 y z rule: Lmap_literates.Llist.coinduct_strong)
  by (simp_all add: lemma_a)
(* Why isn't obs function in background? Bug somewhere! *)
lemma lemma_ab [thy_expl]: "obsLList 1 (lmap z (literates y x2)) = Lst.Cons (z x2) Emp"
apply (coinduction  arbitrary: x2 y z rule: Lmap_literates.Lst.coinduct_strong)
  by (simp_all add: Llist.case_eq_if)

lemma lemma_ac [thy_expl]: "ltl (lmap y (literates z x2)) = lmap y (literates z (z x2))"
apply (coinduction  arbitrary: x2 y z rule: Lmap_literates.Llist.coinduct_strong)
by (simp_all add: Llist.case_eq_if)
(*Proving: lhd (lmap z (literates y x2)) = z x2
No matching coinduction rule found*)
theorem lmap_literates: "lmap f (literates f x) = literates f (f x)"
  by(simp add: lemma_a)
  (*by hipster_coinduct_sledgehammer
Metis: Failed to replay Metis proof
resynchronize: Out of sync
Failed to apply initial proof method *)
  apply(coinduction arbitrary: x rule: Llist.coinduct_strong)
  by (smt Llist.case_eq_if literates.disc_iff literates.simps(2) literates.simps(3) lmap.disc_iff(2) lmap.sel(1) lmap.sel(2))
(*by hipster_coinduct_sledgehammer
fails *)
end


(*  Title:      ZF/upair.thy
    Author:     Lawrence C Paulson and Martin D Coen, CU Computer Laboratory
    Copyright   1993  University of Cambridge

Observe the order of dependence:
    Upair is defined in terms of Replace
    \<union> is defined in terms of Upair and \<Union>(similarly for Int)
    cons is defined in terms of Upair and Un
    Ordered pairs and descriptions are defined using cons ("set notation")
*)

section\<open>Unordered Pairs\<close>

theory upair
imports ZF_Base
keywords "print_tcset" :: diag
begin

ML_file \<open>Tools/typechk.ML\<close>

lemma atomize_ball [symmetric, rulify]:
     "(!!x. x \<in> A ==> P(x)) == Trueprop (\<forall>x\<in>A. P(x))"
by (simp add: Ball_def atomize_all atomize_imp)

subsection\<open>Unordered Pairs: constant \<^term>\<open>Upair\<close>\<close>

lemma Upair_iff [simp]: "c \<in> Upair(a,b) \<longleftrightarrow> (c=a | c=b)"
by (unfold Upair_def, blast)

lemma UpairI1: "a \<in> Upair(a,b)"
by simp

lemma UpairI2: "b \<in> Upair(a,b)"
by simp

lemma UpairE: "[| a \<in> Upair(b,c);  a=b ==> P;  a=c ==> P |] ==> P"
by (simp, blast)

subsection\<open>Rules for Binary Union, Defined via \<^term>\<open>Upair\<close>\<close>

lemma Un_iff [simp]: "c \<in> A \<union> B \<longleftrightarrow> (c \<in> A | c \<in> B)"
apply (simp add: Un_def)
apply (blast intro: UpairI1 UpairI2 elim: UpairE)
done

lemma UnI1: "c \<in> A ==> c \<in> A \<union> B"
by simp

lemma UnI2: "c \<in> B ==> c \<in> A \<union> B"
by simp

declare UnI1 [elim?]  UnI2 [elim?]

lemma UnE [elim!]: "[| c \<in> A \<union> B;  c \<in> A ==> P;  c \<in> B ==> P |] ==> P"
by (simp, blast)

(*Stronger version of the rule above*)
lemma UnE': "[| c \<in> A \<union> B;  c \<in> A ==> P;  [| c \<in> B;  c\<notin>A |] ==> P |] ==> P"
by (simp, blast)

(*Classical introduction rule: no commitment to A vs B*)
lemma UnCI [intro!]: "(c \<notin> B ==> c \<in> A) ==> c \<in> A \<union> B"
by (simp, blast)

subsection\<open>Rules for Binary Intersection, Defined via \<^term>\<open>Upair\<close>\<close>

lemma Int_iff [simp]: "c \<in> A \<inter> B \<longleftrightarrow> (c \<in> A & c \<in> B)"
apply (unfold Int_def)
apply (blast intro: UpairI1 UpairI2 elim: UpairE)
done

lemma IntI [intro!]: "[| c \<in> A;  c \<in> B |] ==> c \<in> A \<inter> B"
by simp

lemma IntD1: "c \<in> A \<inter> B ==> c \<in> A"
by simp

lemma IntD2: "c \<in> A \<inter> B ==> c \<in> B"
by simp

lemma IntE [elim!]: "[| c \<in> A \<inter> B;  [| c \<in> A; c \<in> B |] ==> P |] ==> P"
by simp

subsection\<open>Rules for Set Difference, Defined via \<^term>\<open>Upair\<close>\<close>

lemma Diff_iff [simp]: "c \<in> A-B \<longleftrightarrow> (c \<in> A & c\<notin>B)"
by (unfold Diff_def, blast)

lemma DiffI [intro!]: "[| c \<in> A;  c \<notin> B |] ==> c \<in> A - B"
by simp

lemma DiffD1: "c \<in> A - B ==> c \<in> A"
by simp

lemma DiffD2: "c \<in> A - B ==> c \<notin> B"
by simp

lemma DiffE [elim!]: "[| c \<in> A - B;  [| c \<in> A; c\<notin>B |] ==> P |] ==> P"
by simp

subsection\<open>Rules for \<^term>\<open>cons\<close>\<close>

lemma cons_iff [simp]: "a \<in> cons(b,A) \<longleftrightarrow> (a=b | a \<in> A)"
apply (unfold cons_def)
apply (blast intro: UpairI1 UpairI2 elim: UpairE)
done

(*risky as a typechecking rule, but solves otherwise unconstrained goals of
the form x \<in> ?A*)
lemma consI1 [simp,TC]: "a \<in> cons(a,B)"
by simp

lemma consI2: "a \<in> B ==> a \<in> cons(b,B)"
by simp

lemma consE [elim!]: "[| a \<in> cons(b,A);  a=b ==> P;  a \<in> A ==> P |] ==> P"
by (simp, blast)

(*Stronger version of the rule above*)
lemma consE':
    "[| a \<in> cons(b,A);  a=b ==> P;  [| a \<in> A;  a\<noteq>b |] ==> P |] ==> P"
by (simp, blast)

(*Classical introduction rule*)
lemma consCI [intro!]: "(a\<notin>B ==> a=b) ==> a \<in> cons(b,B)"
by (simp, blast)

lemma cons_not_0 [simp]: "cons(a,B) \<noteq> 0"
by (blast elim: equalityE)

lemmas cons_neq_0 = cons_not_0 [THEN notE]

declare cons_not_0 [THEN not_sym, simp]

subsection\<open>Singletons\<close>

lemma singleton_iff: "a \<in> {b} \<longleftrightarrow> a=b"
by simp

lemma singletonI [intro!]: "a \<in> {a}"
by (rule consI1)

lemmas singletonE = singleton_iff [THEN iffD1, elim_format, elim!]

subsection\<open>Descriptions\<close>

lemma the_equality [intro]:
    "[| P(a);  !!x. P(x) ==> x=a |] ==> (THE x. P(x)) = a"
apply (unfold the_def)
apply (fast dest: subst)
done

(* Only use this if you already know \<exists>!x. P(x) *)
lemma the_equality2: "[| \<exists>!x. P(x);  P(a) |] ==> (THE x. P(x)) = a"
by blast

lemma theI: "\<exists>!x. P(x) ==> P(THE x. P(x))"
apply (erule ex1E)
apply (subst the_equality)
apply (blast+)
done

(*No congruence rule is necessary: if @{term"\<forall>y.P(y)\<longleftrightarrow>Q(y)"} then
  @{term "THE x.P(x)"}  rewrites to @{term "THE x.Q(x)"} *)

(*If it's "undefined", it's zero!*)
lemma the_0: "~ (\<exists>!x. P(x)) ==> (THE x. P(x))=0"
apply (unfold the_def)
apply (blast elim!: ReplaceE)
done

(*Easier to apply than theI: conclusion has only one occurrence of P*)
lemma theI2:
    assumes p1: "~ Q(0) ==> \<exists>!x. P(x)"
        and p2: "!!x. P(x) ==> Q(x)"
    shows "Q(THE x. P(x))"
apply (rule classical)
apply (rule p2)
apply (rule theI)
apply (rule classical)
apply (rule p1)
apply (erule the_0 [THEN subst], assumption)
done

lemma the_eq_trivial [simp]: "(THE x. x = a) = a"
by blast

lemma the_eq_trivial2 [simp]: "(THE x. a = x) = a"
by blast

subsection\<open>Conditional Terms: \<open>if-then-else\<close>\<close>

lemma if_true [simp]: "(if True then a else b) = a"
by (unfold if_def, blast)

lemma if_false [simp]: "(if False then a else b) = b"
by (unfold if_def, blast)

(*Never use with case splitting, or if P is known to be true or false*)
lemma if_cong:
    "[| P\<longleftrightarrow>Q;  Q ==> a=c;  ~Q ==> b=d |]
     ==> (if P then a else b) = (if Q then c else d)"
by (simp add: if_def cong add: conj_cong)

(*Prevents simplification of x and y \<in> faster and allows the execution
  of functional programs. NOW THE DEFAULT.*)
lemma if_weak_cong: "P\<longleftrightarrow>Q ==> (if P then x else y) = (if Q then x else y)"
by simp

(*Not needed for rewriting, since P would rewrite to True anyway*)
lemma if_P: "P ==> (if P then a else b) = a"
by (unfold if_def, blast)

(*Not needed for rewriting, since P would rewrite to False anyway*)
lemma if_not_P: "~P ==> (if P then a else b) = b"
by (unfold if_def, blast)

lemma split_if [split]:
     "P(if Q then x else y) \<longleftrightarrow> ((Q \<longrightarrow> P(x)) & (~Q \<longrightarrow> P(y)))"
by (case_tac Q, simp_all)

(** Rewrite rules for boolean case-splitting: faster than split_if [split]
**)

lemmas split_if_eq1 = split_if [of "%x. x = b"] for b
lemmas split_if_eq2 = split_if [of "%x. a = x"] for a

lemmas split_if_mem1 = split_if [of "%x. x \<in> b"] for b
lemmas split_if_mem2 = split_if [of "%x. a \<in> x"] for a

lemmas split_ifs = split_if_eq1 split_if_eq2 split_if_mem1 split_if_mem2

(*Logically equivalent to split_if_mem2*)
lemma if_iff: "a: (if P then x else y) \<longleftrightarrow> P & a \<in> x | ~P & a \<in> y"
by simp

lemma if_type [TC]:
    "[| P ==> a \<in> A;  ~P ==> b \<in> A |] ==> (if P then a else b): A"
by simp

(** Splitting IFs in the assumptions **)

lemma split_if_asm: "P(if Q then x else y) \<longleftrightarrow> (~((Q & ~P(x)) | (~Q & ~P(y))))"
by simp

lemmas if_splits = split_if split_if_asm

subsection\<open>Consequences of Foundation\<close>

(*was called mem_anti_sym*)
lemma mem_asym: "[| a \<in> b;  ~P ==> b \<in> a |] ==> P"
apply (rule classical)
apply (rule_tac A1 = "{a,b}" in foundation [THEN disjE])
apply (blast elim!: equalityE)+
done

(*was called mem_anti_refl*)
lemma mem_irrefl: "a \<in> a ==> P"
by (blast intro: mem_asym)

(*mem_irrefl should NOT be added to default databases:
      it would be tried on most goals, making proofs slower!*)

lemma mem_not_refl: "a \<notin> a"
apply (rule notI)
apply (erule mem_irrefl)
done

(*Good for proving inequalities by rewriting*)
lemma mem_imp_not_eq: "a \<in> A ==> a \<noteq> A"
by (blast elim!: mem_irrefl)

lemma eq_imp_not_mem: "a=A ==> a \<notin> A"
by (blast intro: elim: mem_irrefl)

subsection\<open>Rules for Successor\<close>

lemma succ_iff: "i \<in> succ(j) \<longleftrightarrow> i=j | i \<in> j"
by (unfold succ_def, blast)

lemma succI1 [simp]: "i \<in> succ(i)"
by (simp add: succ_iff)

lemma succI2: "i \<in> j ==> i \<in> succ(j)"
by (simp add: succ_iff)

lemma succE [elim!]:
    "[| i \<in> succ(j);  i=j ==> P;  i \<in> j ==> P |] ==> P"
apply (simp add: succ_iff, blast)
done

(*Classical introduction rule*)
lemma succCI [intro!]: "(i\<notin>j ==> i=j) ==> i \<in> succ(j)"
by (simp add: succ_iff, blast)

lemma succ_not_0 [simp]: "succ(n) \<noteq> 0"
by (blast elim!: equalityE)

lemmas succ_neq_0 = succ_not_0 [THEN notE, elim!]

declare succ_not_0 [THEN not_sym, simp]
declare sym [THEN succ_neq_0, elim!]

(* @{term"succ(c) \<subseteq> B ==> c \<in> B"} *)
lemmas succ_subsetD = succI1 [THEN [2] subsetD]

(* @{term"succ(b) \<noteq> b"} *)
lemmas succ_neq_self = succI1 [THEN mem_imp_not_eq, THEN not_sym]

lemma succ_inject_iff [simp]: "succ(m) = succ(n) \<longleftrightarrow> m=n"
by (blast elim: mem_asym elim!: equalityE)

lemmas succ_inject = succ_inject_iff [THEN iffD1, dest!]

subsection\<open>Miniscoping of the Bounded Universal Quantifier\<close>

lemma ball_simps1:
     "(\<forall>x\<in>A. P(x) & Q)   \<longleftrightarrow> (\<forall>x\<in>A. P(x)) & (A=0 | Q)"
     "(\<forall>x\<in>A. P(x) | Q)   \<longleftrightarrow> ((\<forall>x\<in>A. P(x)) | Q)"
     "(\<forall>x\<in>A. P(x) \<longrightarrow> Q) \<longleftrightarrow> ((\<exists>x\<in>A. P(x)) \<longrightarrow> Q)"
     "(~(\<forall>x\<in>A. P(x))) \<longleftrightarrow> (\<exists>x\<in>A. ~P(x))"
     "(\<forall>x\<in>0.P(x)) \<longleftrightarrow> True"
     "(\<forall>x\<in>succ(i).P(x)) \<longleftrightarrow> P(i) & (\<forall>x\<in>i. P(x))"
     "(\<forall>x\<in>cons(a,B).P(x)) \<longleftrightarrow> P(a) & (\<forall>x\<in>B. P(x))"
     "(\<forall>x\<in>RepFun(A,f). P(x)) \<longleftrightarrow> (\<forall>y\<in>A. P(f(y)))"
     "(\<forall>x\<in>\<Union>(A).P(x)) \<longleftrightarrow> (\<forall>y\<in>A. \<forall>x\<in>y. P(x))"
by blast+

lemma ball_simps2:
     "(\<forall>x\<in>A. P & Q(x))   \<longleftrightarrow> (A=0 | P) & (\<forall>x\<in>A. Q(x))"
     "(\<forall>x\<in>A. P | Q(x))   \<longleftrightarrow> (P | (\<forall>x\<in>A. Q(x)))"
     "(\<forall>x\<in>A. P \<longrightarrow> Q(x)) \<longleftrightarrow> (P \<longrightarrow> (\<forall>x\<in>A. Q(x)))"
by blast+

lemma ball_simps3:
     "(\<forall>x\<in>Collect(A,Q).P(x)) \<longleftrightarrow> (\<forall>x\<in>A. Q(x) \<longrightarrow> P(x))"
by blast+

lemmas ball_simps [simp] = ball_simps1 ball_simps2 ball_simps3

lemma ball_conj_distrib:
    "(\<forall>x\<in>A. P(x) & Q(x)) \<longleftrightarrow> ((\<forall>x\<in>A. P(x)) & (\<forall>x\<in>A. Q(x)))"
by blast

subsection\<open>Miniscoping of the Bounded Existential Quantifier\<close>

lemma bex_simps1:
     "(\<exists>x\<in>A. P(x) & Q) \<longleftrightarrow> ((\<exists>x\<in>A. P(x)) & Q)"
     "(\<exists>x\<in>A. P(x) | Q) \<longleftrightarrow> (\<exists>x\<in>A. P(x)) | (A\<noteq>0 & Q)"
     "(\<exists>x\<in>A. P(x) \<longrightarrow> Q) \<longleftrightarrow> ((\<forall>x\<in>A. P(x)) \<longrightarrow> (A\<noteq>0 & Q))"
     "(\<exists>x\<in>0.P(x)) \<longleftrightarrow> False"
     "(\<exists>x\<in>succ(i).P(x)) \<longleftrightarrow> P(i) | (\<exists>x\<in>i. P(x))"
     "(\<exists>x\<in>cons(a,B).P(x)) \<longleftrightarrow> P(a) | (\<exists>x\<in>B. P(x))"
     "(\<exists>x\<in>RepFun(A,f). P(x)) \<longleftrightarrow> (\<exists>y\<in>A. P(f(y)))"
     "(\<exists>x\<in>\<Union>(A).P(x)) \<longleftrightarrow> (\<exists>y\<in>A. \<exists>x\<in>y.  P(x))"
     "(~(\<exists>x\<in>A. P(x))) \<longleftrightarrow> (\<forall>x\<in>A. ~P(x))"
by blast+

lemma bex_simps2:
     "(\<exists>x\<in>A. P & Q(x)) \<longleftrightarrow> (P & (\<exists>x\<in>A. Q(x)))"
     "(\<exists>x\<in>A. P | Q(x)) \<longleftrightarrow> (A\<noteq>0 & P) | (\<exists>x\<in>A. Q(x))"
     "(\<exists>x\<in>A. P \<longrightarrow> Q(x)) \<longleftrightarrow> ((A=0 | P) \<longrightarrow> (\<exists>x\<in>A. Q(x)))"
by blast+

lemma bex_simps3:
     "(\<exists>x\<in>Collect(A,Q).P(x)) \<longleftrightarrow> (\<exists>x\<in>A. Q(x) & P(x))"
by blast

lemmas bex_simps [simp] = bex_simps1 bex_simps2 bex_simps3

lemma bex_disj_distrib:
    "(\<exists>x\<in>A. P(x) | Q(x)) \<longleftrightarrow> ((\<exists>x\<in>A. P(x)) | (\<exists>x\<in>A. Q(x)))"
by blast

(** One-point rule for bounded quantifiers: see HOL/Set.ML **)

lemma bex_triv_one_point1 [simp]: "(\<exists>x\<in>A. x=a) \<longleftrightarrow> (a \<in> A)"
by blast

lemma bex_triv_one_point2 [simp]: "(\<exists>x\<in>A. a=x) \<longleftrightarrow> (a \<in> A)"
by blast

lemma bex_one_point1 [simp]: "(\<exists>x\<in>A. x=a & P(x)) \<longleftrightarrow> (a \<in> A & P(a))"
by blast

lemma bex_one_point2 [simp]: "(\<exists>x\<in>A. a=x & P(x)) \<longleftrightarrow> (a \<in> A & P(a))"
by blast

lemma ball_one_point1 [simp]: "(\<forall>x\<in>A. x=a \<longrightarrow> P(x)) \<longleftrightarrow> (a \<in> A \<longrightarrow> P(a))"
by blast

lemma ball_one_point2 [simp]: "(\<forall>x\<in>A. a=x \<longrightarrow> P(x)) \<longleftrightarrow> (a \<in> A \<longrightarrow> P(a))"
by blast

subsection\<open>Miniscoping of the Replacement Operator\<close>

text\<open>These cover both \<^term>\<open>Replace\<close> and \<^term>\<open>Collect\<close>\<close>
lemma Rep_simps [simp]:
     "{x. y \<in> 0, R(x,y)} = 0"
     "{x \<in> 0. P(x)} = 0"
     "{x \<in> A. Q} = (if Q then A else 0)"
     "RepFun(0,f) = 0"
     "RepFun(succ(i),f) = cons(f(i), RepFun(i,f))"
     "RepFun(cons(a,B),f) = cons(f(a), RepFun(B,f))"
by (simp_all, blast+)

subsection\<open>Miniscoping of Unions\<close>

lemma UN_simps1:
     "(\<Union>x\<in>C. cons(a, B(x))) = (if C=0 then 0 else cons(a, \<Union>x\<in>C. B(x)))"
     "(\<Union>x\<in>C. A(x) \<union> B')   = (if C=0 then 0 else (\<Union>x\<in>C. A(x)) \<union> B')"
     "(\<Union>x\<in>C. A' \<union> B(x))   = (if C=0 then 0 else A' \<union> (\<Union>x\<in>C. B(x)))"
     "(\<Union>x\<in>C. A(x) \<inter> B')  = ((\<Union>x\<in>C. A(x)) \<inter> B')"
     "(\<Union>x\<in>C. A' \<inter> B(x))  = (A' \<inter> (\<Union>x\<in>C. B(x)))"
     "(\<Union>x\<in>C. A(x) - B')    = ((\<Union>x\<in>C. A(x)) - B')"
     "(\<Union>x\<in>C. A' - B(x))    = (if C=0 then 0 else A' - (\<Inter>x\<in>C. B(x)))"
apply (simp_all add: Inter_def)
apply (blast intro!: equalityI )+
done

lemma UN_simps2:
      "(\<Union>x\<in>\<Union>(A). B(x)) = (\<Union>y\<in>A. \<Union>x\<in>y. B(x))"
      "(\<Union>z\<in>(\<Union>x\<in>A. B(x)). C(z)) = (\<Union>x\<in>A. \<Union>z\<in>B(x). C(z))"
      "(\<Union>x\<in>RepFun(A,f). B(x))     = (\<Union>a\<in>A. B(f(a)))"
by blast+

lemmas UN_simps [simp] = UN_simps1 UN_simps2

text\<open>Opposite of miniscoping: pull the operator out\<close>

lemma UN_extend_simps1:
     "(\<Union>x\<in>C. A(x)) \<union> B   = (if C=0 then B else (\<Union>x\<in>C. A(x) \<union> B))"
     "((\<Union>x\<in>C. A(x)) \<inter> B) = (\<Union>x\<in>C. A(x) \<inter> B)"
     "((\<Union>x\<in>C. A(x)) - B) = (\<Union>x\<in>C. A(x) - B)"
apply simp_all
apply blast+
done

lemma UN_extend_simps2:
     "cons(a, \<Union>x\<in>C. B(x)) = (if C=0 then {a} else (\<Union>x\<in>C. cons(a, B(x))))"
     "A \<union> (\<Union>x\<in>C. B(x))   = (if C=0 then A else (\<Union>x\<in>C. A \<union> B(x)))"
     "(A \<inter> (\<Union>x\<in>C. B(x))) = (\<Union>x\<in>C. A \<inter> B(x))"
     "A - (\<Inter>x\<in>C. B(x))    = (if C=0 then A else (\<Union>x\<in>C. A - B(x)))"
     "(\<Union>y\<in>A. \<Union>x\<in>y. B(x)) = (\<Union>x\<in>\<Union>(A). B(x))"
     "(\<Union>a\<in>A. B(f(a))) = (\<Union>x\<in>RepFun(A,f). B(x))"
apply (simp_all add: Inter_def)
apply (blast intro!: equalityI)+
done

lemma UN_UN_extend:
     "(\<Union>x\<in>A. \<Union>z\<in>B(x). C(z)) = (\<Union>z\<in>(\<Union>x\<in>A. B(x)). C(z))"
by blast

lemmas UN_extend_simps = UN_extend_simps1 UN_extend_simps2 UN_UN_extend

subsection\<open>Miniscoping of Intersections\<close>

lemma INT_simps1:
     "(\<Inter>x\<in>C. A(x) \<inter> B) = (\<Inter>x\<in>C. A(x)) \<inter> B"
     "(\<Inter>x\<in>C. A(x) - B)   = (\<Inter>x\<in>C. A(x)) - B"
     "(\<Inter>x\<in>C. A(x) \<union> B)  = (if C=0 then 0 else (\<Inter>x\<in>C. A(x)) \<union> B)"
by (simp_all add: Inter_def, blast+)

lemma INT_simps2:
     "(\<Inter>x\<in>C. A \<inter> B(x)) = A \<inter> (\<Inter>x\<in>C. B(x))"
     "(\<Inter>x\<in>C. A - B(x))   = (if C=0 then 0 else A - (\<Union>x\<in>C. B(x)))"
     "(\<Inter>x\<in>C. cons(a, B(x))) = (if C=0 then 0 else cons(a, \<Inter>x\<in>C. B(x)))"
     "(\<Inter>x\<in>C. A \<union> B(x))  = (if C=0 then 0 else A \<union> (\<Inter>x\<in>C. B(x)))"
apply (simp_all add: Inter_def)
apply (blast intro!: equalityI)+
done

lemmas INT_simps [simp] = INT_simps1 INT_simps2

text\<open>Opposite of miniscoping: pull the operator out\<close>

lemma INT_extend_simps1:
     "(\<Inter>x\<in>C. A(x)) \<inter> B = (\<Inter>x\<in>C. A(x) \<inter> B)"
     "(\<Inter>x\<in>C. A(x)) - B = (\<Inter>x\<in>C. A(x) - B)"
     "(\<Inter>x\<in>C. A(x)) \<union> B  = (if C=0 then B else (\<Inter>x\<in>C. A(x) \<union> B))"
apply (simp_all add: Inter_def, blast+)
done

lemma INT_extend_simps2:
     "A \<inter> (\<Inter>x\<in>C. B(x)) = (\<Inter>x\<in>C. A \<inter> B(x))"
     "A - (\<Union>x\<in>C. B(x))   = (if C=0 then A else (\<Inter>x\<in>C. A - B(x)))"
     "cons(a, \<Inter>x\<in>C. B(x)) = (if C=0 then {a} else (\<Inter>x\<in>C. cons(a, B(x))))"
     "A \<union> (\<Inter>x\<in>C. B(x))  = (if C=0 then A else (\<Inter>x\<in>C. A \<union> B(x)))"
apply (simp_all add: Inter_def)
apply (blast intro!: equalityI)+
done

lemmas INT_extend_simps = INT_extend_simps1 INT_extend_simps2

subsection\<open>Other simprules\<close>

(*** Miniscoping: pushing in big Unions, Intersections, quantifiers, etc. ***)

lemma misc_simps [simp]:
     "0 \<union> A = A"
     "A \<union> 0 = A"
     "0 \<inter> A = 0"
     "A \<inter> 0 = 0"
     "0 - A = 0"
     "A - 0 = A"
     "\<Union>(0) = 0"
     "\<Union>(cons(b,A)) = b \<union> \<Union>(A)"
     "\<Inter>({b}) = b"
by blast+

end


theory Chapter13_5
imports Main "HOL-Library.Lattice_Syntax"
begin

text{*
\setcounter{exercise}{10}

\begin{exercise}
Take the Isabelle theories that define commands, big-step semantics,
annotated commands and the collecting semantics and extend them with a
nondeterministic choice construct. Start with Exercise~\ref{exe:IMP:OR}
and extend type @{text com}, then extend type @{text acom} with a
corresponding construct:
\begin{alltt}
  Or "'a acom" "'a acom" 'a     ("_ OR// _//{_}"  [60, 61, 0] 60)
\end{alltt}
Finally extend function @{text Step}. Update proofs as well.
Hint: think of @{text OR} as a nondeterministic conditional without a test.
\end{exercise}

\exercise
Prove the following lemmas in a detailed and readable style:
*}

lemma fixes x0 :: "'a :: order"
assumes "\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y"  and  "f q \<le> q"  and  "x0 \<le> q"
shows "(f ^^ i) x0 \<le> q"
(* your definition/proof here *)

lemma fixes x0 :: "'a :: order"
assumes "\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y" and "x0 \<le> f x0"
shows "(f ^^ i) x0 \<le> (f ^^ (i+1)) x0"
(* your definition/proof here *)

text{*
\endexercise

\exercise% needs Lattice_Syntax
Let @{typ 'a} be a complete lattice and
let @{text "f :: 'a \<Rightarrow> 'a"} be a monotone function.
Give a readable proof that if @{text P} is a set of pre-fixpoints of @{text f}
then @{text"\<Sqinter>P"} is also a pre-fixpoint of @{text f}:
*}

lemma fixes P :: "'a::complete_lattice set"
assumes "mono f" and "\<forall>p \<in> P. f p \<le> p"
shows "f(\<Sqinter> P) \<le> \<Sqinter> P"
(* your definition/proof here *)

text{*
Sledgehammer should give you a proof you can start from.
\endexercise
*}

end


theory Vector
imports Main
begin

fun insert_at :: "nat \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "insert_at 0 a' [] = a' # []"
| "insert_at 0 a' (a # as) = a' # a # as"
| "insert_at (Suc x) a' [] = undefined"
| "insert_at (Suc x) a' (a # as) = a # insert_at x a' as"

fun lookup :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option" where
  "lookup [] x = None"
| "lookup (a # as) 0 = Some a"
| "lookup (a # as) (Suc x) = lookup as x"

fun remove :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list" where
  "remove [] x = undefined"
| "remove (a # as) 0 = as"
| "remove (a # as) (Suc x) = a # remove as x"

lemma insert_length [simp]: "x \<le> length as \<Longrightarrow> length (insert_at x a as) = Suc (length as)"
  by (induction x a as rule: insert_at.induct) simp_all

lemma [simp]: "x \<le> length as \<Longrightarrow> y \<le> x \<Longrightarrow>
    insert_at y b (insert_at x a as) = insert_at (Suc x) a (insert_at y b as)"
  proof (induction x a as arbitrary: y rule: insert_at.induct)
  case 4
    thus ?case by (induction y) simp_all
  qed simp_all

lemma [simp]: "x < length as \<Longrightarrow> y \<le> x \<Longrightarrow>
    insert_at y a (remove as x) = remove (insert_at y a as) (Suc x)"
  proof (induction as x arbitrary: y rule: remove.induct)
  case (2 a as)
    thus ?case
      proof (induction y)
      case 0
        thus ?case by (induction as) simp_all
      qed simp_all
  next case 3
    thus ?case by (induction y) simp_all
  qed simp_all

lemma [simp]: "x \<le> length as \<Longrightarrow> lookup (insert_at x a as) x = Some a"
  by (induction x a as rule: insert_at.induct) simp_all

lemma [simp]: "lookup as x = Some a \<Longrightarrow> lookup (insert_at (length as) a' as) x = Some a"
  by (induction as x rule: lookup.induct) simp_all

lemma [elim]: "lookup (insert_at (length as) a' as) x = Some a \<Longrightarrow> x < length as \<Longrightarrow>
    lookup as x = Some a"
  by (induction as x rule: lookup.induct) fastforce+

lemma [simp]: "x \<le> length as \<Longrightarrow> y < x \<Longrightarrow> lookup (insert_at x a as) y = lookup as y"
  proof (induction x a as arbitrary: y rule: insert_at.induct)
  case 4
    thus ?case by (induction y) simp_all
  qed simp_all

lemma [simp]: "x \<le> length as \<Longrightarrow> x \<le> y \<Longrightarrow> lookup (insert_at x a as) (Suc y) = lookup as y"
  proof (induction x a as arbitrary: y rule: insert_at.induct)
  case 4
    thus ?case by (induction y) simp_all
  qed simp_all

lemma [simp]: "x \<le> length as \<Longrightarrow> map f (insert_at x a as) = insert_at x (f a) (map f as)"
  by (induction x a as rule: insert_at.induct) simp_all

lemma [simp]: "x < length as \<Longrightarrow> map f (remove as x) = remove (map f as) x"
  by (induction as x rule: remove.induct) simp_all

lemma [simp]: "lookup (map f as) x = map_option f (lookup as x)"
  by (induction as x rule: lookup.induct) simp_all

lemma lookup_less_than [elim]: "lookup as x = Some a \<Longrightarrow> x < length as"
  by (induction as x rule: lookup.induct) simp_all

lemma [simp]: "x < length as \<Longrightarrow> \<exists>a. lookup as x = Some a"
  by (induction as x rule: lookup.induct) simp_all

lemma [elim]: "list_all p as \<Longrightarrow> lookup as x = Some a \<Longrightarrow> p a"
  by (induction as x rule: lookup.induct) simp_all

lemma [simp]: "x < length as \<Longrightarrow> lookup (as @ bs) x = lookup as x"
  by (induction as x rule: lookup.induct) simp_all

lemma [simp]: "lookup (as @ bs) (length as + x) = lookup bs x"
  by (induction as "length as + x" rule: lookup.induct) simp_all

lemma [simp]: "x \<le> length as \<Longrightarrow> insert_at x a (as @ bs) = insert_at x a as @ bs"
  by (induction x a as rule: insert_at.induct) (cases bs, simp_all)

lemma [simp]: "lookup as x = Some a \<Longrightarrow> \<exists>as'. as = insert_at x a as' \<and> x \<le> length as'"
  proof (induction as x rule: lookup.induct)
  case (2 a' as)
    have "a # as = insert_at 0 a as" by (cases as) simp_all
    with 2 show ?case by fastforce
  next case (3 a' as x)
    then obtain as' where "as = insert_at x a as' \<and> x \<le> length as'" by fastforce
    moreover have "a' # insert_at x a as' = insert_at (Suc x) a (a' # as')" by simp
    ultimately show ?case by fastforce
  qed simp_all

end


chapter \<open>Predicates for Terms, Formulas and Substitution\<close>

theory Coding_Predicates
imports Coding Sigma
begin

declare succ_iff [simp del]

text \<open>This material comes from Section 3, greatly modified for de Bruijn syntax.\<close>

section \<open>Predicates for atomic terms\<close>

subsection \<open>Free Variables\<close>

definition VarP :: "tm \<Rightarrow> fm" where "VarP x \<equiv> OrdP x AND Zero IN x"

lemma VarP_eqvt [eqvt]: "(p \<bullet> VarP x) = VarP (p \<bullet> x)"
  by (simp add: VarP_def)

lemma VarP_fresh_iff [simp]: "a \<sharp> VarP x \<longleftrightarrow> a \<sharp> x"
  by (simp add: VarP_def)

lemma VarP_sf [iff]: "Sigma_fm (VarP x)"
  by (auto simp: VarP_def)

lemma VarP_subst [simp]: "(VarP x)(i::=t) = VarP (subst i t x) "
  by (simp add: VarP_def)

lemma VarP_cong: "H \<turnstile> x EQ x' \<Longrightarrow> H \<turnstile> VarP x IFF VarP x'"
  by (rule P1_cong) auto

lemma VarP_HPairE [intro!]: "insert (VarP (HPair x y)) H \<turnstile> A"
  by (auto simp: VarP_def)

subsection \<open>De Bruijn Indexes\<close>

abbreviation Q_Ind :: "tm \<Rightarrow> tm"
  where "Q_Ind k \<equiv> HPair (HTuple 6) k"

nominal_function IndP :: "tm \<Rightarrow> fm"
  where "atom m \<sharp> x \<Longrightarrow>
    IndP x = Ex m (OrdP (Var m) AND x EQ HPair (HTuple 6) (Var m))"
  by (auto simp: eqvt_def IndP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows IndP_fresh_iff [simp]: "a \<sharp> IndP x \<longleftrightarrow> a \<sharp> x"                (is ?thesis1)
    and IndP_sf [iff]:         "Sigma_fm (IndP x)"                   (is ?thsf)
    and OrdP_IndP_Q_Ind:       "{OrdP x} \<turnstile> IndP (Q_Ind x)"           (is ?thqind)
proof -
  obtain m::name where "atom m \<sharp> x"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf ?thqind
    by (auto intro: Ex_I [where x=x])
qed

lemma IndP_Q_Ind: "H \<turnstile> OrdP x \<Longrightarrow> H \<turnstile> IndP (Q_Ind x)"
  by (rule cut1 [OF OrdP_IndP_Q_Ind])

lemma subst_fm_IndP [simp]: "(IndP t)(i::=x) = IndP (subst i x t)"
proof -
  obtain m::name where "atom m \<sharp> (i,t,x)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: IndP.simps [of m])
qed

lemma IndP_cong: "H \<turnstile> x EQ x' \<Longrightarrow> H \<turnstile> IndP x IFF IndP x'"
  by (rule P1_cong) auto

subsection \<open>Various syntactic lemmas\<close>

section \<open>The predicate \<open>SeqCTermP\<close>, for Terms and Constants\<close>

(*SeqCTerm(s,k,t) \<equiv> LstSeq(s,k,t) \<and> (\<forall>l\<in>k)[s l=0 \<or> Var(s l)\<or>(\<exists>m,n\<in>l)[s l = \<langle>Eats, s m, s n\<rangle>]]*)
nominal_function SeqCTermP :: "bool \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom l \<sharp> (s,k,sl,m,n,sm,sn);  atom sl \<sharp> (s,m,n,sm,sn);
          atom m \<sharp> (s,n,sm,sn);  atom n \<sharp> (s,sm,sn);
          atom sm \<sharp> (s,sn);  atom sn \<sharp> (s)\<rbrakk> \<Longrightarrow>
    SeqCTermP vf s k t =
      LstSeqP s k t AND
      All2 l (SUCC k) (Ex sl (HPair (Var l) (Var sl) IN s AND
               (Var sl EQ Zero OR (if vf then VarP (Var sl) else Fls) OR
                Ex m (Ex n (Ex sm (Ex sn (Var m IN Var l AND Var n IN Var l AND
                       HPair (Var m) (Var sm) IN s AND HPair (Var n) (Var sn) IN s AND
                       Var sl EQ Q_Eats (Var sm) (Var sn))))))))"
  by (auto simp: eqvt_def SeqCTermP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows SeqCTermP_fresh_iff [simp]:
       "a \<sharp> SeqCTermP vf s k t \<longleftrightarrow> a \<sharp> s \<and> a \<sharp> k \<and> a \<sharp> t"  (is ?thesis1)
    and SeqCTermP_sf [iff]:
       "Sigma_fm (SeqCTermP vf s k t)"   (is ?thsf)
    and SeqCTermP_imp_LstSeqP:
      "{ SeqCTermP vf s k t } \<turnstile> LstSeqP s k t"  (is ?thlstseq)
    and SeqCTermP_imp_OrdP [simp]:
      "{ SeqCTermP vf s k t } \<turnstile> OrdP k"  (is ?thord)
proof -
  obtain l::name and sl::name and m::name and n::name and sm::name and sn::name
    where atoms: "atom l \<sharp> (s,k,sl,m,n,sm,sn)"   "atom sl \<sharp> (s,m,n,sm,sn)"
        "atom m \<sharp> (s,n,sm,sn)"   "atom n \<sharp> (s,sm,sn)"
        "atom sm \<sharp> (s,sn)"   "atom sn \<sharp> (s)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf ?thlstseq ?thord
    by (auto simp: LstSeqP.simps)
qed

lemma SeqCTermP_subst [simp]:
      "(SeqCTermP vf s k t)(j::=w) = SeqCTermP vf (subst j w s) (subst j w k) (subst j w t)"
proof -
  obtain l::name and sl::name and m::name and n::name and sm::name and sn::name
    where "atom l \<sharp> (j,w,s,k,sl,m,n,sm,sn)"   "atom sl \<sharp> (j,w,s,m,n,sm,sn)"
          "atom m \<sharp> (j,w,s,n,sm,sn)"   "atom n \<sharp> (j,w,s,sm,sn)"
          "atom sm \<sharp> (j,w,s,sn)"   "atom sn \<sharp> (j,w,s)"
    by (metis obtain_fresh)
  thus ?thesis
    by (force simp add: SeqCTermP.simps [of l _ _ sl m n sm sn])
qed

declare SeqCTermP.simps [simp del]

abbreviation SeqTermP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "SeqTermP \<equiv> SeqCTermP True"

abbreviation SeqConstP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "SeqConstP \<equiv> SeqCTermP False"

lemma SeqConstP_imp_SeqTermP: "{SeqConstP s k t} \<turnstile> SeqTermP s k t"
proof -
  obtain l::name and sl::name and m::name and n::name and sm::name and sn::name
    where "atom l \<sharp> (s,k,t,sl,m,n,sm,sn)"   "atom sl \<sharp> (s,k,t,m,n,sm,sn)"
          "atom m \<sharp> (s,k,t,n,sm,sn)"   "atom n \<sharp> (s,k,t,sm,sn)"
          "atom sm \<sharp> (s,k,t,sn)"   "atom sn \<sharp> (s,k,t)"
    by (metis obtain_fresh)
  thus ?thesis
    apply (auto simp: SeqCTermP.simps [of l s k sl m n sm sn])
    apply (rule Ex_I [where x="Var l"], auto)
    apply (rule Ex_I [where x = "Var sl"], force intro: Disj_I1)
    apply (rule Ex_I [where x = "Var sl"], simp)
    apply (rule Conj_I, blast)
    apply (rule Disj_I2)+
    apply (rule Ex_I [where x = "Var m"], simp)
    apply (rule Ex_I [where x = "Var n"], simp)
    apply (rule Ex_I [where x = "Var sm"], simp)
    apply (rule Ex_I [where x = "Var sn"], auto)
    done
qed

section \<open>The predicates \<open>TermP\<close> and \<open>ConstP\<close>\<close>

subsection \<open>Definition\<close>

nominal_function CTermP :: "bool \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom k \<sharp> (s,t); atom s \<sharp> t\<rbrakk> \<Longrightarrow>
    CTermP vf t = Ex s (Ex k (SeqCTermP vf (Var s) (Var k) t))"
  by (auto simp: eqvt_def CTermP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows CTermP_fresh_iff [simp]: "a \<sharp> CTermP vf t \<longleftrightarrow> a \<sharp> t"            (is ?thesis1)
    and CTermP_sf [iff]: "Sigma_fm (CTermP vf t)"                      (is ?thsf)
proof -
  obtain k::name and s::name  where "atom k \<sharp> (s,t)" "atom s \<sharp> t"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf
    by auto
qed

lemma CTermP_subst [simp]: "(CTermP vf i)(j::=w) = CTermP vf (subst j w i)"
proof -
  obtain k::name and s::name  where "atom k \<sharp> (s,i,j,w)" "atom s \<sharp> (i,j,w)"
    by (metis obtain_fresh)
  thus ?thesis
    by (simp add: CTermP.simps [of k s])
qed

abbreviation TermP :: "tm \<Rightarrow> fm"
  where "TermP \<equiv> CTermP True"

abbreviation ConstP :: "tm \<Rightarrow> fm"
  where "ConstP \<equiv> CTermP False"

subsection \<open>Correctness properties for constants\<close>

lemma ConstP_imp_TermP: "{ConstP t} \<turnstile> TermP t"
proof -
  obtain k::name and s::name  where "atom k \<sharp> (s,t)" "atom s \<sharp> t"
    by (metis obtain_fresh)
  thus ?thesis
    apply auto
    apply (rule Ex_I [where x = "Var s"], simp)
    apply (rule Ex_I [where x = "Var k"], auto intro: SeqConstP_imp_SeqTermP [THEN cut1])
    done
qed

section \<open>Abstraction over terms\<close>

nominal_function SeqStTermP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom l \<sharp> (s,k,v,i,sl,sl',m,n,sm,sm',sn,sn');
          atom sl \<sharp> (s,v,i,sl',m,n,sm,sm',sn,sn'); atom sl' \<sharp> (s,v,i,m,n,sm,sm',sn,sn');
          atom m \<sharp> (s,n,sm,sm',sn,sn'); atom n \<sharp> (s,sm,sm',sn,sn');
          atom sm \<sharp> (s,sm',sn,sn'); atom sm' \<sharp> (s,sn,sn');
          atom sn \<sharp> (s,sn'); atom sn' \<sharp> s\<rbrakk> \<Longrightarrow>
    SeqStTermP v i t u s k =
      VarP v AND LstSeqP s k (HPair t u) AND
      All2 l (SUCC k) (Ex sl (Ex sl' (HPair (Var l) (HPair (Var sl) (Var sl')) IN s AND
                (((Var sl EQ v AND Var sl' EQ i) OR
                  ((IndP (Var sl) OR Var sl NEQ v) AND Var sl' EQ Var sl)) OR
                Ex m (Ex n (Ex sm (Ex sm' (Ex sn (Ex sn' (Var m IN Var l AND Var n IN Var l AND
                       HPair (Var m) (HPair (Var sm) (Var sm')) IN s AND
                       HPair (Var n) (HPair (Var sn) (Var sn')) IN s AND
                       Var sl EQ Q_Eats (Var sm) (Var sn) AND
                       Var sl' EQ Q_Eats (Var sm') (Var sn')))))))))))"
  apply (simp_all add: eqvt_def SeqStTermP_graph_aux_def flip_fresh_fresh)
  by auto (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows SeqStTermP_fresh_iff [simp]:
      "a \<sharp> SeqStTermP v i t u s k \<longleftrightarrow> a \<sharp> v \<and> a \<sharp> i \<and> a \<sharp> t \<and> a \<sharp> u \<and> a \<sharp> s \<and> a \<sharp> k"  (is ?thesis1)
    and SeqStTermP_sf [iff]:
      "Sigma_fm (SeqStTermP v i t u s k)"  (is ?thsf)
    and SeqStTermP_imp_OrdP:
      "{ SeqStTermP v i t u s k } \<turnstile> OrdP k"  (is ?thord)
    and SeqStTermP_imp_VarP:
      "{ SeqStTermP v i t u s k } \<turnstile> VarP v"  (is ?thvar)
    and SeqStTermP_imp_LstSeqP:
      "{ SeqStTermP v i t u s k } \<turnstile> LstSeqP s k (HPair t u)"  (is ?thlstseq)
proof -
  obtain l::name and sl::name and sl'::name and m::name and n::name and
         sm::name and sm'::name and sn::name and sn'::name
    where atoms:
       "atom l \<sharp> (s,k,v,i,sl,sl',m,n,sm,sm',sn,sn')"
       "atom sl \<sharp> (s,v,i,sl',m,n,sm,sm',sn,sn')" "atom sl' \<sharp> (s,v,i,m,n,sm,sm',sn,sn')"
       "atom m \<sharp> (s,n,sm,sm',sn,sn')" "atom n \<sharp> (s,sm,sm',sn,sn')"
       "atom sm \<sharp> (s,sm',sn,sn')" "atom sm' \<sharp> (s,sn,sn')"
       "atom sn \<sharp> (s,sn')" "atom sn' \<sharp> (s)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf ?thord ?thvar ?thlstseq
    by (auto intro: LstSeqP_OrdP)
qed

lemma SeqStTermP_subst [simp]:
      "(SeqStTermP v i t u s k)(j::=w) =
       SeqStTermP (subst j w v) (subst j w i) (subst j w t) (subst j w u) (subst j w s) (subst j w k)"
proof -
  obtain l::name and sl::name and sl'::name and m::name and n::name and
         sm::name and sm'::name and sn::name and sn'::name
    where "atom l \<sharp> (s,k,v,i,w,j,sl,sl',m,n,sm,sm',sn,sn')"
         "atom sl \<sharp> (s,v,i,w,j,sl',m,n,sm,sm',sn,sn')"
         "atom sl' \<sharp> (s,v,i,w,j,m,n,sm,sm',sn,sn')"
         "atom m \<sharp> (s,w,j,n,sm,sm',sn,sn')" "atom n \<sharp> (s,w,j,sm,sm',sn,sn')"
         "atom sm \<sharp> (s,w,j,sm',sn,sn')" "atom sm' \<sharp> (s,w,j,sn,sn')"
         "atom sn \<sharp> (s,w,j,sn')" "atom sn' \<sharp> (s,w,j)"
    by (metis obtain_fresh)
  thus ?thesis
    by (force simp add: SeqStTermP.simps [of l _ _ _ _ sl sl' m n sm sm' sn sn'])
qed

lemma SeqStTermP_cong:
  "\<lbrakk>H \<turnstile> t EQ t'; H \<turnstile> u EQ u'; H \<turnstile> s EQ s'; H \<turnstile> k EQ k'\<rbrakk>
   \<Longrightarrow> H \<turnstile> SeqStTermP v i t u s k IFF SeqStTermP v i t' u' s' k'"
   by (rule P4_cong [where tms="[v,i]"]) (auto simp: fresh_Cons)

declare SeqStTermP.simps [simp del]

subsection \<open>Defining the syntax: main predicate\<close>

nominal_function AbstTermP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom s \<sharp> (v,i,t,u,k); atom k \<sharp> (v,i,t,u)\<rbrakk> \<Longrightarrow>
    AbstTermP v i t u =
     OrdP i AND Ex s (Ex k (SeqStTermP v (Q_Ind i) t u (Var s) (Var k)))"
  by (auto simp: eqvt_def AbstTermP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows AbstTermP_fresh_iff [simp]:
      "a \<sharp> AbstTermP v i t u \<longleftrightarrow> a \<sharp> v \<and> a \<sharp> i \<and> a \<sharp> t \<and> a \<sharp> u"  (is ?thesis1)
    and AbstTermP_sf [iff]:
      "Sigma_fm (AbstTermP v i t u)"  (is ?thsf)
    and AbstTermP_imp_VarP:
       "{ AbstTermP v i t u } \<turnstile> VarP v"   (is ?thvar)
    and AbstTermP_imp_OrdP:
       "{ AbstTermP v i t u } \<turnstile> OrdP i"   (is ?thord)
proof -
  obtain s::name and k::name where "atom s \<sharp> (v,i,t,u,k)"  "atom k \<sharp> (v,i,t,u)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf ?thvar ?thord
    by (auto intro: SeqStTermP_imp_VarP thin2)
qed

lemma AbstTermP_subst [simp]:
      "(AbstTermP v i t u)(j::=w) = AbstTermP (subst j w v) (subst j w i) (subst j w t) (subst j w u)"
proof -
  obtain s::name and k::name  where "atom s \<sharp> (v,i,t,u,w,j,k)"  "atom k \<sharp> (v,i,t,u,w,j)"
    by (metis obtain_fresh)
  thus ?thesis
    by (simp add: AbstTermP.simps [of s _ _ _ _ k])
qed

declare AbstTermP.simps [simp del]

section \<open>Substitution over terms\<close>

subsection \<open>Defining the syntax\<close>

nominal_function SubstTermP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom s \<sharp> (v,i,t,u,k); atom k \<sharp> (v,i,t,u)\<rbrakk> \<Longrightarrow>
    SubstTermP v i t u = TermP i AND Ex s (Ex k (SeqStTermP v i t u (Var s) (Var k)))"
  by (auto simp: eqvt_def SubstTermP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows SubstTermP_fresh_iff [simp]:
       "a \<sharp> SubstTermP v i t u \<longleftrightarrow> a \<sharp> v \<and> a \<sharp> i \<and> a \<sharp> t \<and> a \<sharp> u"  (is ?thesis1)
    and SubstTermP_sf [iff]:
       "Sigma_fm (SubstTermP v i t u)"     (is ?thsf)
    and SubstTermP_imp_TermP:
       "{ SubstTermP v i t u } \<turnstile> TermP i"  (is ?thterm)
    and SubstTermP_imp_VarP:
       "{ SubstTermP v i t u } \<turnstile> VarP v"   (is ?thvar)
proof -
  obtain s::name and k::name  where "atom s \<sharp> (v,i,t,u,k)" "atom k \<sharp> (v,i,t,u)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf ?thterm ?thvar
    by (auto intro: SeqStTermP_imp_VarP thin2)
qed

lemma SubstTermP_subst [simp]:
      "(SubstTermP v i t u)(j::=w) = SubstTermP (subst j w v) (subst j w i) (subst j w t) (subst j w u)"
proof -
  obtain s::name and k::name
    where "atom s \<sharp> (v,i,t,u,w,j,k)"  "atom k \<sharp> (v,i,t,u,w,j)"
    by (metis obtain_fresh)
  thus ?thesis
    by (simp add: SubstTermP.simps [of s _ _ _ _ k])
qed

lemma SubstTermP_cong:
  "\<lbrakk>H \<turnstile> v EQ v'; H \<turnstile> i EQ i'; H \<turnstile> t EQ t'; H \<turnstile> u EQ u'\<rbrakk>
   \<Longrightarrow> H \<turnstile> SubstTermP v i t u IFF SubstTermP v' i' t' u'"
  by (rule P4_cong) auto

declare SubstTermP.simps [simp del]

section \<open>Abstraction over formulas\<close>

subsection \<open>The predicate \<open>AbstAtomicP\<close>\<close>

nominal_function AbstAtomicP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom t \<sharp> (v,i,y,y',t',u,u'); atom t' \<sharp> (v,i,y,y',u,u');
          atom u \<sharp> (v,i,y,y',u'); atom u' \<sharp> (v,i,y,y')\<rbrakk> \<Longrightarrow>
    AbstAtomicP v i y y' =
         Ex t (Ex u (Ex t' (Ex u'
           (AbstTermP v i (Var t) (Var t') AND AbstTermP v i (Var u) (Var u') AND
                      ((y EQ Q_Eq (Var t) (Var u) AND y' EQ Q_Eq (Var t') (Var u')) OR
                       (y EQ Q_Mem (Var t) (Var u) AND y' EQ Q_Mem (Var t') (Var u')))))))"
  by (auto simp: eqvt_def AbstAtomicP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows AbstAtomicP_fresh_iff [simp]:
       "a \<sharp> AbstAtomicP v i y y' \<longleftrightarrow> a \<sharp> v \<and> a \<sharp> i \<and> a \<sharp> y \<and> a \<sharp> y'"         (is ?thesis1)
    and AbstAtomicP_sf [iff]: "Sigma_fm (AbstAtomicP v i y y')"              (is ?thsf)
proof -
  obtain t::name and u::name and t'::name  and u'::name
    where "atom t \<sharp> (v,i,y,y',t',u,u')" "atom t' \<sharp> (v,i,y,y',u,u')"
          "atom u \<sharp> (v,i,y,y',u')" "atom u' \<sharp> (v,i,y,y')"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf
    by auto
qed

lemma AbstAtomicP_subst [simp]:
      "(AbstAtomicP v tm y y')(i::=w) = AbstAtomicP (subst i w v) (subst i w tm) (subst i w y) (subst i w y')"
proof -
  obtain t::name and u::name and t'::name  and u'::name
    where "atom t \<sharp> (v,tm,y,y',w,i,t',u,u')"  "atom t' \<sharp> (v,tm,y,y',w,i,u,u')"
          "atom u \<sharp> (v,tm,y,y',w,i,u')"       "atom u' \<sharp> (v,tm,y,y',w,i)"
    by (metis obtain_fresh)
  thus ?thesis
    by (simp add: AbstAtomicP.simps [of t _ _ _ _ t' u u'])
qed

declare AbstAtomicP.simps [simp del]

subsection \<open>The predicate \<open>AbsMakeForm\<close>\<close>

nominal_function SeqAbstFormP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom l \<sharp> (s,k,v,sli,sl,sl',m,n,smi,sm,sm',sni,sn,sn');
          atom sli \<sharp> (s,v,sl,sl',m,n,smi,sm,sm',sni,sn,sn');
          atom sl \<sharp> (s,v,sl',m,n,smi,sm,sm',sni,sn,sn');
          atom sl' \<sharp> (s,v,m,n,smi,sm,sm',sni,sn,sn');
          atom m \<sharp> (s,n,smi,sm,sm',sni,sn,sn');
          atom n \<sharp> (s,smi,sm,sm',sni,sn,sn'); atom smi \<sharp> (s,sm,sm',sni,sn,sn');
          atom sm \<sharp> (s,sm',sni,sn,sn'); atom sm' \<sharp> (s,sni,sn,sn');
          atom sni \<sharp> (s,sn,sn'); atom sn \<sharp> (s,sn'); atom sn' \<sharp> (s)\<rbrakk> \<Longrightarrow>
    SeqAbstFormP v i x x' s k =
      LstSeqP s k (HPair i (HPair x x')) AND
      All2 l (SUCC k) (Ex sli (Ex sl (Ex sl' (HPair (Var l) (HPair (Var sli) (HPair (Var sl) (Var sl'))) IN s AND
                (AbstAtomicP v (Var sli) (Var sl) (Var sl') OR
                OrdP (Var sli) AND
                Ex m (Ex n (Ex smi (Ex sm (Ex sm' (Ex sni (Ex sn (Ex sn'
                      (Var m IN Var l AND Var n IN Var l AND
                       HPair (Var m) (HPair (Var smi) (HPair (Var sm) (Var sm'))) IN s AND
                       HPair (Var n) (HPair (Var sni) (HPair (Var sn) (Var sn'))) IN s AND
                       ((Var sli EQ Var smi AND Var sli EQ Var sni AND
                         Var sl EQ Q_Disj (Var sm) (Var sn) AND
                         Var sl' EQ Q_Disj (Var sm') (Var sn')) OR
                        (Var sli EQ Var smi AND
                         Var sl EQ Q_Neg (Var sm) AND Var sl' EQ Q_Neg (Var sm')) OR
                        (SUCC (Var sli) EQ Var smi AND
                         Var sl EQ Q_Ex (Var sm) AND Var sl' EQ Q_Ex (Var sm'))))))))))))))))"
  by (auto simp: eqvt_def SeqAbstFormP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows SeqAbstFormP_fresh_iff [simp]:
       "a \<sharp> SeqAbstFormP v i x x' s k \<longleftrightarrow> a \<sharp> v \<and> a \<sharp> i \<and> a \<sharp> x \<and> a \<sharp> x' \<and> a \<sharp> s \<and> a \<sharp> k"  (is ?thesis1)
    and SeqAbstFormP_sf [iff]:
       "Sigma_fm (SeqAbstFormP v i x x' s k)"  (is ?thsf)
    and SeqAbstFormP_imp_OrdP:
       "{ SeqAbstFormP v u x x' s k } \<turnstile> OrdP k"  (is ?thOrd)
    and SeqAbstFormP_imp_LstSeqP:
       "{ SeqAbstFormP v u x x' s k } \<turnstile> LstSeqP s k (HPair u (HPair x x'))"  (is ?thLstSeq)
proof -
  obtain l::name and sli::name and sl::name and sl'::name and m::name and n::name and
         smi::name and sm::name and sm'::name and sni::name and sn::name and sn'::name
    where atoms:
         "atom l \<sharp> (s,k,v,sli,sl,sl',m,n,smi,sm,sm',sni,sn,sn')"
         "atom sli \<sharp> (s,v,sl,sl',m,n,smi,sm,sm',sni,sn,sn')"
         "atom sl \<sharp> (s,v,sl',m,n,smi,sm,sm',sni,sn,sn')"
         "atom sl' \<sharp> (s,v,m,n,smi,sm,sm',sni,sn,sn')"
         "atom m \<sharp> (s,n,smi,sm,sm',sni,sn,sn')" "atom n \<sharp> (s,smi,sm,sm',sni,sn,sn')"
         "atom smi \<sharp> (s,sm,sm',sni,sn,sn')"
         "atom sm \<sharp> (s,sm',sni,sn,sn')"
         "atom sm' \<sharp> (s,sni,sn,sn')"
         "atom sni \<sharp> (s,sn,sn')" "atom sn \<sharp> (s,sn')" "atom sn' \<sharp> s"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf ?thOrd ?thLstSeq
    by (auto intro: LstSeqP_OrdP)
qed

lemma SeqAbstFormP_subst [simp]:
      "(SeqAbstFormP v u x x' s k)(i::=t) =
       SeqAbstFormP (subst i t v) (subst i t u) (subst i t x) (subst i t x') (subst i t s) (subst i t k)"
proof -
  obtain l::name and sli::name and sl::name and sl'::name and m::name and n::name and
         smi::name and sm::name and sm'::name and sni::name and sn::name and sn'::name
   where "atom l \<sharp> (i,t,s,k,v,sli,sl,sl',m,n,smi,sm,sm',sni,sn,sn')"
         "atom sli \<sharp> (i,t,s,v,sl,sl',m,n,smi,sm,sm',sni,sn,sn')"
         "atom sl \<sharp> (i,t,s,v,sl',m,n,smi,sm,sm',sni,sn,sn')"
         "atom sl' \<sharp> (i,t,s,v,m,n,smi,sm,sm',sni,sn,sn')"
         "atom m \<sharp> (i,t,s,n,smi,sm,sm',sni,sn,sn')"
         "atom n \<sharp> (i,t,s,smi,sm,sm',sni,sn,sn')"
         "atom smi \<sharp> (i,t,s,sm,sm',sni,sn,sn')"
         "atom sm \<sharp> (i,t,s,sm',sni,sn,sn')" "atom sm' \<sharp> (i,t,s,sni,sn,sn')"
         "atom sni \<sharp> (i,t,s,sn,sn')" "atom sn \<sharp> (i,t,s,sn')" "atom sn' \<sharp> (i,t,s)"
    by (metis obtain_fresh)
  thus ?thesis
    by (force simp add: SeqAbstFormP.simps [of l _ _ _ sli sl sl' m n smi sm sm' sni sn sn'])
qed

declare SeqAbstFormP.simps [simp del]

subsection \<open>Defining the syntax: the main AbstForm predicate\<close>

nominal_function AbstFormP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom s \<sharp> (v,i,x,x',k);
          atom k \<sharp> (v,i,x,x')\<rbrakk> \<Longrightarrow>
    AbstFormP v i x x' = VarP v AND OrdP i AND Ex s (Ex k (SeqAbstFormP v i x x' (Var s) (Var k)))"
  by (auto simp: eqvt_def AbstFormP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows AbstFormP_fresh_iff [simp]:
       "a \<sharp> AbstFormP v i x x' \<longleftrightarrow> a \<sharp> v \<and> a \<sharp> i \<and> a \<sharp> x \<and> a \<sharp> x'" (is ?thesis1)
    and AbstFormP_sf [iff]:
       "Sigma_fm (AbstFormP v i x x')"    (is ?thsf)
proof -
  obtain s::name and k::name  where "atom s \<sharp> (v,i,x,x',k)" "atom k \<sharp> (v,i,x,x')"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf
    by auto
qed

lemma AbstFormP_subst [simp]:
     "(AbstFormP v i x x')(j::=t) = AbstFormP (subst j t v) (subst j t i) (subst j t x) (subst j t x')"
proof -
  obtain s::name and k::name  where "atom s \<sharp> (v,i,x,x',t,j,k)" "atom k \<sharp> (v,i,x,x',t,j)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: AbstFormP.simps [of s _ _ _ _ k])
qed

declare AbstFormP.simps [simp del]

section \<open>Substitution over formulas\<close>

subsection \<open>The predicate \<open>SubstAtomicP\<close>\<close>

nominal_function SubstAtomicP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom t \<sharp> (v,tm,y,y',t',u,u');
          atom t' \<sharp> (v,tm,y,y',u,u');
          atom u \<sharp> (v,tm,y,y',u');
          atom u' \<sharp> (v,tm,y,y')\<rbrakk> \<Longrightarrow>
    SubstAtomicP v tm y y' =
         Ex t (Ex u (Ex t' (Ex u'
           (SubstTermP v tm (Var t) (Var t') AND SubstTermP v tm (Var u) (Var u') AND
                      ((y EQ Q_Eq (Var t) (Var u) AND y' EQ Q_Eq (Var t') (Var u')) OR
                       (y EQ Q_Mem (Var t) (Var u) AND y' EQ Q_Mem (Var t') (Var u')))))))"
by (auto simp: eqvt_def SubstAtomicP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows SubstAtomicP_fresh_iff [simp]:
       "a \<sharp> SubstAtomicP v tm y y' \<longleftrightarrow> a \<sharp> v \<and> a \<sharp> tm \<and> a \<sharp> y \<and> a \<sharp> y'"           (is ?thesis1)
    and SubstAtomicP_sf [iff]: "Sigma_fm (SubstAtomicP v tm y y')"               (is ?thsf)
proof -
  obtain t::name and u::name and t'::name  and u'::name
    where "atom t \<sharp> (v,tm,y,y',t',u,u')" "atom t' \<sharp> (v,tm,y,y',u,u')"
          "atom u \<sharp> (v,tm,y,y',u')" "atom u' \<sharp> (v,tm,y,y')"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf
    by auto
qed

lemma SubstAtomicP_subst [simp]:
  "(SubstAtomicP v tm y y')(i::=w) = SubstAtomicP (subst i w v) (subst i w tm) (subst i w y) (subst i w y')"
proof -
  obtain t::name and u::name and t'::name  and u'::name
    where "atom t \<sharp> (v,tm,y,y',w,i,t',u,u')" "atom t' \<sharp> (v,tm,y,y',w,i,u,u')"
          "atom u \<sharp> (v,tm,y,y',w,i,u')" "atom u' \<sharp> (v,tm,y,y',w,i)"
    by (metis obtain_fresh)
  thus ?thesis
    by (simp add: SubstAtomicP.simps [of t _ _ _ _ t' u u'])
qed

lemma SubstAtomicP_cong:
  "\<lbrakk>H \<turnstile> v EQ v'; H \<turnstile> tm EQ tm'; H \<turnstile> x EQ x'; H \<turnstile> y EQ y'\<rbrakk>
   \<Longrightarrow> H \<turnstile> SubstAtomicP v tm x y IFF SubstAtomicP v' tm' x' y'"
  by (rule P4_cong) auto

subsection \<open>The predicate \<open>SubstMakeForm\<close>\<close>

nominal_function SeqSubstFormP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom l \<sharp> (s,k,v,u,sl,sl',m,n,sm,sm',sn,sn');
          atom sl \<sharp> (s,v,u,sl',m,n,sm,sm',sn,sn');
          atom sl' \<sharp> (s,v,u,m,n,sm,sm',sn,sn');
          atom m \<sharp> (s,n,sm,sm',sn,sn'); atom n \<sharp> (s,sm,sm',sn,sn');
          atom sm \<sharp> (s,sm',sn,sn'); atom sm' \<sharp> (s,sn,sn');
          atom sn \<sharp> (s,sn'); atom sn' \<sharp> s\<rbrakk> \<Longrightarrow>
    SeqSubstFormP v u x x' s k =
      LstSeqP s k (HPair x x') AND
      All2 l (SUCC k) (Ex sl (Ex sl' (HPair (Var l) (HPair (Var sl) (Var sl')) IN s AND
                (SubstAtomicP v u (Var sl) (Var sl') OR
                Ex m (Ex n (Ex sm (Ex sm' (Ex sn (Ex sn' (Var m IN Var l AND Var n IN Var l AND
                       HPair (Var m) (HPair (Var sm) (Var sm')) IN s AND
                       HPair (Var n) (HPair (Var sn) (Var sn')) IN s AND
                       ((Var sl EQ Q_Disj (Var sm) (Var sn) AND
                        Var sl' EQ Q_Disj (Var sm') (Var sn')) OR
                        (Var sl EQ Q_Neg (Var sm) AND Var sl' EQ Q_Neg (Var sm')) OR
                        (Var sl EQ Q_Ex (Var sm) AND Var sl' EQ Q_Ex (Var sm')))))))))))))"
  apply (simp_all add: eqvt_def SeqSubstFormP_graph_aux_def flip_fresh_fresh)
  by auto (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows SeqSubstFormP_fresh_iff [simp]:
       "a \<sharp> SeqSubstFormP v u x x' s k \<longleftrightarrow> a \<sharp> v \<and> a \<sharp> u \<and> a \<sharp> x \<and> a \<sharp> x' \<and> a \<sharp> s \<and> a \<sharp> k"  (is ?thesis1)
    and SeqSubstFormP_sf [iff]:
       "Sigma_fm (SeqSubstFormP v u x x' s k)"  (is ?thsf)
    and SeqSubstFormP_imp_OrdP:
       "{ SeqSubstFormP v u x x' s k } \<turnstile> OrdP k"  (is ?thOrd)
    and SeqSubstFormP_imp_LstSeqP:
       "{ SeqSubstFormP v u x x' s k } \<turnstile> LstSeqP s k (HPair x x')"  (is ?thLstSeq)
proof -
  obtain l::name and sl::name and sl'::name and m::name and n::name and
         sm::name and sm'::name and sn::name and sn'::name
    where atoms:
         "atom l \<sharp> (s,k,v,u,sl,sl',m,n,sm,sm',sn,sn')"
         "atom sl \<sharp> (s,v,u,sl',m,n,sm,sm',sn,sn')"
         "atom sl' \<sharp> (s,v,u,m,n,sm,sm',sn,sn')"
         "atom m \<sharp> (s,n,sm,sm',sn,sn')" "atom n \<sharp> (s,sm,sm',sn,sn')"
         "atom sm \<sharp> (s,sm',sn,sn')" "atom sm' \<sharp> (s,sn,sn')"
         "atom sn \<sharp> (s,sn')" "atom sn' \<sharp> (s)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf ?thOrd ?thLstSeq
    by (auto intro: LstSeqP_OrdP)
qed

lemma SeqSubstFormP_subst [simp]:
      "(SeqSubstFormP v u x x' s k)(i::=t) =
       SeqSubstFormP (subst i t v) (subst i t u) (subst i t x) (subst i t x') (subst i t s) (subst i t k)"
proof -
  obtain l::name and sl::name and sl'::name and m::name and n::name and
         sm::name and sm'::name and sn::name and sn'::name
   where "atom l \<sharp> (s,k,v,u,t,i,sl,sl',m,n,sm,sm',sn,sn')"
         "atom sl \<sharp> (s,v,u,t,i,sl',m,n,sm,sm',sn,sn')"
         "atom sl' \<sharp> (s,v,u,t,i,m,n,sm,sm',sn,sn')"
         "atom m \<sharp> (s,t,i,n,sm,sm',sn,sn')" "atom n \<sharp> (s,t,i,sm,sm',sn,sn')"
         "atom sm \<sharp> (s,t,i,sm',sn,sn')" "atom sm' \<sharp> (s,t,i,sn,sn')"
         "atom sn \<sharp> (s,t,i,sn')" "atom sn' \<sharp> (s,t,i)"
    by (metis obtain_fresh)
  thus ?thesis
    by (force simp add: SeqSubstFormP.simps [of l _ _ _ _ sl sl' m n sm sm' sn sn'])
qed

lemma SeqSubstFormP_cong:
  "\<lbrakk>H \<turnstile> t EQ t'; H \<turnstile> u EQ u'; H \<turnstile> s EQ s'; H \<turnstile> k EQ k'\<rbrakk>
   \<Longrightarrow> H \<turnstile> SeqSubstFormP v i t u s k IFF SeqSubstFormP v i t' u' s' k'"
   by (rule P4_cong [where tms="[v,i]"]) (auto simp: fresh_Cons)

declare SeqSubstFormP.simps [simp del]

subsection \<open>Defining the syntax: the main SubstForm predicate\<close>

nominal_function SubstFormP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom s \<sharp> (v,i,x,x',k); atom k \<sharp> (v,i,x,x')\<rbrakk> \<Longrightarrow>
    SubstFormP v i x x' =
      VarP v AND TermP i AND Ex s (Ex k (SeqSubstFormP v i x x' (Var s) (Var k)))"
  by (auto simp: eqvt_def SubstFormP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows SubstFormP_fresh_iff [simp]:
       "a \<sharp> SubstFormP v i x x' \<longleftrightarrow> a \<sharp> v \<and> a \<sharp> i \<and> a \<sharp> x \<and> a \<sharp> x'"  (is ?thesis1)
    and SubstFormP_sf [iff]:
       "Sigma_fm (SubstFormP v i x x')"  (is ?thsf)
proof -
  obtain s::name and k::name
    where "atom s \<sharp> (v,i,x,x',k)"  "atom k \<sharp> (v,i,x,x')"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf
    by auto
qed

lemma SubstFormP_subst [simp]:
     "(SubstFormP v i x x')(j::=t) = SubstFormP (subst j t v) (subst j t i) (subst j t x) (subst j t x')"
proof -
  obtain s::name and k::name  where "atom s \<sharp> (v,i,x,x',t,j,k)" "atom k \<sharp> (v,i,x,x',t,j)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SubstFormP.simps [of s _ _ _ _ k])
qed

lemma SubstFormP_cong:
  "\<lbrakk>H \<turnstile> v EQ v'; H \<turnstile> i EQ i'; H \<turnstile> t EQ t'; H \<turnstile> u EQ u'\<rbrakk>
   \<Longrightarrow> H \<turnstile> SubstFormP v i t u IFF SubstFormP v' i' t' u'"
  by (rule P4_cong) auto

lemma ground_SubstFormP [simp]: "ground_fm (SubstFormP v y x x') \<longleftrightarrow> ground v \<and> ground y \<and> ground x \<and> ground x'"
  by (auto simp: ground_aux_def ground_fm_aux_def supp_conv_fresh)

declare SubstFormP.simps [simp del]

section \<open>The predicate \<open>AtomicP\<close>\<close>

nominal_function AtomicP :: "tm \<Rightarrow> fm"
  where "\<lbrakk>atom t \<sharp> (u,y); atom u \<sharp> y\<rbrakk> \<Longrightarrow>
    AtomicP y = Ex t (Ex u (TermP (Var t) AND TermP (Var u) AND
                      (y EQ Q_Eq (Var t) (Var u) OR
                       y EQ Q_Mem (Var t) (Var u))))"
  by (auto simp: eqvt_def AtomicP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows AtomicP_fresh_iff [simp]: "a \<sharp> AtomicP y \<longleftrightarrow> a \<sharp> y"    (is ?thesis1)
    and AtomicP_sf [iff]: "Sigma_fm (AtomicP y)"  (is ?thsf)
proof -
  obtain t::name and u::name  where "atom t \<sharp> (u,y)"  "atom u \<sharp> y"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf
    by auto
qed

lemma AtompicP_subst [simp]: "(AtomicP t)(j::=w) = AtomicP (subst j w t)"
proof -
  obtain x y :: name where "atom x \<sharp> (j,w,t,y)"   "atom y \<sharp> (j,w,t)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: AtomicP.simps [of x y])
qed

section \<open>The predicate \<open>MakeForm\<close>\<close>

nominal_function MakeFormP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom v \<sharp> (y,u,w,au); atom au \<sharp> (y,u,w)\<rbrakk> \<Longrightarrow>
    MakeFormP y u w =
      y EQ Q_Disj u w OR y EQ Q_Neg u OR
      Ex v (Ex au (AbstFormP (Var v) Zero u (Var au) AND y EQ Q_Ex (Var au)))"
  by (auto simp: eqvt_def MakeFormP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows MakeFormP_fresh_iff [simp]:
       "a \<sharp> MakeFormP y u w \<longleftrightarrow> a \<sharp> y \<and> a \<sharp> u \<and> a \<sharp> w"  (is ?thesis1)
    and MakeFormP_sf [iff]:
       "Sigma_fm (MakeFormP y u w)"  (is ?thsf)
proof -
  obtain v::name and au::name  where "atom v \<sharp> (y,u,w,au)"  "atom au \<sharp> (y,u,w)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf
    by auto
qed

declare MakeFormP.simps [simp del]

lemma MakeFormP_subst [simp]: "(MakeFormP y u t)(j::=w) = MakeFormP (subst j w y) (subst j w u) (subst j w t)"
proof -
  obtain a b :: name where "atom a \<sharp> (j,w,y,u,t,b)"   "atom b \<sharp> (j,w,y,u,t)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: MakeFormP.simps [of a _ _ _ b])
qed

section \<open>The predicate \<open>SeqFormP\<close>\<close>

(*SeqForm(s,k,t) \<equiv> LstSeq(s,k,t) \<and> (\<forall>n\<in>k)[Atomic (s n) \<or> (\<exists>m,l\<in>n)[MakeForm (s m) (s l) (s n)]]*)

nominal_function SeqFormP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom l \<sharp> (s,k,t,sl,m,n,sm,sn); atom sl \<sharp> (s,k,t,m,n,sm,sn);
          atom m \<sharp> (s,k,t,n,sm,sn); atom n \<sharp> (s,k,t,sm,sn);
          atom sm \<sharp> (s,k,t,sn); atom sn \<sharp> (s,k,t)\<rbrakk> \<Longrightarrow>
    SeqFormP s k t =
      LstSeqP s k t AND
      All2 n (SUCC k) (Ex sn (HPair (Var n) (Var sn) IN s AND (AtomicP (Var sn) OR
                Ex m (Ex l (Ex sm (Ex sl (Var m IN Var n AND Var l IN Var n AND
                       HPair (Var m) (Var sm) IN s AND HPair (Var l) (Var sl) IN s AND
                       MakeFormP (Var sn) (Var sm) (Var sl))))))))"
  by (auto simp: eqvt_def SeqFormP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows SeqFormP_fresh_iff [simp]:
       "a \<sharp> SeqFormP s k t \<longleftrightarrow> a \<sharp> s \<and> a \<sharp> k \<and> a \<sharp> t" (is ?thesis1)
    and SeqFormP_sf [iff]: "Sigma_fm (SeqFormP s k t)"          (is ?thsf)
    and SeqFormP_imp_OrdP:
       "{ SeqFormP s k t } \<turnstile> OrdP k"  (is ?thOrd)
    and SeqFormP_imp_LstSeqP:
       "{ SeqFormP s k t } \<turnstile> LstSeqP s k t"  (is ?thLstSeq)
proof -
  obtain l::name and sl::name and m::name and n::name and sm::name and sn::name
    where atoms: "atom l \<sharp> (s,k,t,sl,m,n,sm,sn)"   "atom sl \<sharp> (s,k,t,m,n,sm,sn)"
        "atom m \<sharp> (s,k,t,n,sm,sn)"   "atom n \<sharp> (s,k,t,sm,sn)"
        "atom sm \<sharp> (s,k,t,sn)"       "atom sn \<sharp> (s,k,t)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf ?thOrd ?thLstSeq
    by (auto intro: LstSeqP_OrdP)
qed

lemma SeqFormP_subst [simp]:
      "(SeqFormP s k t)(j::=w) = SeqFormP (subst j w s) (subst j w k) (subst j w t)"
proof -
  obtain l::name and sl::name and m::name and n::name and sm::name and sn::name
    where "atom l \<sharp> (j,w,s,t,k,sl,m,n,sm,sn)"   "atom sl \<sharp> (j,w,s,k,t,m,n,sm,sn)"
        "atom m \<sharp> (j,w,s,k,t,n,sm,sn)"   "atom n \<sharp> (j,w,s,k,t,sm,sn)"
        "atom sm \<sharp> (j,w,s,k,t,sn)"   "atom sn \<sharp> (j,w,s,k,t)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SeqFormP.simps [of l _ _ _ sl m n sm sn])
qed

section \<open>The predicate \<open>FormP\<close>\<close>

subsection \<open>Definition\<close>

nominal_function FormP :: "tm \<Rightarrow> fm"
  where "\<lbrakk>atom k \<sharp> (s,y); atom s \<sharp> y\<rbrakk> \<Longrightarrow>
    FormP y = Ex k (Ex s (SeqFormP (Var s) (Var k) y))"
  by (auto simp: eqvt_def FormP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows FormP_fresh_iff [simp]: "a \<sharp> FormP y \<longleftrightarrow> a \<sharp> y"              (is ?thesis1)
    and FormP_sf [iff]:         "Sigma_fm (FormP y)"                 (is ?thsf)
proof -
  obtain k::name and s::name  where k: "atom k \<sharp> (s,y)" "atom s \<sharp> y"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf
    by auto
qed

lemma FormP_subst [simp]: "(FormP y)(j::=w) = FormP (subst j w y)"
proof -
  obtain k::name and s::name where "atom k \<sharp> (s,j,w,y)"  "atom s \<sharp> (j,w,y)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: FormP.simps [of k s])
qed

subsection \<open>The predicate \<open>VarNonOccFormP\<close> (Derived from \<open>SubstFormP\<close>)\<close>

nominal_function VarNonOccFormP :: "tm \<Rightarrow> tm \<Rightarrow> fm"
  where "VarNonOccFormP v x = FormP x AND SubstFormP v Zero x x"
  by (auto simp: eqvt_def VarNonOccFormP_graph_aux_def)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows VarNonOccFormP_fresh_iff [simp]: "a \<sharp> VarNonOccFormP v y \<longleftrightarrow> a \<sharp> v \<and> a \<sharp> y" (is ?thesis1)
    and VarNonOccFormP_sf [iff]: "Sigma_fm (VarNonOccFormP v y)" (is ?thsf)
proof -
  show ?thesis1 ?thsf
    by auto
qed

declare VarNonOccFormP.simps [simp del]

end


(*
  Author:  Jeremy Dawson, NICTA
*)

section {* Useful Numerical Lemmas *}

theory Misc_Numeric
imports Main
begin

lemma mod_2_neq_1_eq_eq_0:
  fixes k :: int
  shows "k mod 2 \<noteq> 1 \<longleftrightarrow> k mod 2 = 0"
  by (fact not_mod_2_eq_1_eq_0)

lemma z1pmod2:
  fixes b :: int
  shows "(2 * b + 1) mod 2 = (1::int)"
  by arith

lemma diff_le_eq':
  "a - b \<le> c \<longleftrightarrow> a \<le> b + (c::int)"
  by arith

lemma emep1:
  fixes n d :: int
  shows "even n \<Longrightarrow> even d \<Longrightarrow> 0 \<le> d \<Longrightarrow> (n + 1) mod d = (n mod d) + 1"
  by (auto simp add: pos_zmod_mult_2 add.commute dvd_def)

lemma int_mod_ge:
  "a < n \<Longrightarrow> 0 < (n :: int) \<Longrightarrow> a \<le> a mod n"
  by (metis dual_order.trans le_cases mod_pos_pos_trivial pos_mod_conj)

lemma int_mod_ge':
  "b < 0 \<Longrightarrow> 0 < (n :: int) \<Longrightarrow> b + n \<le> b mod n"
  by (metis add_less_same_cancel2 int_mod_ge mod_add_self2)

lemma int_mod_le':
  "(0::int) \<le> b - n \<Longrightarrow> b mod n \<le> b - n"
  by (metis minus_mod_self2 zmod_le_nonneg_dividend)

lemma zless2:
  "0 < (2 :: int)"
  by (fact zero_less_numeral)

lemma zless2p:
  "0 < (2 ^ n :: int)"
  by arith

lemma zle2p:
  "0 \<le> (2 ^ n :: int)"
  by arith

lemma m1mod2k:
  "- 1 mod 2 ^ n = (2 ^ n - 1 :: int)"
  using zless2p by (rule zmod_minus1)

lemma p1mod22k':
  fixes b :: int
  shows "(1 + 2 * b) mod (2 * 2 ^ n) = 1 + 2 * (b mod 2 ^ n)"
  using zle2p by (rule pos_zmod_mult_2)

lemma p1mod22k:
  fixes b :: int
  shows "(2 * b + 1) mod (2 * 2 ^ n) = 2 * (b mod 2 ^ n) + 1"
  by (simp add: p1mod22k' add.commute)

lemma int_mod_lem:
  "(0 :: int) < n ==> (0 <= b & b < n) = (b mod n = b)"
  apply safe
    apply (erule (1) mod_pos_pos_trivial)
   apply (erule_tac [!] subst)
   apply auto
  done

end


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

datatype Nat = Z | S "Nat"

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

fun add3acc :: "Nat => Nat => Nat => Nat" where
  "add3acc (Z) (Z) z = z"
| "add3acc (Z) (S x3) z = add3acc Z x3 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

fun mul3acc :: "Nat => Nat => Nat => Nat" where
  "mul3acc (Z) y z = Z"
| "mul3acc (S x2) (Z) z = Z"
| "mul3acc (S x2) (S x3) (Z) = Z"
| "mul3acc (S x2) (S x3) (S x4) =
     (let fail :: Nat =
       plus
         (S Z)
         (add3acc
            (mul3acc x2 x3 x4)
            (add3acc
               (mul3acc (S Z) x3 x4) (mul3acc x2 (S Z) x4) (mul3acc x2 x3 (S Z)))
            (add3acc (S x2) (S x3) (S x4)))
     in (if (x2 = Z) then
           (if (x3 = Z) then (if (x4 = Z) then S Z else fail) else fail)
           else
           fail))"

theorem property0 :
  "((mul3acc x y z) = (mul3acc y x z))"
  oops

end


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

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

datatype Nat = Z | S "Nat"

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

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

theorem property0 :
  "((S (count n xs)) = (count n (cons2 n xs)))"
  oops

end


theory Iteration
  imports Main
begin

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for f where
  iter_refl [simp]: "iter f a a"
| iter_step [simp]: "f a b \<Longrightarrow> iter f b c \<Longrightarrow> iter f a c"

lemma iter_one: "f a b \<Longrightarrow> iter f a b"
  by (metis iter_refl iter_step)

lemma iter_append: "iter f a b \<Longrightarrow> iter f b c \<Longrightarrow> iter f a c"
  by (induction a b rule: iter.induct) simp_all

lemma iter_step_after [simp]: "iter f a b \<Longrightarrow> f b c \<Longrightarrow> iter f a c"
  by (induction a b rule: iter.induct) simp_all

end