(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   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.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_21
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

fun rotate :: "Nat => 'a list => 'a list" where
  "rotate (Z) z = z"
| "rotate (S z2) (nil2) = nil2"
| "rotate (S z2) (cons2 x2 x3) =
     rotate z2 (x x3 (cons2 x2 (nil2)))"

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

theorem property0 :
  "((rotate (length y) (x y z)) = (x z y))"
  oops

end


(* Author: Johannes Hölzl <hoelzl@in.tum.de> *)

section \<open>Stopping times\<close>

theory Stopping_Time
  imports "HOL-Analysis.Analysis"
begin

subsection \<open>Stopping Time\<close>

text \<open>This is also called strong stopping time. Then stopping time is T with alternative is
  \<open>T x < t\<close> measurable.\<close>

definition stopping_time :: "('t::linorder \<Rightarrow> 'a measure) \<Rightarrow> ('a \<Rightarrow> 't) \<Rightarrow> bool"
where
  "stopping_time F T = (\<forall>t. Measurable.pred (F t) (\<lambda>x. T x \<le> t))"

lemma stopping_time_cong: "(\<And>t x. x \<in> space (F t) \<Longrightarrow> T x = S x) \<Longrightarrow> stopping_time F T = stopping_time F S"
  unfolding stopping_time_def by (intro arg_cong[where f=All] ext measurable_cong) simp

lemma stopping_timeD: "stopping_time F T \<Longrightarrow> Measurable.pred (F t) (\<lambda>x. T x \<le> t)"
  by (auto simp: stopping_time_def)

lemma stopping_timeD2: "stopping_time F T \<Longrightarrow> Measurable.pred (F t) (\<lambda>x. t < T x)"
  unfolding not_le[symmetric] by (auto intro: stopping_timeD Measurable.pred_intros_logic)

lemma stopping_timeI[intro?]: "(\<And>t. Measurable.pred (F t) (\<lambda>x. T x \<le> t)) \<Longrightarrow> stopping_time F T"
  by (auto simp: stopping_time_def)

lemma measurable_stopping_time:
  fixes T :: "'a \<Rightarrow> 't::{linorder_topology, second_countable_topology}"
  assumes T: "stopping_time F T"
    and M: "\<And>t. sets (F t) \<subseteq> sets M" "\<And>t. space (F t) = space M"
  shows "T \<in> M \<rightarrow>\<^sub>M borel"
proof (rule borel_measurableI_le)
  show "{x \<in> space M. T x \<le> t} \<in> sets M" for t
    using stopping_timeD[OF T] M by (auto simp: Measurable.pred_def)
qed

lemma stopping_time_const: "stopping_time F (\<lambda>x. c)"
  by (auto simp: stopping_time_def)

lemma stopping_time_min:
  "stopping_time F T \<Longrightarrow> stopping_time F S \<Longrightarrow> stopping_time F (\<lambda>x. min (T x) (S x))"
  by (auto simp: stopping_time_def min_le_iff_disj intro!: pred_intros_logic)

lemma stopping_time_max:
  "stopping_time F T \<Longrightarrow> stopping_time F S \<Longrightarrow> stopping_time F (\<lambda>x. max (T x) (S x))"
  by (auto simp: stopping_time_def intro!: pred_intros_logic)

section \<open>Filtration\<close>

locale filtration =
  fixes \<Omega> :: "'a set" and F :: "'t::{linorder_topology, second_countable_topology} \<Rightarrow> 'a measure"
  assumes space_F: "\<And>i. space (F i) = \<Omega>"
  assumes sets_F_mono: "\<And>i j. i \<le> j \<Longrightarrow> sets (F i) \<le> sets (F j)"
begin

subsection \<open>$\sigma$-algebra of a Stopping Time\<close>

definition pre_sigma :: "('a \<Rightarrow> 't) \<Rightarrow> 'a measure"
where
  "pre_sigma T = sigma \<Omega> {A. \<forall>t. {\<omega>\<in>A. T \<omega> \<le> t} \<in> sets (F t)}"

lemma space_pre_sigma: "space (pre_sigma T) = \<Omega>"
  unfolding pre_sigma_def using sets.space_closed[of "F _"]
  by (intro space_measure_of) (auto simp: space_F)

lemma measure_pre_sigma[simp]: "emeasure (pre_sigma T) = (\<lambda>_. 0)"
  by (simp add: pre_sigma_def emeasure_sigma)

lemma sigma_algebra_pre_sigma:
  assumes T: "stopping_time F T"
  shows "sigma_algebra \<Omega> {A. \<forall>t. {\<omega>\<in>A. T \<omega> \<le> t} \<in> sets (F t)}"
  unfolding sigma_algebra_iff2
proof (intro sigma_algebra_iff2[THEN iffD2] conjI ballI allI impI CollectI)
  show "{A. \<forall>t. {\<omega> \<in> A. T \<omega> \<le> t} \<in> sets (F t)} \<subseteq> Pow \<Omega>"
    using sets.space_closed[of "F _"] by (auto simp: space_F)
next
  fix A t assume "A \<in> {A. \<forall>t. {\<omega> \<in> A. T \<omega> \<le> t} \<in> sets (F t)}"
  then have "{\<omega> \<in> space (F t). T \<omega> \<le> t} - {\<omega> \<in> A. T \<omega> \<le> t} \<in> sets (F t)"
    using T stopping_timeD[measurable] by auto
  also have "{\<omega> \<in> space (F t). T \<omega> \<le> t} - {\<omega> \<in> A. T \<omega> \<le> t} = {\<omega> \<in> \<Omega> - A. T \<omega> \<le> t}"
    by (auto simp: space_F)
  finally show "{\<omega> \<in> \<Omega> - A. T \<omega> \<le> t} \<in> sets (F t)" .
next
  fix AA :: "nat \<Rightarrow> 'a set" and t assume "range AA \<subseteq> {A. \<forall>t. {\<omega> \<in> A. T \<omega> \<le> t} \<in> sets (F t)}"
  then have "(\<Union>i. {\<omega> \<in> AA i. T \<omega> \<le> t}) \<in> sets (F t)" for t
    by auto
  also have "(\<Union>i. {\<omega> \<in> AA i. T \<omega> \<le> t}) = {\<omega> \<in> \<Union>(AA ` UNIV). T \<omega> \<le> t}"
    by auto
  finally show "{\<omega> \<in> \<Union>(AA ` UNIV). T \<omega> \<le> t} \<in> sets (F t)" .
qed auto

lemma sets_pre_sigma: "stopping_time F T \<Longrightarrow> sets (pre_sigma T) = {A. \<forall>t. {\<omega>\<in>A. T \<omega> \<le> t} \<in> sets (F t)}"
  unfolding pre_sigma_def by (rule sigma_algebra.sets_measure_of_eq[OF sigma_algebra_pre_sigma])

lemma sets_pre_sigmaI: "stopping_time F T \<Longrightarrow> (\<And>t. {\<omega>\<in>A. T \<omega> \<le> t} \<in> sets (F t)) \<Longrightarrow> A \<in> sets (pre_sigma T)"
  unfolding sets_pre_sigma by auto

lemma pred_pre_sigmaI:
  assumes T: "stopping_time F T"
  shows "(\<And>t. Measurable.pred (F t) (\<lambda>\<omega>. P \<omega> \<and> T \<omega> \<le> t)) \<Longrightarrow> Measurable.pred (pre_sigma T) P"
  unfolding pred_def space_F space_pre_sigma by (intro sets_pre_sigmaI[OF T]) simp

lemma sets_pre_sigmaD: "stopping_time F T \<Longrightarrow> A \<in> sets (pre_sigma T) \<Longrightarrow> {\<omega>\<in>A. T \<omega> \<le> t} \<in> sets (F t)"
  unfolding sets_pre_sigma by auto

lemma stopping_time_le_const: "stopping_time F T \<Longrightarrow> s \<le> t \<Longrightarrow> Measurable.pred (F t) (\<lambda>\<omega>. T \<omega> \<le> s)"
  using stopping_timeD[of F T] sets_F_mono[of _ t] by (auto simp: pred_def space_F)

lemma measurable_stopping_time_pre_sigma:
  assumes T: "stopping_time F T" shows "T \<in> pre_sigma T \<rightarrow>\<^sub>M borel"
proof (intro borel_measurableI_le sets_pre_sigmaI[OF T])
  fix t t'
  have "{\<omega>\<in>space (F (min t' t)). T \<omega> \<le> min t' t} \<in> sets (F (min t' t))"
    using T unfolding pred_def[symmetric] by (rule stopping_timeD)
  also have "\<dots> \<subseteq> sets (F t)"
    by (rule sets_F_mono) simp
  finally show "{\<omega> \<in> {x \<in> space (pre_sigma T). T x \<le> t'}. T \<omega> \<le> t} \<in> sets (F t)"
    by (simp add: space_pre_sigma space_F)
qed

lemma mono_pre_sigma:
  assumes T: "stopping_time F T" and S: "stopping_time F S"
    and le: "\<And>\<omega>. \<omega> \<in> \<Omega> \<Longrightarrow> T \<omega> \<le> S \<omega>"
  shows "sets (pre_sigma T) \<subseteq> sets (pre_sigma S)"
  unfolding sets_pre_sigma[OF S] sets_pre_sigma[OF T]
proof safe
  interpret sigma_algebra \<Omega> "{A. \<forall>t. {\<omega>\<in>A. T \<omega> \<le> t} \<in> sets (F t)}"
    using T by (rule sigma_algebra_pre_sigma)
  fix A t assume A: "\<forall>t. {\<omega>\<in>A. T \<omega> \<le> t} \<in> sets (F t)"
  then have "A \<subseteq> \<Omega>"
    using sets_into_space by auto
  from A have "{\<omega>\<in>A. T \<omega> \<le> t} \<inter> {\<omega>\<in>space (F t). S \<omega> \<le> t} \<in> sets (F t)"
    using stopping_timeD[OF S] by (auto simp: pred_def)
  also have "{\<omega>\<in>A. T \<omega> \<le> t} \<inter> {\<omega>\<in>space (F t). S \<omega> \<le> t} = {\<omega>\<in>A. S \<omega> \<le> t}"
    using \<open>A \<subseteq> \<Omega>\<close> sets_into_space[of A] le by (auto simp: space_F intro: order_trans)
  finally show "{\<omega>\<in>A. S \<omega> \<le> t} \<in> sets (F t)"
    by auto
qed

lemma stopping_time_less_const:
  assumes T: "stopping_time F T" shows "Measurable.pred (F t) (\<lambda>\<omega>. T \<omega> < t)"
proof -
  obtain D :: "'t set"
    where D: "countable D" "\<And>X. open X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> \<exists>d\<in>D. d \<in> X"
  using countable_dense_setE by auto
  show ?thesis
  proof cases
    assume *: "\<forall>t'<t. \<exists>t''. t' < t'' \<and> t'' < t"
    { fix t' assume "t' < t"
      with * have "{t' <..< t} \<noteq> {}"
        by fastforce
      with D(2)[OF _ this]
      have "\<exists>d\<in>D. t'< d \<and> d < t"
        by auto }
    note ** = this

    show ?thesis
    proof (rule measurable_cong[THEN iffD2])
      show "T \<omega> < t \<longleftrightarrow> (\<exists>r\<in>{r\<in>D. r < t}. T \<omega> \<le> r)" for \<omega>
        by (auto dest: ** intro: less_imp_le)
      show "Measurable.pred (F t) (\<lambda>w. \<exists>r\<in>{r \<in> D. r < t}. T w \<le> r)"
        by (intro measurable_pred_countable stopping_time_le_const[OF T] countable_Collect D) auto
    qed
  next
    assume "\<not> (\<forall>t'<t. \<exists>t''. t' < t'' \<and> t'' < t)"
    then obtain t' where t': "t' < t" "\<And>t''. t'' < t \<Longrightarrow> t'' \<le> t'"
      by (auto simp: not_less[symmetric])
    show ?thesis
    proof (rule measurable_cong[THEN iffD2])
      show "T \<omega> < t \<longleftrightarrow> T \<omega> \<le> t'" for \<omega>
        using t' by auto
      show "Measurable.pred (F t) (\<lambda>w. T w \<le> t')"
        using \<open>t'<t\<close> by (intro stopping_time_le_const[OF T]) auto
    qed
  qed
qed

lemma stopping_time_eq_const: "stopping_time F T \<Longrightarrow> Measurable.pred (F t) (\<lambda>\<omega>. T \<omega> = t)"
  unfolding eq_iff using stopping_time_less_const[of T t]
  by (intro pred_intros_logic stopping_time_le_const) (auto simp: not_less[symmetric] )

lemma stopping_time_less:
  assumes T: "stopping_time F T" and S: "stopping_time F S"
  shows "Measurable.pred (pre_sigma T) (\<lambda>\<omega>. T \<omega> < S \<omega>)"
proof (rule pred_pre_sigmaI[OF T])
  fix t
  obtain D :: "'t set"
    where [simp]: "countable D" and semidense_D: "\<And>x y. x < y \<Longrightarrow> (\<exists>b\<in>D. x \<le> b \<and> b < y)"
    using countable_separating_set_linorder2 by auto
  show "Measurable.pred (F t) (\<lambda>\<omega>. T \<omega> < S \<omega> \<and> T \<omega> \<le> t)"
  proof (rule measurable_cong[THEN iffD2])
    let ?f = "\<lambda>\<omega>. if T \<omega> = t then \<not> S \<omega> \<le> t else \<exists>s\<in>{s\<in>D. s \<le> t}. T \<omega> \<le> s \<and> \<not> (S \<omega> \<le> s)"
    { fix \<omega> assume "T \<omega> \<le> t" "T \<omega> \<noteq> t" "T \<omega> < S \<omega>"
      then have "T \<omega> < min t (S \<omega>)"
        by auto
      then obtain r where "r \<in> D" "T \<omega> \<le> r" "r < min t (S \<omega>)"
        by (metis semidense_D)
      then have "\<exists>s\<in>{s\<in>D. s \<le> t}. T \<omega> \<le> s \<and> s < S \<omega>"
        by auto }
    then show "(T \<omega> < S \<omega> \<and> T \<omega> \<le> t) = ?f \<omega>" for \<omega>
      by (auto simp: not_le)
    show "Measurable.pred (F t) ?f"
      by (intro pred_intros_logic measurable_If measurable_pred_countable countable_Collect
                stopping_time_le_const predE stopping_time_eq_const T S)
         auto
  qed
qed

end

lemma stopping_time_SUP_enat:
  fixes T :: "nat \<Rightarrow> ('a \<Rightarrow> enat)"
  shows "(\<And>i. stopping_time F (T i)) \<Longrightarrow> stopping_time F (SUP i. T i)"
  unfolding stopping_time_def SUP_apply SUP_le_iff by (auto intro!: pred_intros_countable)

lemma less_eSuc_iff: "a < eSuc b \<longleftrightarrow> (a \<le> b \<and> a \<noteq> \<infinity>)"
  by (cases a) auto

lemma stopping_time_Inf_enat:
  fixes F :: "enat \<Rightarrow> 'a measure"
  assumes F: "filtration \<Omega> F"
  assumes P: "\<And>i. Measurable.pred (F i) (P i)"
  shows "stopping_time F (\<lambda>\<omega>. Inf {i. P i \<omega>})"
proof (rule stopping_timeI, cases)
  fix t :: enat assume "t = \<infinity>" then show "Measurable.pred (F t) (\<lambda>\<omega>. Inf {i. P i \<omega>} \<le> t)"
    by auto
next
  fix t :: enat assume "t \<noteq> \<infinity>"
  moreover
  { fix i \<omega> assume "Inf {i. P i \<omega>} \<le> t"
    with \<open>t \<noteq> \<infinity>\<close> have "(\<exists>i\<le>t. P i \<omega>)"
      unfolding Inf_le_iff by (cases t) (auto elim!: allE[of _ "eSuc t"] simp: less_eSuc_iff) }
  ultimately have *: "\<And>\<omega>. Inf {i. P i \<omega>} \<le> t \<longleftrightarrow> (\<exists>i\<in>{..t}. P i \<omega>)"
    by (auto intro!: Inf_lower2)
  show "Measurable.pred (F t) (\<lambda>\<omega>. Inf {i. P i \<omega>} \<le> t)"
    unfolding * using filtration.sets_F_mono[OF F, of _ t] P
    by (intro pred_intros_countable_bounded) (auto simp: pred_def filtration.space_F[OF F])
qed

lemma stopping_time_Inf_nat:
  fixes F :: "nat \<Rightarrow> 'a measure"
  assumes F: "filtration \<Omega> F"
  assumes P: "\<And>i. Measurable.pred (F i) (P i)" and wf: "\<And>i \<omega>. \<omega> \<in> \<Omega> \<Longrightarrow> \<exists>n. P n \<omega>"
  shows "stopping_time F (\<lambda>\<omega>. Inf {i. P i \<omega>})"
  unfolding stopping_time_def
proof (intro allI, subst measurable_cong)
  fix t \<omega> assume "\<omega> \<in> space (F t)"
  then have "\<omega> \<in> \<Omega>"
    using filtration.space_F[OF F] by auto
  from wf[OF this] have "((LEAST n. P n \<omega>) \<le> t) = (\<exists>i\<le>t. P i \<omega>)"
    by (rule LeastI2_wellorder_ex) auto
  then show "(Inf {i. P i \<omega>} \<le> t) = (\<exists>i\<in>{..t}. P i \<omega>)"
    by (simp add: Inf_nat_def Bex_def)
next
  fix t from P show "Measurable.pred (F t) (\<lambda>w. \<exists>i\<in>{..t}. P i w)"
    using filtration.sets_F_mono[OF F, of _ t]
    by (intro pred_intros_countable_bounded) (auto simp: pred_def filtration.space_F[OF F])
qed

end


theory EtaExpansionSafe
imports EtaExpansion Sestoft
begin

theorem eta_expansion_safe:
  assumes "set T \<subseteq> range Arg"
  shows "(\<Gamma>, eta_expand (length T) e, T@S) \<Rightarrow>\<^sup>* (\<Gamma>, e, T@S)"
using assms
proof(induction T arbitrary: e)
  case Nil show ?case by simp
next
  case (Cons se T)
  from Cons(2) obtain x where "se = Arg x" by auto

  from Cons have prem: "set T \<subseteq> range Arg" by simp

  have "(\<Gamma>, eta_expand (Suc (length T)) e, Arg x # T @ S) = (\<Gamma>, Lam [fresh_var e]. eta_expand (length T) (App e (fresh_var e)), Arg x # T @ S)" by simp
  also have "\<dots> \<Rightarrow> (\<Gamma>, (eta_expand (length T) (App e (fresh_var e)))[fresh_var e ::= x], T @ S)" by (rule app\<^sub>2)
  also have "\<dots> = (\<Gamma>, (eta_expand (length T) (App e x)), T @ S)" unfolding subst_eta_expand by simp
  also have "\<dots> \<Rightarrow>\<^sup>* (\<Gamma>, App e x, T @ S)" by (rule Cons.IH[OF prem])
  also have "\<dots> \<Rightarrow> (\<Gamma>, e, Arg x # T @ S)"  by (rule app\<^sub>1)
  finally show ?case using \<open>se = _\<close> by simp
qed

fun arg_prefix :: "stack \<Rightarrow> nat" where
  "arg_prefix [] = 0"
| "arg_prefix (Arg x # S) = Suc (arg_prefix S)"
| "arg_prefix (Alts e1 e2 # S) = 0"
| "arg_prefix (Upd x # S) = 0"
| "arg_prefix (Dummy x # S) = 0"

theorem eta_expansion_safe':
  assumes "n \<le> arg_prefix S"
  shows "(\<Gamma>, eta_expand n e, S) \<Rightarrow>\<^sup>* (\<Gamma>, e, S)"
proof-
  from assms
  have "set (take n S) \<subseteq> range Arg" and "length (take n S) = n"
    apply (induction S arbitrary: n rule: arg_prefix.induct)
    apply auto
    apply (case_tac n, auto)+
    done
  hence "S = take n S @ drop n S" by (metis append_take_drop_id)
  with eta_expansion_safe[OF \<open>_ \<subseteq> _\<close>] \<open>length _ = _\<close>
  show ?thesis by metis
qed

end


theory Chapter12_5
imports "HOL-IMP.Hoare_Total"
begin

text\<open>
\exercise
Prove total correctness of the commands in exercises~\ref{exe:Hoare:sumeq} to
\ref{exe:Hoare:sqrt}.
\<close>

text\<open>
\endexercise

\exercise
Modify the VCG to take termination into account. First modify type @{text acom}
by annotating  @{text WHILE} with a measure function in addition to an
invariant:
\<close>
datatype acom =
  Askip                  ("SKIP") |
  Aassign vname aexp     ("(_ ::= _)" [1000, 61] 61) |
  Aseq   acom acom       ("_;;/ _"  [60, 61] 60) |
  Aif bexp acom acom     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61) |
  Awhile assn "state \<Rightarrow> nat" bexp acom
    ("({_, _}/ WHILE _/ DO _)"  [0, 0, 61] 61)

notation com.SKIP ("SKIP")

fun strip :: "acom \<Rightarrow> com" where
"strip SKIP = SKIP" |
"strip (x ::= a) = (x ::= a)" |
"strip (C\<^sub>1;; C\<^sub>2) = (strip C\<^sub>1;; strip C\<^sub>2)" |
"strip (IF b THEN C\<^sub>1 ELSE C\<^sub>2) = (IF b THEN strip C\<^sub>1 ELSE strip C\<^sub>2)" |
"strip ({_,_} WHILE b DO C) = (WHILE b DO strip C)"

fun pre :: "acom \<Rightarrow> assn \<Rightarrow> assn" where
"pre SKIP Q = Q" |
"pre (x ::= a) Q = (\<lambda>s. Q(s(x := aval a s)))" |
"pre (C\<^sub>1;; C\<^sub>2) Q = pre C\<^sub>1 (pre C\<^sub>2 Q)" |
"pre (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q =
  (\<lambda>s. if bval b s then pre C\<^sub>1 Q s else pre C\<^sub>2 Q s)" |
"pre ({I,f} WHILE b DO C) Q = I"

fun vc :: "acom \<Rightarrow> assn \<Rightarrow> bool" where
"vc SKIP Q = True" |
"vc (x ::= a) Q = True" |
"vc (C\<^sub>1;; C\<^sub>2) Q = (vc C\<^sub>1 (pre C\<^sub>2 Q) \<and> vc C\<^sub>2 Q)" |
"vc (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q = (vc C\<^sub>1 Q \<and> vc C\<^sub>2 Q)" |
(* your definition/proof here *)

text\<open>
Functions @{const strip} and @{const pre} remain almost unchanged.
The only significant change is in the @{text WHILE} case for @{const vc}.
Modify the old soundness proof to obtain
\<close>

lemma vc_sound: "vc C Q \<Longrightarrow> \<turnstile>\<^sub>t {pre C Q} strip C {Q}"
(* your definition/proof here *)

text\<open>
You may need the combined soundness and completeness of @{text"\<turnstile>\<^sub>t"}:
@{thm hoaret_sc}
\endexercise
\<close>

end


theory Lazy_Sum_List
  imports "$AFP/Coinductive/Coinductive" Sum_Type
begin

section {* Lazy Sum Lists *}

notation sum_case ("\<langle>_,_\<rangle>" [0,0] 1000)

primrec is_left :: "('a + 'b) \<Rightarrow> bool" where
  "is_left (Inl x) = True"
| "is_left (Inr x) = False"

primrec is_right :: "('a + 'b) \<Rightarrow> bool" where
  "is_right (Inr x) = True"
| "is_right (Inl x) = False"

primrec unl :: "('a, 'b) sum \<Rightarrow> 'a" where
  "unl (Inl x) = x"
| "unl (Inr x) = undefined"

primrec unr :: "('a, 'b) sum \<Rightarrow> 'b" where
  "unr (Inr x) = x"
| "unr (Inl x) = undefined"

lemma not_is_left [simp]: "\<not> is_left x \<longleftrightarrow> is_right x"
  by (cases x) auto

lemma Not_is_left: "is_right = Not \<circ> is_left"
  by (simp add: o_def)

lemma not_is_right [simp]: "\<not> is_right x \<longleftrightarrow> is_left x"
  by (cases x) auto

lemma Not_is_right: "is_left = Not \<circ> is_right"
  by (simp add: o_def)

definition lefts :: "('a + 'b) llist \<Rightarrow> 'a llist" ("\<ll>") where
  "lefts = lmap unl \<circ> lfilter is_left"

definition rights :: "('a + 'b) llist \<Rightarrow> 'b llist" ("\<rr>") where
  "rights = lmap unr \<circ> lfilter is_right"

lemma [dest!]: "xs \<noteq> LNil \<Longrightarrow> \<exists>y ys. xs = LCons y ys"
  by (metis llist.exhaust)

lemma all_rights [simp]: "lfilter is_right (lmap Inr xs) = lmap Inr xs"
  by (coinduct xs rule: llist_fun_coinduct) auto

lemma all_lefts [simp]: "lfilter is_left (lmap Inl xs) = lmap Inl xs"
  by (coinduct xs rule: llist_fun_coinduct) auto

lemma lmap2_id: "(\<And>x. f (g x) = x) \<Longrightarrow> lmap f (lmap g xs) = xs"
  by (coinduct xs rule: llist_fun_coinduct) auto

lemma rights_mapr [simp]: "\<rr> (lmap Inr xs) = xs"
  by (auto simp add: rights_def, rule lmap2_id, simp)

lemma lefts_mapl [simp]: "\<ll> (lmap Inl xs) = xs"
  by (auto simp add: lefts_def, rule lmap2_id, simp)

lemma rights_LConsr [simp]: "\<rr> (LCons (Inr x) xs) = LCons x (\<rr> xs)"
  by (auto simp add: rights_def)

lemma rights_LConsl [simp]: "\<rr> (LCons (Inl x) xs) = \<rr> xs"
  by (auto simp add: rights_def)

lemma lefts_LConsl [simp]: "\<ll> (LCons (Inl x) xs) = LCons x (\<ll> xs)"
  by (auto simp add: lefts_def)

lemma lefts_LConsr [simp]: "\<ll> (LCons (Inr x) xs) = \<ll> xs"
  by (auto simp add: lefts_def)

lemma rights_LNil [simp]: "\<rr> LNil = LNil"
  by (auto simp add: rights_def)

lemma lefts_LNil [simp]: "\<ll> LNil = LNil"
  by (auto simp add: lefts_def)

fun swap :: "('a + 'b) \<Rightarrow> ('b, 'a) sum" where
  "swap (Inl x) = Inr x"
| "swap (Inr x) = Inl x"

definition fair :: "('a + 'b) llist \<Rightarrow> bool" where
  "fair l \<equiv> (\<exists>n. is_right (lnth l n)) \<and> (\<exists>n. is_left (lnth l n))
          \<and> (\<forall>n. is_right (lnth l n) \<longrightarrow> (\<exists>m>n. is_right (lnth l m)))
          \<and> (\<forall>n. is_left (lnth l n) \<longrightarrow> (\<exists>m>n. is_left (lnth l m)))
          \<and> (\<not> lfinite l)"

lemma fair_right_ex: "fair l \<Longrightarrow> \<exists>n. is_right (lnth l n)"
  by (simp add: fair_def)

lemma fair_left_ex: "fair l \<Longrightarrow> \<exists>n. is_left (lnth l n)"
  by (simp add: fair_def)

lemma fair_morer: "fair l \<Longrightarrow> is_right (lnth l n) \<Longrightarrow> \<exists>m>n. is_right (lnth l m)"
  by (simp add: fair_def)

lemma fair_morel: "fair l \<Longrightarrow> is_left (lnth l n) \<Longrightarrow> \<exists>m>n. is_left (lnth l m)"
  by (simp add: fair_def)

definition first_left :: "('a + 'b) llist \<Rightarrow> 'a" where
  "first_left = Sum_Type.Projl \<circ> lhd \<circ> ldropWhile is_right"

lemma lefts_append: "lfinite xs \<Longrightarrow> \<ll> (lappend xs ys) = lappend (\<ll> xs) (\<ll> ys)"
  apply (auto simp add: lefts_def)
  by (metis lmap_lappend_distrib)

lemma rights_append: "lfinite xs \<Longrightarrow> \<rr> (lappend xs ys) = lappend (\<rr> xs) (\<rr> ys)"
  apply (auto simp add: rights_def)
  by (metis lmap_lappend_distrib)

declare in_lset_conv_lnth[iff]
declare lfinite_conv_llength_enat[iff]

lemma lnth_in_lset: "\<not> lfinite xs \<Longrightarrow> lnth xs n \<in> lset xs"
  by auto

lemma fair_ltakel: "fair xs \<Longrightarrow> lfinite (ltakeWhile is_left xs)"
  apply (subst lfinite_ltakeWhile)
  apply (rule disjI2)
  apply (auto simp add: fair_def)
  apply (rule_tac x = "lnth xs n" in bexI)
  apply assumption
  by (metis llength_eq_infty_conv_lfinite lnth_in_lset)

lemma fair_ltaker: "fair xs \<Longrightarrow> lfinite (ltakeWhile is_right xs)"
  apply (subst lfinite_ltakeWhile)
  apply (rule disjI2)
  apply (auto simp add: fair_def)
  apply (rule_tac x = "lnth xs na" in bexI)
  apply assumption
  by (metis llength_eq_infty_conv_lfinite lnth_in_lset)

lemma lefts_Nil: "lfinite xs \<Longrightarrow> \<forall>x\<in>lset xs. is_right x \<Longrightarrow> \<ll> xs = LNil"
  by (auto simp add: lefts_def)

lemma lefts_ltaker: "fair xs \<Longrightarrow> \<ll> (ltakeWhile is_right xs) = LNil"
  apply (rule lefts_Nil)
  apply (erule fair_ltaker)
  by (metis lset_ltakeWhileD)

lemma lefts_ldropr:
  assumes xs_fair: "fair xs" shows "\<ll> xs = \<ll> (ldropWhile is_right xs)" (is "?lhs = ?rhs")
proof -
  have "?lhs = \<ll> (lappend (ltakeWhile is_right xs) (ldropWhile is_right xs))"
    by (metis lappend_ltakeWhile_ldropWhile)
  also have "... = lappend (\<ll> (ltakeWhile is_right xs)) (\<ll> (ldropWhile is_right xs))"
    by (metis fair_ltaker lefts_append xs_fair)
  also have "... = lappend LNil (\<ll> (ldropWhile is_right xs))"
    by (metis lefts_ltaker xs_fair)
  also have "... = ?rhs"
    by (metis lappend_code(1))
  finally show ?thesis .
qed

lemma fairI:
  assumes "\<exists>n. is_right (lnth l n)" and "\<exists>n. is_left (lnth l n)"
  and "\<And>n. is_right (lnth l n) \<Longrightarrow> \<exists>m>n. is_right (lnth l m)"
  and "\<And>n. is_left (lnth l n) \<Longrightarrow> \<exists>m>n. is_left (lnth l m)"
  and "\<not> lfinite l"
  shows "fair l"
  by (insert assms) (simp add: fair_def)

lemma fair_non_empty: "fair l \<Longrightarrow> \<not> lfinite l"
  by (auto simp add: fair_def)

lemma [simp]: "is_left (swap x) = is_right x"
  by (cases x) auto

lemma is_right_swap [simp]: "is_right \<circ> swap = is_left"
  by (rule ext) (simp  add: o_def)

lemma is_left_swap [simp]: "is_left \<circ> swap = is_right"
  by (rule ext) (simp  add: o_def)

lemma [simp]: "unr (swap x) = unl x"
  by (cases x) auto

lemma [simp]: "unl (swap x) = unr x"
  by (cases x) auto

lemma unr_swap [simp]: "unr \<circ> swap = unl"
  by (rule ext) (simp  add: o_def)

lemma unl_swap [simp]: "unl \<circ> swap = unr"
  by (rule ext) (simp  add: o_def)

lemma [simp]: "\<langle>id,id\<rangle> (swap x) = \<langle>id,id\<rangle> x"
  by (cases x) auto

declare lmap.compositionality[simp]

lemma [simp]: "\<rr> (lmap swap xs) = \<ll> xs"
  by (simp add: rights_def lfilter_lmap lefts_def)

lemma [simp]: "\<ll> (lmap swap xs) = \<rr> xs"
  by (simp add: rights_def lfilter_lmap lefts_def)

lemma [simp]: "lmap \<langle>id,id\<rangle> (lmap swap xs) = lmap \<langle>id,id\<rangle> xs"
  by (simp add: o_def)

fun rbr1 :: "'a + ('b + 'c) \<Rightarrow> ('a + 'b) + 'c" where
  "rbr1 (Inl x) = Inl (Inl x)"
| "rbr1 (Inr (Inl x)) = Inl (Inr x)"
| "rbr1 (Inr (Inr x)) = Inr x"

fun rbr2 :: "('a + 'b) + 'c \<Rightarrow> 'a + ('b + 'c)" where
  "rbr2 (Inr x) = Inr (Inr x)"
| "rbr2 (Inl (Inr x)) = Inr (Inl x)"
| "rbr2 (Inl (Inl x)) = Inl x"

lemma sum3_cases1: "(\<And>x. P (Inl x)) \<Longrightarrow> (\<And>x. P (Inr (Inl x))) \<Longrightarrow> (\<And>x. P (Inr (Inr x))) \<Longrightarrow> P x"
  by (metis sumE)

lemma sum3_cases2: "(\<And>x. P (Inr x)) \<Longrightarrow> (\<And>x. P (Inl (Inl x))) \<Longrightarrow> (\<And>x. P (Inl (Inr x))) \<Longrightarrow> P x"
  by (metis sumE)

lemma [simp]: "is_left (unl (rbr1 x)) \<and> is_left (rbr1 x) \<longleftrightarrow> is_left x"
  by (rule sum3_cases1) auto

lemma [simp]: "is_left x \<Longrightarrow> unl (unl (rbr1 x)) = unl x"
  by (cases x) auto

lemma [simp]: "is_right (unl (rbr1 x)) \<and> is_left (rbr1 x) \<longleftrightarrow> is_left (unr x) \<and> is_right x"
  by (rule sum3_cases1) auto

lemma [simp]: "is_left (unr x) \<and> is_right x \<Longrightarrow> unr (unl (rbr1 x)) = unl (unr x)"
  apply (cases x)
  apply auto
  by (metis is_right.simps(1) not_is_right rbr1.simps(2) sum.exhaust unl.simps(1) unr.simps(1))

lemma [simp]: "is_right (rbr1 x) \<longleftrightarrow> is_right (unr x) \<and> is_right x"
  by (rule sum3_cases1) auto

lemma [simp]: "is_right (unr x) \<and> is_right x \<Longrightarrow> unr (rbr1 x) = unr (unr x)"
  apply (cases x)
  apply auto
  by (metis is_left.simps(1) not_is_left rbr1.simps(3) swap.cases unr.simps(1))

lemma [simp]: "is_right (unr (rbr2 x)) \<and> is_right (rbr2 x) \<longleftrightarrow> is_right x"
  by (rule sum3_cases2) auto

lemma [simp]: "is_right x \<Longrightarrow> unr (unr (rbr2 x)) = unr x"
  by (cases x) auto

lemma [simp]: "is_left (unr (rbr2 x)) \<and> is_right (rbr2 x) \<longleftrightarrow> is_right (unl x) \<and> is_left x"
  by (rule sum3_cases2) auto

lemma [simp]: "is_right (unl x) \<and> is_left x \<Longrightarrow> unl (unr (rbr2 x)) = unr (unl x)"
  apply (cases x)
  apply auto
  by (metis is_left.simps(1) not_is_right rbr2.simps(2) sum.exhaust unl.simps(1) unr.simps(1))

lemma [simp]: "is_left (rbr2 x) \<longleftrightarrow> is_left (unl x) \<and> is_left x"
  by (rule sum3_cases2) auto

lemma [simp]: "is_left (unl x) \<and> is_left x \<Longrightarrow> unl (rbr2 x) = unl (unl x)"
  apply (cases x)
  apply auto
  by (metis is_left.simps(2) rbr2.simps(3) sum.exhaust unl.simps(1))

lemma lmap_lfilter_eq [intro]: "(\<And>x. P x \<Longrightarrow> f x = g x) \<Longrightarrow> lmap f (lfilter P xs) = lmap g (lfilter P xs)"
  by (rule llist.map_cong0) simp

lemma lmap_lfilter_left_eq: "(\<And>x. f (Inl x) = g (Inl x)) \<Longrightarrow> lmap f (lfilter is_left xs) = lmap g (lfilter is_left xs)"
  by (rule lmap_lfilter_eq) (metis (full_types) is_left.simps(2) swap.cases)

lemma lmap_lfilter_right_eq: "(\<And>x. f (Inr x) = g (Inr x)) \<Longrightarrow> lmap f (lfilter is_right xs) = lmap g (lfilter is_right xs)"
  by (rule lmap_lfilter_eq) (metis (full_types) is_right.simps(2) swap.cases)

lemma [simp]: "\<ll> (\<ll> (lmap rbr1 xs)) = \<ll> xs"
  by (auto simp add: lefts_def lfilter_lmap  lfilter_lfilter o_def)

lemma [simp]: "\<rr> (\<ll> (lmap rbr1 xs)) = \<ll> (\<rr> xs)"
  by (auto simp add: rights_def lefts_def lfilter_lmap lfilter_lfilter o_def)

lemma [simp]: "\<rr> (lmap rbr1 xs) = \<rr> (\<rr> xs)"
  by (auto simp add: rights_def lfilter_lmap  lfilter_lfilter o_def)

lemma [simp]: "\<rr> (\<rr> (lmap rbr2 xs)) = \<rr> xs"
  by (auto simp add: rights_def lfilter_lmap  lfilter_lfilter o_def)

lemma [simp]: "\<ll> (\<rr> (lmap rbr2 xs)) = \<rr> (\<ll> xs)"
  by (auto simp add: rights_def lefts_def lfilter_lmap lfilter_lfilter o_def)

lemma [simp]: "\<ll> (lmap rbr2 xs) = \<ll> (\<ll> xs)"
  by (auto simp add: lefts_def lfilter_lmap lfilter_lfilter o_def)

lemma [simp]: "\<langle>id,\<langle>id,id\<rangle>\<rangle> (rbr2 x) = \<langle>\<langle>id,id\<rangle>,id\<rangle> x"
  by (rule sum3_cases2) auto

lemma [simp]: "\<langle>\<langle>id,id\<rangle>,id\<rangle> (rbr1 x) = \<langle>id,\<langle>id,id\<rangle>\<rangle> x"
  by (rule sum3_cases1) auto

lemma lfilter_ltakeWhile [simp]: "lfilter P (ltakeWhile (Not \<circ> P) xs) = LNil"
  by auto (metis (full_types) in_lset_conv_lnth lset_ltakeWhileD)

lemma lset_ex_lnth: "(\<exists>x\<in>lset xs. P x) \<Longrightarrow> \<exists>n. P (lnth xs n)"
  by auto

lemma infinite_lfilter: "\<not> lfinite (lfilter P xs) \<Longrightarrow> \<exists>n. P (lnth xs n)"
proof -
  assume "\<not> lfinite (lfilter P xs)"
  hence assm1: "\<not> lfinite (lfilter P (lappend (ltakeWhile (Not \<circ> P) xs) (ldropWhile (Not \<circ> P) xs)))"
    by (metis lappend_ltakeWhile_ldropWhile)
  {
    assume assm2: "lfinite (ltakeWhile (Not \<circ> P) xs)"
    then obtain n where n_def: "llength (ltakeWhile (Not \<circ> P) xs) = enat n"
      by (metis lfinite_conv_llength_enat)
    from assm1 and assm2
    have "\<not> lfinite (lappend (lfilter P (ltakeWhile (Not \<circ> P) xs)) (lfilter P (ldropWhile (Not \<circ> P) xs)))"
      by (metis lfilter_lappend_lfinite)
    hence "\<not> lfinite (lfilter P (ldropWhile (Not \<circ> P) xs))"
      by (simp only: lfilter_ltakeWhile, simp)
    hence "P (lhd (ldropWhile (Not \<circ> P) xs))"
      by (metis (lifting, no_types) `\<not> lfinite (lfilter P xs)` lappend_code(1) lappend_ltakeWhile_ldropWhile ldropWhile_eq_LNil_iff lfilter_LNil lfinite_LNil lfinite_ltl lhd_lfilter ltakeWhile_eq_LNil_iff ltl_ldropWhile_lfilter ltl_simps(1))
    hence "\<exists>x\<in>lset xs. P x"
      apply (rule_tac x = "lhd (ldropWhile (Not \<circ> P) xs)" in bexI)
      apply simp
      by (metis `\<not> lfinite (lfilter P (ldropWhile (Not \<circ> P) xs))` in_lset_ldropWhileD lfinite.simps lfinite_lfilterI lhd_in_lset lhd_lfilter)
    hence "\<exists>n. P (lnth xs n)"
      by (rule lset_ex_lnth)
  }
  moreover
  {
    assume assm2: "\<not> lfinite (ltakeWhile (Not \<circ> P) xs)"
    from assm1 and assm2
    have "\<not> lfinite (lfilter P (ltakeWhile (Not \<circ> P) xs))"
      by (metis lappend_inf)
    hence "\<not> lfinite LNil"
      by (simp only: lfilter_ltakeWhile, simp)
    from this and lfinite_LNil have "False" by blast
  }
  ultimately show "\<exists>n. P (lnth xs n)"
    by metis
qed

declare in_lset_conv_lnth[iff del]
declare lfinite_conv_llength_enat[iff del]

definition "llist_Case \<equiv> llist_case"

primrec ldeleteLeft_nat :: "nat \<Rightarrow> ('a + 'b) llist \<Rightarrow> ('a + 'b) llist" where
  "ldeleteLeft_nat 0 xs = lappend (ltakeWhile is_right xs) (ltl (ldropWhile is_right xs))"
| "ldeleteLeft_nat (Suc n) xs = lappend (ltakeWhile is_right xs) (llist_Case LNil (\<lambda>x' xs'. LCons x' (ldeleteLeft_nat n xs')) (ldropWhile is_right xs))"

primrec ldeleteLeft :: "enat \<Rightarrow> ('a + 'b) llist \<Rightarrow> ('a + 'b) llist" where
  "ldeleteLeft (enat n) xs = ldeleteLeft_nat n xs"
| "ldeleteLeft \<infinity> xs = xs"

primrec linsertLeft_nat :: "nat \<Rightarrow> 'a \<Rightarrow> ('a + 'b) llist \<Rightarrow> ('a + 'b) llist" where
  "linsertLeft_nat 0 x xs = lappend (ltakeWhile is_right xs) (LCons (Inl x) (ldropWhile is_right xs))"
| "linsertLeft_nat (Suc n) x xs = lappend (ltakeWhile is_right xs) (llist_Case LNil (\<lambda>x' xs'. LCons x' (linsertLeft_nat n x xs')) (ldropWhile is_right xs))"

primrec linsertLeft :: "enat \<Rightarrow> 'a \<Rightarrow> ('a + 'b) llist \<Rightarrow> ('a + 'b) llist" where
  "linsertLeft (enat n) x xs = linsertLeft_nat n x xs"
| "linsertLeft \<infinity> x xs = xs"

lemma [simp]: "(case xs of LNil \<Rightarrow> LNil | LCons x' xs' \<Rightarrow> LCons x' xs') = xs"
  by (cases xs) auto

lemma linsertLeft_eSuc: "linsertLeft (eSuc n) x xs = lappend (ltakeWhile is_right xs) (llist_Case LNil (\<lambda>x' xs'. LCons x' (linsertLeft n x xs')) (ldropWhile is_right xs))"
  by (cases n) (simp_all add: eSuc_enat llist_Case_def)

primrec linsert_nat :: "nat \<Rightarrow> 'a \<Rightarrow> 'a llist \<Rightarrow> 'a llist" where
  "linsert_nat 0 x xs = LCons x xs"
| "linsert_nat (Suc n) x xs = llist_Case LNil (\<lambda>x' xs'. LCons x' (linsert_nat n x xs')) xs"

primrec linsert :: "enat \<Rightarrow> 'a \<Rightarrow> 'a llist \<Rightarrow> 'a llist" where
  "linsert (enat n) x xs = linsert_nat n x xs"
| "linsert \<infinity> x xs = xs"

lemma [simp]: "llength xs = \<infinity> \<Longrightarrow> lappend xs ys = xs"
  by (metis lappend_inf llength_eq_infty_conv_lfinite)

notation ltake ("\<up>")
  and ldrop ("\<down>")

lemma [simp]: "\<up> (llength xs) xs = xs"
  by (metis ltake_all order_refl)

lemma lefts_ltake_right [simp]: "\<ll> (ltakeWhile is_right xs) = LNil"
  by (auto dest: lset_ltakeWhileD simp add: lefts_def)

lemma [simp]: "lmap f xs \<noteq> LNil \<longleftrightarrow> xs \<noteq> LNil"
  by (metis LNil_eq_llist_map)

end


theory Gvf_Solver imports Gvf_Logic "HOL-Eisbach.Eisbach" begin

method sc_decompose_L_h = (rule L_Neg | rule L_And | rule L_Or | rule L_Imp)
method sc_decompose_R_h = (rule R_Neg | rule R_Imp | rule R_Or | rule R_And)

fun can_decompose :: \<open>'a \<Phi>\<^sub>P \<Rightarrow> bool\<close> where
  \<open>can_decompose (\<^bold>\<not> _) = True\<close> |
  \<open>can_decompose (_ \<^bold>\<longrightarrow> _) = True\<close> |
  \<open>can_decompose (_ \<^bold>\<and> _) = True\<close> |
  \<open>can_decompose (_ \<^bold>\<or> _) = True\<close> |
  \<open>can_decompose _ = False\<close>

lemma L_Shift_meaningful: \<open>\<exists>p \<in> set \<Gamma>. can_decompose p \<Longrightarrow> gen_sc R (rotate1 \<Gamma>) \<Delta> \<Longrightarrow> gen_sc R \<Gamma> \<Delta>\<close>
  using L_Shift .

lemma R_Shift_meaningful: \<open>\<exists>p \<in> set \<Delta>. can_decompose p \<Longrightarrow> gen_sc R \<Gamma> (rotate1 \<Delta>) \<Longrightarrow> gen_sc R \<Gamma> \<Delta>\<close>
  using R_Shift .

method sc_shift_L = rule L_Shift_meaningful; simp_all; (match conclusion in \<open>gen_sc _ _ _\<close> \<Rightarrow> succeed)
method sc_shift_R = rule R_Shift_meaningful; simp_all; (match conclusion in \<open>gen_sc _ _ _\<close> \<Rightarrow> succeed)
method sc_decompose_h = (sc_decompose_L_h | sc_decompose_R_h)+
method try_shift = sc_shift_L | sc_shift_R

method try_axiom = (match conclusion in \<open>gen_sc R \<Gamma> (p # \<Delta>)\<close> for R \<Gamma> \<Delta> p \<Rightarrow> \<open>rule Axiom[where R=R and \<Gamma>=\<Gamma> and \<Delta>=\<open>(p # \<Delta>)\<close> and p=p]; simp_all; match conclusion in False \<Rightarrow> fail\<close>)
method try_axiom_all = (try_axiom | (match conclusion in \<open>gen_sc R \<Gamma> (p # \<Delta>)\<close> for R \<Gamma> \<Delta> p \<Rightarrow> \<open>rule weakening_h(2)[where R=R and \<Gamma>=\<Gamma> and p=p and \<Delta>=\<Delta>]; try_axiom_all\<close>))+

method sc_decompose = (sc_decompose_h?, ((try_shift, sc_decompose_h?)+)?)

method sc_solver = (sc_decompose, try_axiom_all+)+

\<comment> \<open>Simple example\<close>
lemma \<open>\<turnstile>\<^sub>P (P \<^bold>\<longrightarrow> Q) \<^bold>\<longrightarrow> P \<^bold>\<longrightarrow> Q\<close> by sc_solver

(*  Does not work for all rules, in particular generic ones, weakening and cut *)

end


theory Incredible_Deduction
imports
  Main
  "~~/src/HOL/Library/FSet"
  "~~/src/HOL/Library/Stream"
  "~~/src/HOL/Eisbach/Eisbach"
  Incredible_Signatures
begin

text \<open>This theory contains the definition for actual proof graphs, and their various possible
properties.\<close>

text \<open>The following locale first defines graphs, without edges.\<close>

locale Vertex_Graph =
  Port_Graph_Signature nodes inPorts outPorts
    for nodes :: "'node stream"
    and inPorts :: "'node \<Rightarrow> 'inPort fset"
    and outPorts :: "'node \<Rightarrow> 'outPort fset" +
  fixes vertices :: "'v fset"
  fixes nodeOf :: "'v \<Rightarrow> 'node"
begin
  fun valid_out_port where "valid_out_port (v,p) \<longleftrightarrow> v |\<in>| vertices \<and> p |\<in>| outPorts (nodeOf v)"
  fun valid_in_port  where "valid_in_port (v,p) \<longleftrightarrow> v |\<in>| vertices \<and> p |\<in>| inPorts (nodeOf v)"

  fun terminal_node where
    "terminal_node n \<longleftrightarrow> outPorts n = {||}"
  fun terminal_vertex where
    "terminal_vertex v \<longleftrightarrow> v |\<in>| vertices \<and> terminal_node (nodeOf v)"
end

text \<open>And now we add the edges. This allows us to define paths and scopes.\<close>

type_synonym ('v, 'outPort, 'inPort) edge = "(('v \<times> 'outPort) \<times> ('v \<times> 'inPort))"

locale Pre_Port_Graph =
  Vertex_Graph nodes inPorts outPorts vertices nodeOf
    for nodes :: "'node stream"
    and inPorts :: "'node \<Rightarrow> 'inPort fset"
    and outPorts :: "'node \<Rightarrow> 'outPort fset"
    and vertices :: "'v fset"
    and nodeOf :: "'v \<Rightarrow> 'node" +
  fixes edges :: "('v, 'outPort, 'inPort) edge set"
begin
  fun edge_begin :: "(('v \<times> 'outPort) \<times> ('v \<times> 'inPort)) \<Rightarrow> 'v" where
    "edge_begin ((v1,p1),(v2,p2)) = v1"
  fun edge_end :: "(('v \<times> 'outPort) \<times> ('v \<times> 'inPort)) \<Rightarrow> 'v" where
    "edge_end ((v1,p1),(v2,p2)) = v2"

  lemma edge_begin_tup: "edge_begin x = fst (fst x)" by (metis edge_begin.simps prod.collapse)
  lemma edge_end_tup: "edge_end x = fst (snd x)" by (metis edge_end.simps prod.collapse)

  inductive path :: "'v \<Rightarrow> 'v \<Rightarrow> ('v, 'outPort, 'inPort) edge list \<Rightarrow> bool"   where
    path_empty: "path v v []" |
    path_cons: "e \<in> edges \<Longrightarrow> path (edge_end e) v' pth \<Longrightarrow> path (edge_begin e) v' (e#pth)"

  inductive_simps path_cons_simp': "path v v' (e#pth)"
  inductive_simps path_empty_simp[simp]: "path v v' []"
  lemma path_cons_simp: "path v v' (e # pth) \<longleftrightarrow> fst (fst e) = v \<and> e \<in> edges \<and> path (fst (snd e)) v' pth"
    by(auto simp add: path_cons_simp', metis prod.collapse)

  lemma path_appendI: "path v v' pth1 \<Longrightarrow> path v' v'' pth2 \<Longrightarrow> path v v'' (pth1@pth2)"
    by (induction pth1 arbitrary: v) (auto simp add: path_cons_simp )

  lemma path_split: "path v v' (pth1@[e]@pth2) \<longleftrightarrow> path v (edge_end e) (pth1@[e]) \<and> path (edge_end e) v' pth2"
    by (induction pth1 arbitrary: v) (auto simp add: path_cons_simp edge_end_tup intro: path_empty)

  lemma path_split2: "path v v' (pth1@(e#pth2)) \<longleftrightarrow> path v (edge_begin e) pth1 \<and> path (edge_begin e) v' (e#pth2)"
    by (induction pth1 arbitrary: v) (auto simp add: path_cons_simp edge_begin_tup intro: path_empty)

  lemma path_snoc: "path v v' (pth1@[e]) \<longleftrightarrow> e \<in> edges \<and> path v (edge_begin e) pth1 \<and> edge_end e = v'"
    by (auto simp add: path_split2 path_cons_simp edge_end_tup edge_begin_tup)

  inductive_set scope :: "'v \<times> 'inPort \<Rightarrow> 'v set" for ps where
    "v |\<in>| vertices \<Longrightarrow> (\<And> pth v'.  path v v' pth \<Longrightarrow> terminal_vertex v' \<Longrightarrow> ps \<in> snd ` set pth)
    \<Longrightarrow> v \<in> scope ps"

  lemma scope_find:
    assumes "v \<in> scope ps"
    assumes "terminal_vertex v'"
    assumes "path v v' pth"
    shows "ps \<in> snd ` set pth"
  using assms by (auto simp add: scope.simps)

  lemma snd_set_split:
    assumes "ps \<in> snd ` set pth"
    obtains pth1 pth2 e  where "pth = pth1@[e]@pth2" and "snd e = ps" and "ps \<notin> snd ` set pth1"
    using assms
    proof (atomize_elim, induction pth)
      case Nil thus ?case by simp
    next
      case (Cons e pth)
      show ?case
      proof(cases "snd e = ps")
        case True
        hence "e # pth = [] @ [e] @ pth \<and> snd e = ps \<and> ps \<notin> snd ` set []" by auto
        thus ?thesis by (intro exI)
      next
        case False
        with Cons(2)
        have "ps \<in> snd ` set pth" by auto
        from Cons.IH[OF this this]
        obtain pth1 e' pth2 where "pth = pth1 @ [e'] @ pth2 \<and> snd e' = ps \<and> ps \<notin> snd ` set pth1" by auto
        with False
        have "e#pth = (e# pth1) @ [e'] @ pth2 \<and> snd e' = ps \<and> ps \<notin> snd ` set (e#pth1)" by auto
        thus ?thesis by blast
      qed
    qed

  lemma scope_split:
    assumes "v \<in> scope ps"
    assumes "path v v' pth"
    assumes "terminal_vertex v'"
    obtains pth1 e pth2
    where "pth = (pth1@[e])@pth2" and "path v (fst ps) (pth1@[e])" and "path (fst ps) v' pth2" and "snd e = ps" and "ps \<notin> snd ` set pth1"
  proof-
    from assms
    have "ps \<in> snd ` set pth" by (auto simp add: scope.simps)
    then obtain pth1 pth2 e  where "pth = pth1@[e]@pth2" and "snd e = ps" and "ps \<notin> snd ` set pth1" by (rule snd_set_split)

    from `path _ _ _` and `pth = pth1@[e]@pth2`
    have "path v (edge_end e) (pth1@[e])" and "path (edge_end e) v' pth2" by (metis path_split)+
    show thesis
    proof(rule that)
      show "pth = (pth1@[e])@pth2" using `pth= _` by simp
      show "path v (fst ps) (pth1@[e])" using `path v (edge_end e) (pth1@[e])`  `snd e = ps` by (simp add: edge_end_tup)
      show "path (fst ps) v' pth2" using `path (edge_end e) v' pth2`  `snd e = ps` by (simp add: edge_end_tup)
      show "ps \<notin> snd ` set pth1" by fact
      show "snd e = ps" by fact
    qed
  qed
end

text \<open>This adds well-formedness conditions to the edges and vertices.\<close>

locale Port_Graph = Pre_Port_Graph +
  assumes valid_nodes: "nodeOf ` fset vertices  \<subseteq> sset nodes"
  assumes valid_edges: "\<forall> (ps1,ps2) \<in> edges. valid_out_port ps1 \<and> valid_in_port ps2"
begin
  lemma snd_set_path_verties: "path v v' pth \<Longrightarrow> fst ` snd ` set pth \<subseteq> fset vertices"
    apply (induction rule: path.induct)
    apply auto
    apply (metis valid_in_port.elims(2) edge_end.simps notin_fset case_prodD valid_edges)
    done

  lemma fst_set_path_verties: "path v v' pth \<Longrightarrow> fst ` fst ` set pth \<subseteq> fset vertices"
    apply (induction rule: path.induct)
    apply auto
    apply (metis valid_out_port.elims(2) edge_begin.simps notin_fset case_prodD valid_edges)
    done
end

text \<open>A pruned graph is one where every node has a path to a terminal node (which will be the conclusions).\<close>

locale Pruned_Port_Graph = Port_Graph +
  assumes pruned: "\<And>v.  v |\<in>| vertices \<Longrightarrow> (\<exists>pth v'. path v v' pth \<and> terminal_vertex v')"
begin
  lemma scopes_not_refl:
    assumes "v |\<in>| vertices"
    shows "v \<notin> scope (v,p)"
  proof(rule notI)
    assume "v \<in> scope (v,p)"

    from pruned[OF assms]
    obtain pth t where "terminal_vertex t" and "path v t pth" and least: "\<forall> pth'. path v t pth' \<longrightarrow> length pth \<le> length pth'"
      by atomize_elim (auto simp del: terminal_vertex.simps elim: ex_has_least_nat)

    from scope_split[OF `v \<in> scope (v,p)` `path v t pth` `terminal_vertex t`]
    obtain pth1 e pth2 where "pth = (pth1 @ [e]) @ pth2" "path v t pth2" by (metis fst_conv)

    from this(2) least
    have "length pth \<le> length pth2" by auto
    with `pth = _`
    show False by auto
  qed

  text \<open>This lemma can be found in \cite{incredible}, but it is otherwise inconsequential.\<close>
  lemma scopes_nest:
    fixes ps1 ps2
    shows "scope ps1 \<subseteq> scope ps2 \<or> scope ps2 \<subseteq> scope ps1 \<or> scope ps1 \<inter> scope ps2 = {}"
  proof(cases "ps1 = ps2")
    assume "ps1 \<noteq> ps2"
    {
    fix v
    assume "v \<in> scope ps1 \<inter> scope ps2"
    hence "v |\<in>| vertices" using scope.simps by auto
    then obtain pth t where "path v t pth" and "terminal_vertex t" using pruned by blast

    from `path v t pth` and `terminal_vertex t` and `v \<in> scope ps1 \<inter> scope ps2`
    obtain pth1a e1 pth1b  where "pth = (pth1a@[e1])@pth1b" and "path v (fst ps1) (pth1a@[e1])" and "snd e1 = ps1" and "ps1 \<notin> snd ` set pth1a"
      by (auto elim: scope_split)

    from `path v t pth` and `terminal_vertex t` and `v \<in> scope ps1 \<inter> scope ps2`
    obtain pth2a e2 pth2b  where "pth = (pth2a@[e2])@pth2b" and "path v (fst ps2) (pth2a@[e2])" and "snd e2 = ps2" and "ps2 \<notin> snd ` set pth2a"
      by (auto elim: scope_split)

    from `pth = (pth1a@[e1])@pth1b` `pth = (pth2a@[e2])@pth2b`
    have "set pth1a \<subseteq> set pth2a \<or> set pth2a \<subseteq> set pth1a" by (auto simp add: append_eq_append_conv2)
    hence "scope ps1 \<subseteq> scope ps2 \<or> scope ps2 \<subseteq> scope ps1"
    proof
      assume "set pth1a \<subseteq> set pth2a" with `ps2 \<notin> _`
      have "ps2 \<notin> snd ` set (pth1a@[e1])" using `ps1 \<noteq> ps2` `snd e1 = ps1` by auto

      have "scope ps1 \<subseteq> scope ps2"
      proof
        fix v'
        assume "v' \<in> scope ps1"
        hence "v' |\<in>| vertices" using scope.simps by auto
        thus "v' \<in> scope ps2"
        proof(rule scope.intros)
          fix pth' t'
          assume "path v' t' pth'" and "terminal_vertex t'"
          with `v' \<in> scope ps1`
          obtain pth3a e3 pth3b where "pth' = (pth3a@[e3])@pth3b" and "path (fst ps1) t' pth3b"
            by (auto elim: scope_split)

          have "path v t' ((pth1a@[e1]) @ pth3b)" using `path v (fst ps1) (pth1a@[e1])` and `path (fst ps1) t' pth3b`
            by (rule path_appendI)
          with `terminal_vertex t'` `v \<in> _`
          have "ps2 \<in> snd ` set ((pth1a@[e1]) @ pth3b)" by (meson IntD2 scope.cases)
          hence "ps2 \<in> snd ` set pth3b" using `ps2 \<notin> snd \` set (pth1a@[e1])` by auto
          thus "ps2 \<in> snd ` set pth'" using `pth'=_` by auto
        qed
      qed
      thus ?thesis by simp
    next
      assume "set pth2a \<subseteq> set pth1a" with `ps1 \<notin> _`
      have "ps1 \<notin> snd ` set (pth2a@[e2])" using `ps1 \<noteq> ps2` `snd e2 = ps2` by auto

      have "scope ps2 \<subseteq> scope ps1"
      proof
        fix v'
        assume "v' \<in> scope ps2"
        hence "v' |\<in>| vertices" using scope.simps by auto
        thus "v' \<in> scope ps1"
        proof(rule scope.intros)
          fix pth' t'
          assume "path v' t' pth'" and "terminal_vertex t'"
          with `v' \<in> scope ps2`
          obtain pth3a e3 pth3b where "pth' = (pth3a@[e3])@pth3b" and "path (fst ps2) t' pth3b"
            by (auto elim: scope_split)

          have "path v t' ((pth2a@[e2]) @ pth3b)" using `path v (fst ps2) (pth2a@[e2])` and `path (fst ps2) t' pth3b`
            by (rule path_appendI)
          with `terminal_vertex t'` `v \<in> _`
          have "ps1 \<in> snd ` set ((pth2a@[e2]) @ pth3b)" by (meson IntD1 scope.cases)
          hence "ps1 \<in> snd ` set pth3b" using `ps1 \<notin> snd \` set (pth2a@[e2])` by auto
          thus "ps1 \<in> snd ` set pth'" using `pth'=_` by auto
        qed
      qed
      thus ?thesis by simp
    qed
    }
    thus ?thesis by blast
  qed simp
end

text \<open>A well-scoped graph is one where a port marked to be a local hypothesis is only connected to
the corresponding input port, either directly or via a path. It must not be, however, that there is
a a path from such a hypothesis to a terminal node that does not pass by the dedicated input port;
this is expressed via scopes.
\<close>

locale Scoped_Graph = Port_Graph + Port_Graph_Signature_Scoped
locale Well_Scoped_Graph = Scoped_Graph +
  assumes well_scoped: "((v\<^sub>1,p\<^sub>1),(v\<^sub>2,p\<^sub>2)) \<in> edges \<Longrightarrow> hyps (nodeOf v\<^sub>1) p\<^sub>1 = Some p' \<Longrightarrow> (v\<^sub>2,p\<^sub>2) = (v\<^sub>1,p') \<or> v\<^sub>2 \<in> scope (v\<^sub>1,p')"

context Scoped_Graph
begin

definition hyps_free where
  "hyps_free pth = (\<forall> v\<^sub>1 p\<^sub>1 v\<^sub>2 p\<^sub>2. ((v\<^sub>1,p\<^sub>1),(v\<^sub>2,p\<^sub>2)) \<in> set pth \<longrightarrow> hyps (nodeOf v\<^sub>1) p\<^sub>1 = None)"

lemma hyps_free_Nil[simp]: "hyps_free []" by (simp add: hyps_free_def)

lemma hyps_free_Cons[simp]: "hyps_free (e#pth) \<longleftrightarrow> hyps_free pth \<and> hyps (nodeOf (fst (fst e))) (snd (fst e)) = None"
  by (auto simp add: hyps_free_def) (metis prod.collapse)

lemma path_vertices_shift:
  assumes "path v v' pth"
  shows "map fst (map fst pth)@[v'] = v#map fst (map snd pth)"
using assms by induction auto

inductive terminal_path where
    terminal_path_empty: "terminal_vertex v \<Longrightarrow> terminal_path v v []" |
    terminal_path_cons: "((v\<^sub>1,p\<^sub>1),(v\<^sub>2,p\<^sub>2)) \<in> edges \<Longrightarrow> terminal_path v\<^sub>2 v' pth \<Longrightarrow> hyps (nodeOf v\<^sub>1) p\<^sub>1 = None \<Longrightarrow> terminal_path v\<^sub>1 v' (((v\<^sub>1,p\<^sub>1),(v\<^sub>2,p\<^sub>2))#pth)"

lemma terminal_path_is_path:
  assumes "terminal_path v v' pth"
  shows "path v v' pth"
using assms by induction (auto simp add: path_cons_simp)

lemma terminal_path_is_hyps_free:
  assumes "terminal_path v v' pth"
  shows "hyps_free pth"
using assms by induction (auto simp add: hyps_free_def)

lemma terminal_path_end_is_terminal:
  assumes "terminal_path v v' pth"
  shows "terminal_vertex v'"
using assms by induction

lemma terminal_pathI:
  assumes "path v v' pth"
  assumes "hyps_free pth"
  assumes "terminal_vertex v'"
  shows "terminal_path v v' pth"
using assms
by induction (auto intro: terminal_path.intros)
end

text \<open>An acyclic graph is one where there are no non-trivial cyclic paths (disregarding
edges that are local hypotheses -- these are naturally and benignly cyclic).\<close>

locale Acyclic_Graph = Scoped_Graph +
  assumes hyps_free_acyclic: "path v v pth \<Longrightarrow> hyps_free pth \<Longrightarrow> pth = []"
begin
lemma hyps_free_vertices_distinct:
  assumes "terminal_path v v' pth"
  shows "distinct (map fst (map fst pth)@[v'])"
using assms
proof(induction v v' pth)
  case terminal_path_empty
  show ?case by simp
next
  case (terminal_path_cons v\<^sub>1 p\<^sub>1 v\<^sub>2 p\<^sub>2 v' pth)
  note terminal_path_cons.IH
  moreover
  have "v\<^sub>1 \<notin> fst ` fst ` set pth"
  proof
    assume "v\<^sub>1 \<in> fst ` fst ` set pth"
    then obtain pth1 e' pth2 where "pth = pth1@[e']@pth2" and "v\<^sub>1 = fst (fst e')"
      apply (atomize_elim)
      apply (induction pth)
      apply (solves simp)
      apply (auto)
      apply (solves \<open>rule exI[where x = "[]"]; simp\<close>)
      apply (metis Cons_eq_appendI image_eqI prod.sel(1))
      done
    with terminal_path_is_path[OF `terminal_path v\<^sub>2 v' pth`]
    have "path v\<^sub>2 v\<^sub>1 pth1" by (simp add:  path_split2 edge_begin_tup)
    with `((v\<^sub>1, p\<^sub>1), (v\<^sub>2, p\<^sub>2)) \<in> _`
    have "path v\<^sub>1 v\<^sub>1 (((v\<^sub>1, p\<^sub>1), (v\<^sub>2, p\<^sub>2)) # pth1)" by (simp add: path_cons_simp)
    moreover
    from terminal_path_is_hyps_free[OF `terminal_path v\<^sub>2 v' pth`]
         `hyps (nodeOf v\<^sub>1) p\<^sub>1 = None`
         `pth = pth1@[e']@pth2`
    have "hyps_free(((v\<^sub>1, p\<^sub>1), (v\<^sub>2, p\<^sub>2)) # pth1)"
      by (auto simp add: hyps_free_def)
    ultimately
    show False  using hyps_free_acyclic by blast
  qed
  moreover
  have "v\<^sub>1 \<noteq> v'"
    using hyps_free_acyclic path_cons terminal_path_cons.hyps(1) terminal_path_cons.hyps(2) terminal_path_cons.hyps(3) terminal_path_is_hyps_free terminal_path_is_path by fastforce
  ultimately
  show ?case by (auto simp add: comp_def)
qed

lemma hyps_free_vertices_distinct':
  assumes "terminal_path v v' pth"
  shows "distinct (v # map fst (map snd pth))"
  using hyps_free_vertices_distinct[OF assms]
  unfolding path_vertices_shift[OF terminal_path_is_path[OF assms]]
  .

lemma hyps_free_limited:
  assumes "terminal_path v v' pth"
  shows "length pth \<le> fcard vertices"
proof-
  have "length pth = length (map fst (map fst pth))" by simp
  also
  from hyps_free_vertices_distinct[OF assms]
  have "distinct (map fst (map fst pth))" by simp
  hence "length (map fst (map fst pth)) = card (set (map fst (map fst pth)))"
    by (rule distinct_card[symmetric])
  also have "\<dots> \<le> card (fset vertices)"
  proof (rule card_mono[OF finite_fset])
    from assms(1)
    show "set (map fst (map fst pth)) \<subseteq> fset vertices"
      by (induction v v' pth) (auto, metis valid_edges notin_fset case_prodD valid_out_port.simps)
  qed
  also have "\<dots> = fcard vertices" by (simp add: fcard.rep_eq)
  finally show ?thesis.
qed

lemma hyps_free_path_not_in_scope:
  assumes "terminal_path v t pth"
  assumes "(v',p') \<in> snd ` set pth"
  shows   "v' \<notin> scope (v, p)"
proof
  assume "v' \<in> scope (v,p)"

  from `(v',p') \<in> snd \` set pth`
  obtain pth1 pth2 e  where "pth = pth1@[e]@pth2" and "snd e = (v',p')" by (rule snd_set_split)
  from terminal_path_is_path[OF assms(1), unfolded `pth = _ `] `snd e = _`
  have "path v v' (pth1@[e])" and "path v' t pth2" unfolding path_split by (auto simp add: edge_end_tup)

  from `v' \<in> scope (v,p)` terminal_path_end_is_terminal[OF assms(1)] `path v' t pth2`
  have "(v,p) \<in> snd ` set pth2" by (rule scope_find)
  then obtain pth2a e' pth2b  where "pth2 = pth2a@[e']@pth2b" and "snd e' = (v,p)"  by (rule snd_set_split)
  from `path v' t pth2`[unfolded `pth2 = _ `] `snd e' = _`
  have "path v' v (pth2a@[e'])" and "path v t pth2b" unfolding path_split by (auto simp add: edge_end_tup)

  from `path v v' (pth1@[e])` `path v' v (pth2a@[e'])`
  have "path v v ((pth1@[e])@(pth2a@[e']))" by (rule path_appendI)
  moreover
  from terminal_path_is_hyps_free[OF assms(1)] `pth = _` `pth2 = _`
  have "hyps_free ((pth1@[e])@(pth2a@[e']))" by (auto simp add: hyps_free_def)
  ultimately
  have "((pth1@[e])@(pth2a@[e'])) = []" by (rule hyps_free_acyclic)
  thus False by simp
qed

end

text \<open>A saturated graph is one where every input port is incident to an edge.\<close>

locale Saturated_Graph = Port_Graph +
  assumes saturated: "valid_in_port (v,p) \<Longrightarrow> \<exists> e \<in> edges . snd e = (v,p)"

text \<open>These four conditions make up a well-shaped graph.\<close>

locale Well_Shaped_Graph =  Well_Scoped_Graph + Acyclic_Graph + Saturated_Graph + Pruned_Port_Graph

text \<open>Next we demand an instantiation. This consists of a unique natural number per vertex,
in order to rename the local constants apart, and furthermore a substitution per block
which instantiates the schematic formulas given in @{term Labeled_Signature}.\<close>

locale Instantiation =
  Vertex_Graph nodes _ _ vertices _ +
  Labeled_Signature nodes  _ _ _ labelsIn labelsOut +
  Abstract_Formulas freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP
  for nodes :: "'node stream" and edges :: "('vertex, 'outPort, 'inPort) edge set" and vertices :: "'vertex fset" and labelsIn :: "'node \<Rightarrow> 'inPort \<Rightarrow> 'form" and labelsOut :: "'node \<Rightarrow> 'outPort \<Rightarrow> 'form"
  and  freshenLC :: "nat \<Rightarrow> 'var \<Rightarrow> 'var"
    and renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> 'form \<Rightarrow> 'form"
    and lconsts :: "'form \<Rightarrow> 'var set"
    and closed :: "'form \<Rightarrow> bool"
    and subst :: "'subst \<Rightarrow> 'form \<Rightarrow> 'form"
    and subst_lconsts :: "'subst \<Rightarrow> 'var set"
    and subst_renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> ('subst \<Rightarrow> 'subst)"
    and anyP :: "'form" +
  fixes vidx :: "'vertex \<Rightarrow> nat"
    and inst :: "'vertex \<Rightarrow> 'subst"
  assumes vidx_inj: "inj_on vidx (fset vertices)"
begin
  definition labelAtIn :: "'vertex \<Rightarrow> 'inPort \<Rightarrow> 'form"  where
    "labelAtIn v p = subst (inst v) (freshen (vidx v) (labelsIn (nodeOf v) p))"
  definition labelAtOut :: "'vertex \<Rightarrow> 'outPort \<Rightarrow> 'form"  where
    "labelAtOut v p = subst (inst v) (freshen (vidx v) (labelsOut (nodeOf v) p))"
end

text \<open>A solution is an instantiation where on every edge, both incident ports are labeld with
the same formula.\<close>

locale Solution =
  Instantiation _ _ _ _ _ edges for edges :: "(('vertex \<times> 'outPort) \<times> 'vertex \<times> 'inPort) set" +
  assumes solved: "((v\<^sub>1,p\<^sub>1),(v\<^sub>2,p\<^sub>2)) \<in> edges \<Longrightarrow> labelAtOut v\<^sub>1 p\<^sub>1 = labelAtIn v\<^sub>2 p\<^sub>2"

locale Proof_Graph =  Well_Shaped_Graph + Solution

text \<open>If we have locally scoped constants, we demand that only blocks in the scope of the
corresponding input port may mention such a locally scoped variable in its substitution.\<close>

locale Well_Scoped_Instantiation =
   Pre_Port_Graph  nodes inPorts outPorts vertices nodeOf edges +
   Instantiation  inPorts outPorts nodeOf hyps nodes edges  vertices labelsIn labelsOut freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP vidx inst +
   Port_Graph_Signature_Scoped_Vars nodes inPorts outPorts freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP local_vars
   for freshenLC :: "nat \<Rightarrow> 'var \<Rightarrow> 'var"
    and renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> 'form \<Rightarrow> 'form"
    and lconsts :: "'form \<Rightarrow> 'var set"
    and closed :: "'form \<Rightarrow> bool"
    and subst :: "'subst \<Rightarrow> 'form \<Rightarrow> 'form"
    and subst_lconsts :: "'subst \<Rightarrow> 'var set"
    and subst_renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> ('subst \<Rightarrow> 'subst)"
    and anyP :: "'form"
    and inPorts :: "'node \<Rightarrow> 'inPort fset"
    and outPorts :: "'node \<Rightarrow> 'outPort fset"
    and nodeOf :: "'vertex \<Rightarrow> 'node"
    and hyps :: "'node \<Rightarrow> 'outPort \<Rightarrow> 'inPort option"
    and nodes :: "'node stream"
    and vertices :: "'vertex fset"
    and labelsIn :: "'node \<Rightarrow> 'inPort \<Rightarrow> 'form"
    and labelsOut :: "'node \<Rightarrow> 'outPort \<Rightarrow> 'form"
    and vidx :: "'vertex \<Rightarrow> nat"
    and inst :: "'vertex \<Rightarrow> 'subst"
    and edges :: "('vertex, 'outPort, 'inPort) edge set"
    and local_vars :: "'node \<Rightarrow> 'inPort \<Rightarrow> 'var set" +
  assumes well_scoped_inst:
    "valid_in_port (v,p) \<Longrightarrow>
     var \<in> local_vars (nodeOf v) p \<Longrightarrow>
     v' |\<in>| vertices \<Longrightarrow>
     freshenLC (vidx v) var \<in> subst_lconsts (inst v') \<Longrightarrow>
     v' \<in> scope (v,p)"
begin
  lemma out_of_scope: "valid_in_port (v,p) \<Longrightarrow> v' |\<in>| vertices \<Longrightarrow> v' \<notin> scope (v,p) \<Longrightarrow> freshenLC (vidx v) ` local_vars (nodeOf v) p \<inter> subst_lconsts (inst v') = {}"
    using well_scoped_inst by auto
end

text \<open>The following locale assembles all these conditions.\<close>

locale Scoped_Proof_Graph =
  Instantiation  inPorts outPorts nodeOf hyps nodes edges  vertices labelsIn labelsOut freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP vidx inst +
  Well_Shaped_Graph  nodes inPorts outPorts vertices nodeOf edges hyps  +
  Solution inPorts outPorts nodeOf hyps nodes vertices  labelsIn labelsOut freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP vidx inst edges +
  Well_Scoped_Instantiation  freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP inPorts outPorts nodeOf hyps  nodes vertices labelsIn labelsOut vidx inst edges local_vars
   for freshenLC :: "nat \<Rightarrow> 'var \<Rightarrow> 'var"
    and renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> 'form \<Rightarrow> 'form"
    and lconsts :: "'form \<Rightarrow> 'var set"
    and closed :: "'form \<Rightarrow> bool"
    and subst :: "'subst \<Rightarrow> 'form \<Rightarrow> 'form"
    and subst_lconsts :: "'subst \<Rightarrow> 'var set"
    and subst_renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> ('subst \<Rightarrow> 'subst)"
    and anyP :: "'form"
    and inPorts :: "'node \<Rightarrow> 'inPort fset"
    and outPorts :: "'node \<Rightarrow> 'outPort fset"
    and nodeOf :: "'vertex \<Rightarrow> 'node"
    and hyps :: "'node \<Rightarrow> 'outPort \<Rightarrow> 'inPort option"
    and nodes :: "'node stream"
    and vertices :: "'vertex fset"
    and labelsIn :: "'node \<Rightarrow> 'inPort \<Rightarrow> 'form"
    and labelsOut :: "'node \<Rightarrow> 'outPort \<Rightarrow> 'form"
    and vidx :: "'vertex \<Rightarrow> nat"
    and inst :: "'vertex \<Rightarrow> 'subst"
    and edges :: "('vertex, 'outPort, 'inPort) edge  set"
    and local_vars :: "'node \<Rightarrow> 'inPort \<Rightarrow> 'var set"

end


(*  Title:      HOL/UNITY/Simple/Common.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

Common Meeting Time example from Misra (1994)

The state is identified with the one variable in existence.

From Misra, "A Logic for Concurrent Programming" (1994), sections 5.1 and 13.1.
*)

theory Common
imports "../UNITY_Main"
begin

consts
  ftime :: "nat=>nat"
  gtime :: "nat=>nat"

axiomatization where
  fmono: "m \<le> n ==> ftime m \<le> ftime n" and
  gmono: "m \<le> n ==> gtime m \<le> gtime n" and

  fasc:  "m \<le> ftime n" and
  gasc:  "m \<le> gtime n"

definition common :: "nat set" where
    "common == {n. ftime n = n & gtime n = n}"

definition maxfg :: "nat => nat set" where
    "maxfg m == {t. t \<le> max (ftime m) (gtime m)}"

(*Misra's property CMT4: t exceeds no common meeting time*)
lemma common_stable:
     "[| \<forall>m. F \<in> {m} Co (maxfg m); n \<in> common |]
      ==> F \<in> Stable (atMost n)"
apply (drule_tac M = "{t. t \<le> n}" in Elimination_sing)
apply (simp add: atMost_def Stable_def common_def maxfg_def le_max_iff_disj)
apply (erule Constrains_weaken_R)
apply (blast intro: order_eq_refl le_trans dest: fmono gmono)
done

lemma common_safety:
     "[| Init F \<subseteq> atMost n;
         \<forall>m. F \<in> {m} Co (maxfg m); n \<in> common |]
      ==> F \<in> Always (atMost n)"
by (simp add: AlwaysI common_stable)

(*** Some programs that implement the safety property above ***)

lemma "SKIP \<in> {m} co (maxfg m)"
by (simp add: constrains_def maxfg_def le_max_iff_disj fasc)

(*This one is  t := ftime t || t := gtime t*)
lemma "mk_total_program
         (UNIV, {range(%t.(t,ftime t)), range(%t.(t,gtime t))}, UNIV)
       \<in> {m} co (maxfg m)"
apply (simp add: mk_total_program_def)
apply (simp add: constrains_def maxfg_def le_max_iff_disj fasc)
done

(*This one is  t := max (ftime t) (gtime t)*)
lemma "mk_total_program (UNIV, {range(%t.(t, max (ftime t) (gtime t)))}, UNIV)
       \<in> {m} co (maxfg m)"
apply (simp add: mk_total_program_def)
apply (simp add: constrains_def maxfg_def gasc max.absorb2)
done

(*This one is  t := t+1 if t <max (ftime t) (gtime t) *)
lemma  "mk_total_program
          (UNIV, { {(t, Suc t) | t. t < max (ftime t) (gtime t)} }, UNIV)
       \<in> {m} co (maxfg m)"
apply (simp add: mk_total_program_def)
apply (simp add: constrains_def maxfg_def gasc max.absorb2)
done

(*It remans to prove that they satisfy CMT3': t does not decrease,
  and that CMT3' implies that t stops changing once common(t) holds.*)

(*** Progress under weak fairness ***)

lemma leadsTo_common_lemma:
  assumes "\<forall>m. F \<in> {m} Co (maxfg m)"
    and "\<forall>m \<in> lessThan n. F \<in> {m} LeadsTo (greaterThan m)"
    and "n \<in> common"
  shows "F \<in> (atMost n) LeadsTo common"
proof (rule LeadsTo_weaken_R)
  show "F \<in> {..n} LeadsTo {..n} \<inter> id -` {n..} \<union> common"
  proof (induct rule: GreaterThan_bounded_induct [of n _ _ id])
    case 1
    from assms have "\<forall>m\<in>{..<n}. F \<in> {..n} \<inter> {m} LeadsTo {..n} \<inter> {m<..} \<union> common"
      by (blast dest: PSP_Stable2 intro: common_stable LeadsTo_weaken_R)
    then show ?case by simp
  qed
next
  from \<open>n \<in> common\<close>
  show "{..n} \<inter> id -` {n..} \<union> common \<subseteq> common"
    by (simp add: atMost_Int_atLeast)
qed

(*The "\<forall>m \<in> -common" form echoes CMT6.*)
lemma leadsTo_common:
     "[| \<forall>m. F \<in> {m} Co (maxfg m);
         \<forall>m \<in> -common. F \<in> {m} LeadsTo (greaterThan m);
         n \<in> common |]
      ==> F \<in> (atMost (LEAST n. n \<in> common)) LeadsTo common"
apply (rule leadsTo_common_lemma)
apply (simp_all (no_asm_simp))
apply (erule_tac [2] LeastI)
apply (blast dest!: not_less_Least)
done

end


(* Christoph Benzmüller and Bruno Woltzenlogel-P., February 2016 *)

theory Scott
imports QML

begin
  (* Gödel's Ontological Argument: Variant of Scott *)

  (* We work in logic S5. *)
  axiomatization where S5: "S5_sem"

  consts P :: "(\<mu> \<Rightarrow> \<sigma>) \<Rightarrow> \<sigma>"

  axiomatization where
    (* Either a property or its negation is positive, but not both. *)
    A1a: "\<lfloor>\<^bold>\<forall>\<Phi>. P(\<^sup>\<not>\<Phi>) \<^bold>\<rightarrow> \<^bold>\<not>(P \<Phi>)\<rfloor>" and
    A1b: "\<lfloor>\<^bold>\<forall>\<Phi>. \<^bold>\<not>(P \<Phi>) \<^bold>\<rightarrow> P (\<^sup>\<not>\<Phi>)\<rfloor>" and

    (* A property necessarily implied by a positive property is positive. *)
    A2:  "\<lfloor>\<^bold>\<forall>\<Phi>. \<^bold>\<forall>\<Psi>. (P \<Phi> \<^bold>\<and> \<^bold>\<box> (\<^bold>\<forall>x. \<Phi> x \<^bold>\<rightarrow> \<Psi> x)) \<^bold>\<rightarrow> P \<Psi>\<rfloor>"

  (* Positive properties are possibly exemplified. *)
  theorem T1: "\<lfloor>\<^bold>\<forall>\<Phi>. P \<Phi> \<^bold>\<rightarrow> \<^bold>\<diamond> (\<^bold>\<exists> \<Phi>)\<rfloor>"
  sledgehammer
  using A1a A2 by blast

  (* A God-like being possesses all positive properties. *)
  definition G :: "\<mu> \<Rightarrow> \<sigma>" where "G = (\<lambda>x. \<^bold>\<forall>(\<lambda>\<Phi>. P \<Phi> \<^bold>\<rightarrow> \<Phi> x))"

  (* The property of being God-like is positive. *)
  axiomatization where A3:  "\<lfloor>P G\<rfloor>"

  (* Possibly, God exists. *)
  corollary C: "\<lfloor>\<^bold>\<diamond> (\<^bold>\<exists> G)\<rfloor>"
  sledgehammer
  by (simp add: A3 T1)

  (* Positive properties are necessarily positive). *)
  axiomatization where A4:  "\<lfloor>\<^bold>\<forall>\<Phi>. P \<Phi> \<^bold>\<rightarrow> \<^bold>\<box>(P \<Phi>)\<rfloor>"

  (* An essence of an individual is a property possessed by it
     and necessarily implying any of its properties *)
  definition ess :: "(\<mu> \<Rightarrow> \<sigma>) \<Rightarrow> \<mu> \<Rightarrow> \<sigma>" (infixr "ess" 85) where
    "\<Phi> ess x = \<Phi> x \<^bold>\<and> (\<^bold>\<forall>\<Psi>. \<Psi> x \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>y. \<Phi> y \<^bold>\<rightarrow> \<Psi> y))"

  (* Being God-like is an essence of any God-like being. *)
  theorem T2: "\<lfloor>\<^bold>\<forall>(\<lambda>x. G x \<^bold>\<rightarrow> G ess x)\<rfloor>"
  sledgehammer [provers = remote_leo2, verbose]
  by (metis A1b A4 G_def ess_def)

  (* Necessary existence of an individual is the necessary
     exemplification of all its essences. *)
  definition NE :: "\<mu> \<Rightarrow> \<sigma>" where "NE = (\<lambda>x. \<^bold>\<forall>\<Phi>. \<Phi> ess x \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<exists> \<Phi>))"

  (* Necessary existence is a positive property *)
  axiomatization where A5:  "\<lfloor>P NE\<rfloor>"

  (* Necessarily, God exists *)
  theorem T3: "\<lfloor>\<^bold>\<box> (\<^bold>\<exists> G)\<rfloor>"
  sledgehammer [provers = remote_leo2, verbose]
  by (metis A5 C T2 S5 G_def NE_def)

  (* God exists *)
  corollary C2: "\<lfloor>\<^bold>\<exists> G\<rfloor>"
  sledgehammer [provers = remote_leo2, verbose]
  by (metis T1 T3 G_def S5)

  (* The consistency of the entire theory is confirmed by Nitpick. *)
  lemma True nitpick [satisfy, user_axioms, expect = genuine] oops

  (* G\"odel's God is flawless: (s)he does not have non-positive properties. *)
  theorem Flawlessness: "\<lfloor>\<^bold>\<forall>\<Phi>. \<^bold>\<forall>x. (G x \<^bold>\<rightarrow> (\<^bold>\<not>(P \<Phi>) \<^bold>\<rightarrow> \<^bold>\<not>(\<Phi> x)))\<rfloor>"
  sledgehammer [provers = remote_leo2, verbose]
  by (metis A1b G_def)

  (* There is only one God: any two God-like beings are equal. *)
  theorem Monotheism: "\<lfloor>\<^bold>\<forall>x.\<^bold>\<forall>y. (G x \<^bold>\<rightarrow> (G y \<^bold>\<rightarrow> (x \<^bold>=\<^sup>L y)))\<rfloor>"
  sledgehammer [provers = remote_satallax, verbose]
  by (metis Flawlessness G_def)

  (* Modal Collapse *)
  lemma MC: "\<lfloor>\<^bold>\<forall>\<Phi>.(\<Phi> \<^bold>\<rightarrow> (\<^bold>\<box> \<Phi>))\<rfloor>"
  sledgehammer [provers = remote_satallax, verbose, timeout = 600]
  -- {* by (metis T2 T3 ess\_def) *}
  -- {* by (meson T2 T3 ess_def) *}
  oops

(*<*)
end
(*>*)


theory Resolution_Compl_SC_Small
imports LSC_Resolution Resolution SC_Sema CNF_Formulas_Sema
begin

(* if you think that cnf transformation of LSC and Compactness are funky, this is the proof for you. *)
lemma Resolution_complete':
  assumes fin: "finite S"
  assumes val: "S \<TTurnstile> F"
  shows "\<Union>((cnf \<circ> nnf) ` ({\<^bold>\<not>F} \<union> S)) \<turnstile> \<box>"
proof -
  from fin obtain S' where S: "S = set_mset S'" using finite_set_mset_mset_set by blast
  have cnf: "\<forall>F \<in> set_mset (image_mset (cnf_form_of \<circ> nnf) (\<^bold>\<not> F, S')). is_cnf F" by(simp add: cnf_form_of_is is_nnf_nnf)
  note entailment_def[simp]
  from val
  have "S \<TTurnstile> \<^bold>\<not>(\<^bold>\<not>F)" by simp
  hence "S \<TTurnstile> \<^bold>\<not>(nnf (\<^bold>\<not>F))" by (simp add: nnf_semantics)
  hence "S \<TTurnstile> \<^bold>\<not>(cnf_form_of (nnf (\<^bold>\<not>F)))" by (simp add: cnf_form_semantics[OF is_nnf_nnf])
  hence "set_mset (image_mset nnf S') \<TTurnstile> \<^bold>\<not>(cnf_form_of (nnf (\<^bold>\<not>F)))" using S by (simp add: nnf_semantics)
  hence "set_mset (image_mset (cnf_form_of \<circ> nnf) S') \<TTurnstile> \<^bold>\<not>(cnf_form_of (nnf (\<^bold>\<not>F)))" by (simp add: cnf_form_semantics[OF is_nnf_nnf])
  hence "image_mset (cnf_form_of \<circ> nnf) S' \<Rightarrow> {#\<^bold>\<not>(cnf_form_of (nnf (\<^bold>\<not>F)))#}"
    unfolding SC_sound_complete sequent_intuitonistic_semantics .
  hence "image_mset (cnf_form_of \<circ> nnf) (\<^bold>\<not>F, S') \<Rightarrow> {#}" using NotR_inv by simp
  hence "image_mset (cnf_form_of \<circ> nnf) (\<^bold>\<not>F, S') \<Rightarrow>\<^sub>n" by (simp add: SC_LSC is_nnf_nnf nnf_cnf_form)
  with CSC_Resolution_pre have "\<Union>(cnf ` set_mset (image_mset (cnf_form_of \<circ> nnf) (\<^bold>\<not> F, S'))) \<turnstile> \<box>"  using cnf .
  thus ?thesis using cnf_cnf[where 'a='a, OF is_nnf_nnf]
               unfolding set_image_mset image_comp comp_def S by simp
qed

corollary Resolution_complete_single:
  assumes "\<Turnstile> F"
  shows "cnf (nnf (\<^bold>\<not>F)) \<turnstile> \<box>"
  using assms Resolution_complete'[OF finite.emptyI, of F]
  unfolding entailment_def comp_def by simp
(* the interesting thing that I want to state with this lemma (although much weaker than Resolution_complete (yes, the one from the other file without the '))
   is that you can prove all these things relatively easily. You don't need complicated things like compactness or that CNF transformation.
   (I did not feel like separating "that CNF transformation" into different files, so you'll either have to believe me
    or stare at the used lemmas and simp sets, etc. very intensely. *)

end


(* $Id$ *)
theory HEAP0SanityProofs
imports HEAP0Sanity HEAP0Proofs
begin

(*------------------------------------------------------------------------*)
section \<open> Proof of some properties of interest \<close>
(*------------------------------------------------------------------------*)

(*------------------------------------------------------------------------*)
subsection \<open> Invariant \<close>
(*------------------------------------------------------------------------*)

(* The invariant holds and fails at expected examples *)
lemma l_F0_inv_example: "F0_ex_inv F0_ex"
unfolding F0_ex_inv_defs by auto

lemma l_F0_inv_counter_example: "\<not> F0_ex_inv UNIV"
unfolding F0_ex_inv_defs by auto

(*------------------------------------------------------------------------*)
subsection \<open> Operations \<close>
(*------------------------------------------------------------------------*)

(*------------------------------------------------------------------------*)
(* NEW0(n) shrinks f *)

lemma new0_post_shrinks_f:
	"PO_new0_post_shrinks_f"
	unfolding PO_new0_post_shrinks_f_def new0_post_defs
	unfolding nat1_def inv_VDMNat1_def
  apply simp
  apply safe
  by (metis DiffE less_add_same_cancel1 mem_Collect_eq order_refl subset_iff)
(*by (smt Diff_subset mem_Collect_eq inv_VDMNat1_def set_diff_eq set_mp subset_iff_psubset_eq)*)

context level0_new
begin

lemma new0_postcondition_shrinks_f:
	"PO_new0_postcondition_shrinks_f"
by (smt PO_new0_post_shrinks_f_def PO_new0_postcondition_shrinks_f_def new0_post_shrinks_f new0_postcondition_def)

end

(*------------------------------------------------------------------------*)
(* NEW0(n) shrinks f by n, excactly *)

thm card_Diff_subset[of "locs_of r n" f]

lemma new0_post_shrinks_f_exactly:
	"PO_new0_post_shrinks_f_exactly"
unfolding PO_new0_post_shrinks_f_exactly_def new0_post_def is_block_def
apply safe
by (simp add: card_Diff_subset b_locs_of_finite b_locs_of_as_set_interval)

(*------------------------------------------------------------------------*)
(* DISPOSE0 extends f*)

context level0_dispose
begin

(* It's interesting what the difference is here: same goal, different proof script *)
lemma dispose0_postcondition_extends_f:
    "PO_dispose0_postcondition_extends_f"
unfolding PO_dispose0_postcondition_extends_f_def
          dispose0_postcondition_def
          dispose0_post_def
by (metis Un_commute b_locs_of_non_empty
          dispose0_pre_def inf_sup_absorb
          inf_sup_ord(3) l0_dispose0_precondition_def
          l0_input_notempty_def less_le)

lemma
	"dispose0_postcondition f' \<Longrightarrow> f0 \<subset> f'"
unfolding dispose0_postcondition_def dispose0_post_def
by (metis b_locs_of_non_empty dispose0_pre_def
          l0_dispose0_precondition_def inf_absorb2
          inf_commute inf_sup_ord(4) l0_input_notempty_def
          le_iff_sup less_le sup.left_idem)
	(*NOTE: we need the precondition *)

(*------------------------------------------------------------------------*)
(* DISPOSE0 extends f by n exactly*)

thm card_Un_disjoint[of f0 "locs_of d0 s0"]
	(* finite f0 \<Longrightarrow>
finite (locs_of d0 s0) \<Longrightarrow>
f0 \<inter> locs_of d0 s0 = {} \<Longrightarrow> card (f0 \<union> locs_of d0 s0) = card f0 + card (locs_of d0 s0)
*)

lemma dispose0_postcondition_extends_f_exactly:
	"PO_dispose0_postcondition_extends_f_exactly"
unfolding PO_dispose0_postcondition_extends_f_exactly_def
          dispose0_postcondition_def dispose0_post_def F0_inv_def
by (metis Int_commute add_0_iff card_Un_Int card.empty
          dispose0_pre_def finite_Un l0_dispose0_precondition_def
          l0_input_notempty_def l_locs_of_card)

lemma
	"dispose0_postcondition f' \<Longrightarrow> card f' = card f0 + s0"
	unfolding dispose0_postcondition_def dispose0_post_def F0_inv_def
  using PO_dispose0_feasibility_def PO_dispose0_postcondition_extends_f_exactly_def dispose0_post_def dispose0_postcondition_def dispose0_postcondition_extends_f_exactly locale0_dispose_FSB by presburger
	(*NOTE: we need the precondition *)
end

(*------------------------------------------------------------------------*)
(* DISPOSE0 NEW0(n) n = Id *)

lemma "PO_new0_dispose_0_identity"
unfolding PO_new0_dispose_0_identity_def
          new0_post_def dispose0_post_def F0_inv_def
apply (safe)
apply (metis is_block_def set_mp)
apply (metis finite_Diff)
by (metis b_locs_of_finite is_block_def)

lemma new0_dispose_0_identity:
	"PO_new0_dispose_0_identity"
by (metis PO_new0_dispose_0_identity_def
          Un_Diff_cancel dispose0_post_def
          is_block_def new0_post_def sup_absorb1 sup_commute)

end


(*
Title: WHATandWHERE-Security
Authors: Sylvia Grewe, Alexander Lux, Heiko Mantel, Jens Sauer
*)
theory Up_To_Technique
imports "WHATWHERE_Security"
begin

context WHATWHERE
begin

abbreviation SdlHPPB where "SdlHPPB \<equiv> Strong_dlHPP_Bisimulation"

--"define the 'reflexive part' of a relation (sets of elements which are related with themselves by the given relation)"
definition Arefl :: "('a \<times> 'a) set \<Rightarrow> 'a set"
where
"Arefl R = {e. (e,e) \<in> R}"

lemma commonArefl_subset_commonDomain:
"(Arefl R1 \<inter> Arefl R2) \<subseteq> (Domain R1 \<inter> Domain R2)"
  by (simp add: Arefl_def, auto)

--"define disjoint strong (d,lH,PP)-bisimulation up-to-R' for a relation R"
definition disj_dlHPP_Bisimulation_Up_To_R' ::
  "'d \<Rightarrow> nat set \<Rightarrow> 'com Bisimulation_type
  \<Rightarrow> 'com Bisimulation_type \<Rightarrow> bool"
where
"disj_dlHPP_Bisimulation_Up_To_R' d PP R' R \<equiv>
  SdlHPPB d PP R' \<and> (sym R) \<and> (trans R)
  \<and> (\<forall>(V,V') \<in> R. length V = length V') \<and>
  (\<forall>(V,V') \<in> R. \<forall>i < length V.
    ((NDC d (V!i)) \<or>
     (IDC d (V!i) (htchLoc (pp (V!i)))))) \<and>
  (\<forall>(V,V') \<in> R. \<forall>i < length V. \<forall>m1 m1' m2 \<alpha> p.
    (\<langle>V!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle> \<and> m1 \<sim>\<^bsub>d,(htchLocSet PP)\<^esub> m1')
    \<longrightarrow> (\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
        (stepResultsinR p p' (R \<union> R')) \<and> (\<alpha>,\<alpha>') \<in> (R \<union> R') \<and>
        (dhequality_alternative d PP (pp (V!i)) m2 m2')))"

--"lemma about the transitivity of the union of symmetric and transitive relations under certain circumstances"
lemma trans_RuR':
  assumes transR: "trans R"
  assumes symR: "sym R"
  assumes transR': "trans R'"
  assumes symR': "sym R'"
  assumes eqlenR: "\<forall>(V,V') \<in> R. length V = length V'"
  assumes eqlenR': "\<forall>(V,V') \<in> R'. length V = length V'"
  assumes Areflassump: "(Arefl R \<inter> Arefl R') \<subseteq> {[]}"
  shows "trans (R \<union> R')"
proof -
 {
   fix V V' V''
   assume p1: "(V,V') \<in> (R \<union> R')"
   assume p2: "(V',V'') \<in> (R \<union> R')"

   from p1 p2 have "(V,V'') \<in> (R \<union> R')"
     proof (auto)
         assume inR1: "(V,V') \<in> R"
         assume inR2: "(V',V'') \<in> R"
         from inR1 inR2 transR show "(V,V'') \<in> R"
           unfolding trans_def
           by blast
       next
         assume inR'1: "(V,V') \<in> R'"
         assume inR'2: "(V',V'') \<in> R'"
         assume notinR': "(V,V'') \<notin> R'"
         from inR'1 inR'2 transR' have inR': "(V,V'') \<in> R'"
           unfolding trans_def
           by blast
         from notinR' inR' have "False"
           by auto
         thus "(V,V'') \<in> R" ..
       next
         assume inR1: "(V,V') \<in> R"
         assume inR'2: "(V',V'') \<in> R'"
         from inR1 symR transR have "(V,V) \<in> R \<and> (V',V') \<in> R"
           unfolding sym_def trans_def
           by blast
         hence AreflR: "{V,V'} \<subseteq> Arefl R" by (simp add: Arefl_def)
         from inR'2 symR' transR' have "(V',V') \<in> R' \<and> (V'',V'') \<in> R'"
           unfolding sym_def trans_def
           by blast
         hence AreflR': "{V',V''} \<subseteq> Arefl R'" by (simp add: Arefl_def)

         from AreflR AreflR' Areflassump have V'empt: "V' = []"
           by (simp add: Arefl_def, blast)
         with inR'2 eqlenR' have "V' = V''" by auto
         with inR1 show "(V, V'') \<in> R" by auto
       next
         assume inR'1: "(V,V') \<in> R'"
         assume inR2: "(V',V'') \<in> R"
         from inR'1 symR' transR' have "(V,V) \<in> R' \<and> (V',V') \<in> R'"
           unfolding sym_def trans_def
           by blast
         hence AreflR': "{V,V'} \<subseteq> Arefl R'" by (simp add: Arefl_def)
         from inR2 symR transR have "(V',V') \<in> R \<and> (V'',V'') \<in> R"
           unfolding sym_def trans_def
           by blast
         hence AreflR: "{V',V''} \<subseteq> Arefl R" by (simp add: Arefl_def)

         from AreflR AreflR' Areflassump have V'empt: "V' = []"
           by (simp add: Arefl_def, blast)
         with inR'1 eqlenR' have "V' = V" by auto
         with inR2 show "(V, V'') \<in> R" by auto
       qed
 }
 thus ?thesis unfolding trans_def by force

qed

lemma Up_To_Technique:
"\<lbrakk> disj_dlHPP_Bisimulation_Up_To_R' d PP R' R;
  Arefl R \<inter> Arefl R' \<subseteq> {[]} \<rbrakk>
  \<Longrightarrow> SdlHPPB d PP (R \<union> R')"
proof (simp add: disj_dlHPP_Bisimulation_Up_To_R'_def
    Strong_dlHPP_Bisimulation_def, auto)
  assume symR': "sym R'"
  assume symR: "sym R"
  with symR' show "sym (R \<union> R')"
    by (simp add: sym_def)
next
  assume symR': "sym R'"
  assume symR: "sym R"
  assume transR': "trans R'"
  assume transR: "trans R"
  assume eqlenR': "\<forall>(V, V')\<in>R'. length V = length V'"
  assume eqlenR: "\<forall>(V, V')\<in>R. length V = length V'"
  assume areflassump: "Arefl R \<inter> Arefl R' \<subseteq> {[]}"
  from symR' symR transR' transR eqlenR' eqlenR areflassump trans_RuR'
  show "trans (R \<union> R')"
    by blast
  --"condition about IDC and NDC and equal length already proven above by auto tactic!"
next
  fix V V' i m1 m1' m2 \<alpha> p
  assume inR': "(V,V') \<in> R'"
  assume irange: "i < length V"
  assume step: "\<langle>V!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle>"
  assume dhequal: "m1 \<sim>\<^bsub>d,(htchLocSet PP)\<^esub> m1'"
  assume disjBisimUpTo: "\<forall>(V,V')\<in>R'. \<forall>i < length V. \<forall>m1 m1' m2 \<alpha> p.
    \<langle>V!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle> \<and> m1 \<sim>\<^bsub>d,(htchLocSet PP)\<^esub> m1' \<longrightarrow>
    (\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
    stepResultsinR p p' R' \<and> (\<alpha>, \<alpha>') \<in> R' \<and>
    dhequality_alternative d PP (pp (V!i)) m2 m2')"
  from inR' irange step dhequal disjBisimUpTo show "\<exists>p' \<alpha>' m2'.
    \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and> stepResultsinR p p' (R \<union> R') \<and>
    ((\<alpha>,\<alpha>') \<in> R \<or> (\<alpha>,\<alpha>') \<in> R') \<and>
    dhequality_alternative d PP (pp (V!i)) m2 m2'"
    by (simp add: stepResultsinR_def,fastforce)
qed

lemma Union_Strong_dlHPP_Bisim:
"\<lbrakk> SdlHPPB d PP R; SdlHPPB d PP R';
  Arefl R \<inter> Arefl R' \<subseteq> {[]} \<rbrakk>
  \<Longrightarrow> SdlHPPB d PP (R \<union> R')"
by (rule Up_To_Technique, simp_all add:
  disj_dlHPP_Bisimulation_Up_To_R'_def
  Strong_dlHPP_Bisimulation_def stepResultsinR_def, fastforce)

lemma adding_emptypair_keeps_SdlHPPB:
  assumes SdlHPP: "SdlHPPB d PP R"
  shows "SdlHPPB d PP (R \<union> {([],[])})"
proof -
  have SdlHPPemp: "SdlHPPB d PP {([],[])}"
    by (simp add: Strong_dlHPP_Bisimulation_def sym_def trans_def)

  have commonDom: "Domain R \<inter> Domain {([],[])} \<subseteq> {[]}"
    by auto

  with commonArefl_subset_commonDomain have Areflassump:
    "Arefl R \<inter> Arefl {([],[])} \<subseteq> {[]}"
    by force

  with SdlHPP SdlHPPemp Union_Strong_dlHPP_Bisim show
    "SdlHPPB d PP (R \<union> {([],[])})"
    by force
qed

end

end


theory TickTock_IntChoice
  imports TickTock_Core
begin

subsection {* Internal Choice *}

definition IntChoiceTT :: "'e ttobs list set \<Rightarrow> 'e ttobs list set \<Rightarrow> 'e ttobs list set" (infixl "\<sqinter>\<^sub>C" 56) where
  "P \<sqinter>\<^sub>C Q = P \<union> Q"

lemma IntChoiceTT_wf: "\<forall> t\<in>P. ttWF t \<Longrightarrow> \<forall> t\<in>Q. ttWF t \<Longrightarrow> \<forall> t\<in>P \<sqinter>\<^sub>C Q. ttWF t"
  unfolding IntChoiceTT_def by auto

lemma TT2_IntChoice:
  assumes "TT2 P" "TT2 Q"
  shows "TT2 (P \<sqinter>\<^sub>C Q)"
    using assms unfolding IntChoiceTT_def TT2_def by (auto, (smt disjoint_iff_not_equal mem_Collect_eq)+)

lemma TT3w_IntChoice:
  assumes "TT3w P" "TT3w Q"
  shows "TT3w (P \<sqinter>\<^sub>C Q)"
  using assms unfolding IntChoiceTT_def TT3w_def by auto

lemma TT3_IntChoice:
  assumes "TT3 P" "TT3 Q"
  shows "TT3 (P \<sqinter>\<^sub>C Q)"
  using assms unfolding IntChoiceTT_def TT3_def by auto

lemma TT_IntChoice:
  assumes "TT P" "TT Q"
  shows "TT (P \<sqinter>\<^sub>C Q)"
  unfolding TT_defs
proof auto
  fix x
  show "x \<in> P \<sqinter>\<^sub>C Q \<Longrightarrow> ttWF x"
    by (metis TT_wf IntChoiceTT_def Un_iff assms(1) assms(2))
next
  show "P \<sqinter>\<^sub>C Q = {} \<Longrightarrow> False"
    using TT_empty IntChoiceTT_def assms(1) by blast
next
  fix \<rho> \<sigma>
  show "\<rho> \<lesssim>\<^sub>C \<sigma> \<Longrightarrow> \<sigma> \<in> P \<sqinter>\<^sub>C Q \<Longrightarrow> \<rho> \<in> P \<sqinter>\<^sub>C Q"
    by (metis TT1_def TT_TT1 IntChoiceTT_def Un_iff assms(1) assms(2))
next
  fix \<rho> X Y
  assume assm1: "\<rho> @ [[X]\<^sub>R] \<in> P \<sqinter>\<^sub>C Q"
  assume assm2: "Y \<inter> {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<sqinter>\<^sub>C Q \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P \<sqinter>\<^sub>C Q} = {}"
  have 1: "\<rho> @ [[X]\<^sub>R] \<in> P \<or> \<rho> @ [[X]\<^sub>R] \<in> Q"
    using assm1 unfolding IntChoiceTT_def by auto
  have 2: "{e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<sqinter>\<^sub>C Q \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P \<sqinter>\<^sub>C Q} =
    {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P} \<union> {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> Q \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> Q}"
    unfolding IntChoiceTT_def by auto
  have 3: "Y \<inter> {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P} = {}"
    using 2 assm2 inf_sup_distrib1 by auto
  have 4: "Y \<inter> {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> Q \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> Q} = {}"
    using 2 assm2 inf_sup_distrib1 by auto
  have 5: "\<rho> @ [[X]\<^sub>R] \<in> P \<Longrightarrow> \<rho> @ [[X \<union> Y]\<^sub>R] \<in> P"
    using "3" TT2w_def TT_def assms(1) by blast
  have 6: "\<rho> @ [[X]\<^sub>R] \<in> Q \<Longrightarrow> \<rho> @ [[X \<union> Y]\<^sub>R] \<in> Q"
    using "4" TT2w_def TT_def assms(2) by blast
  show "\<rho> @ [[X \<union> Y]\<^sub>R] \<in> P \<sqinter>\<^sub>C Q"
    using "1" "5" "6" IntChoiceTT_def by blast
next
  fix x
  show "x \<in> P \<sqinter>\<^sub>C Q \<Longrightarrow> ttWFx_trace x"
    by (metis ttWFx_def TT_ttWFx IntChoiceTT_def UnE assms(1) assms(2))
qed

lemma IntChoice_Union_dist1:
  "S \<noteq> {} \<Longrightarrow> P \<sqinter>\<^sub>C \<Union>S = \<Union>{R. \<exists>Q. Q \<in> S \<and> R = P \<sqinter>\<^sub>C Q}"
  unfolding IntChoiceTT_def by auto

lemma IntChoice_Union_dist2:
  "S \<noteq> {} \<Longrightarrow> \<Union>S \<sqinter>\<^sub>C Q = \<Union>{R. \<exists>P. P \<in> S \<and> R = P \<sqinter>\<^sub>C Q}"
  unfolding IntChoiceTT_def by auto

lemma IntChoice_mono1:
  "P \<sqsubseteq>\<^sub>C Q \<Longrightarrow> P \<sqinter>\<^sub>C R \<sqsubseteq>\<^sub>C Q \<sqinter>\<^sub>C R"
  unfolding RefinesTT_def IntChoiceTT_def by auto

lemma IntChoice_mono2:
  "P \<sqsubseteq>\<^sub>C Q \<Longrightarrow> R \<sqinter>\<^sub>C P \<sqsubseteq>\<^sub>C R \<sqinter>\<^sub>C Q"
  unfolding RefinesTT_def IntChoiceTT_def by auto

end