theory Incredible_Trees
imports
  "HOL-Library.Sublist"
  "HOL-Library.Countable"
  Entailment
  Rose_Tree
  Abstract_Rules_To_Incredible
begin

text \<open>This theory defines incredible trees, which carry roughly the same information
as a (tree-shaped) incredible graph, but where the structure is still given by the data type,
and not by a set of edges etc.\<close>

text \<open>
Tree-shape, but incredible-graph-like content (port names, explicit annotation and substitution)
\<close>

datatype ('form,'rule,'subst,'var) itnode =
    I (iNodeOf': "('form, 'rule) graph_node")
      (iOutPort': "'form reg_out_port")
      (iAnnot': "nat")
      (iSubst': "'subst")
  | H (iAnnot': "nat")
      (iSubst': "'subst")

abbreviation "INode n p i s ants \<equiv> RNode (I n p i s) ants"
abbreviation "HNode i s ants \<equiv> RNode (H i s) ants"

type_synonym ('form,'rule,'subst,'var) itree = "('form,'rule,'subst,'var) itnode rose_tree"

fun iNodeOf where
   "iNodeOf (INode n p i s ants) = n"
 | "iNodeOf (HNode i s ants) = Helper"

context Abstract_Formulas begin
fun iOutPort where
   "iOutPort (INode n p i s ants) = p"
 | "iOutPort (HNode i s ants) = anyP"
end

fun iAnnot where "iAnnot it = iAnnot' (root it)"
fun iSubst where "iSubst it = iSubst' (root it)"
fun iAnts where "iAnts it = children it"

type_synonym ('form, 'rule, 'subst) fresh_check = "('form, 'rule) graph_node \<Rightarrow> nat \<Rightarrow> 'subst \<Rightarrow> 'form entailment \<Rightarrow> bool"

context  Abstract_Task
begin

  text \<open>The well-formedness of the tree. The first argument can be varied, depending on whether we
  are interested in the local freshness side-conditions or not.\<close>

  inductive iwf :: "('form, 'rule, 'subst) fresh_check \<Rightarrow> ('form,'rule,'subst,'var) itree \<Rightarrow> 'form entailment \<Rightarrow> bool"
    for fc
    where
    iwf: "\<lbrakk>
       n \<in> sset nodes;
       Reg p |\<in>| outPorts n;
       list_all2 (\<lambda> ip t. iwf fc t ((\<lambda> h . subst s (freshen i (labelsOut n h))) |`| hyps_for n ip |\<union>| \<Gamma> \<turnstile> subst s (freshen i (labelsIn n ip))))
                (inPorts' n) ants;
       fc n i s (\<Gamma> \<turnstile> c);
       c = subst s (freshen i p)
      \<rbrakk> \<Longrightarrow> iwf fc (INode n p i s ants) (\<Gamma> \<turnstile> c)"
  | iwfH: "\<lbrakk>
       c |\<notin>| ass_forms;
       c |\<in>| \<Gamma>;
       c = subst s (freshen i anyP)
      \<rbrakk> \<Longrightarrow> iwf fc (HNode i s []) (\<Gamma> \<turnstile> c)"

lemma iwf_subst_freshen_outPort:
  "iwf lc ts ent \<Longrightarrow>
  snd ent = subst (iSubst ts) (freshen (iAnnot ts) (iOutPort ts))"
  by (auto elim: iwf.cases)

definition all_local_vars :: "('form, 'rule) graph_node \<Rightarrow> 'var set" where
  "all_local_vars n = \<Union>(local_vars n ` fset (inPorts n))"

lemma all_local_vars_Helper[simp]:
  "all_local_vars Helper = {}"
  unfolding all_local_vars_def by simp

lemma all_local_vars_Assumption[simp]:
  "all_local_vars (Assumption c) = {}"
  unfolding all_local_vars_def by simp

text \<open>Local freshness side-conditions, corresponding what we have in the
theory \<open>Natural_Deduction\<close>.\<close>

inductive local_fresh_check :: "('form, 'rule, 'subst) fresh_check" where
  "\<lbrakk>\<And> f. f |\<in>| \<Gamma> \<Longrightarrow> freshenLC i ` (all_local_vars n) \<inter> lconsts f = {};
    freshenLC i ` (all_local_vars n) \<inter> subst_lconsts s = {}
   \<rbrakk> \<Longrightarrow> local_fresh_check n i s (\<Gamma> \<turnstile> c)"

abbreviation "local_iwf \<equiv> iwf local_fresh_check"

text \<open>No freshness side-conditions. Used with the tree that comes out of
\<open>globalize\<close>, where we establish the (global) freshness conditions
separately.\<close>

inductive no_fresh_check :: "('form, 'rule, 'subst) fresh_check" where
  "no_fresh_check n i s (\<Gamma> \<turnstile> c)"

abbreviation "plain_iwf \<equiv> iwf no_fresh_check"

fun isHNode where
  "isHNode (HNode _ _ _ ) = True"
 |"isHNode _ = False"

lemma iwf_edge_match:
  assumes "iwf fc t ent"
  assumes "is@[i] \<in> it_paths t"
  shows "subst (iSubst (tree_at t (is@[i]))) (freshen (iAnnot (tree_at t (is@[i]))) (iOutPort (tree_at t (is@[i]))))
     = subst (iSubst (tree_at t is)) (freshen (iAnnot (tree_at t is)) (a_conc (inPorts' (iNodeOf (tree_at t is)) ! i)))"
  using assms
  apply (induction arbitrary: "is" i)
   apply (auto elim!: it_paths_SnocE)[1]
   apply (rename_tac "is" i)
   apply (case_tac "is")
    apply (auto dest!: list_all2_nthD2)[1]
    using iwf_subst_freshen_outPort
    apply (solves \<open>(auto)[1]\<close>)
   apply (auto elim!: it_paths_ConsE dest!: list_all2_nthD2)[1]
   using it_path_SnocI
   apply (solves blast)
  apply (solves auto)
  done

lemma iwf_length_inPorts:
  assumes "iwf fc t ent"
  assumes "is \<in> it_paths t"
  shows "length (iAnts (tree_at t is)) \<le> length (inPorts' (iNodeOf (tree_at t is)))"
  using assms
  by (induction arbitrary: "is" rule: iwf.induct)
     (auto elim!: it_paths_RNodeE dest: list_all2_lengthD list_all2_nthD2)

lemma iwf_local_not_in_subst:
  assumes "local_iwf t ent"
  assumes "is \<in> it_paths t"
  assumes "var \<in> all_local_vars (iNodeOf (tree_at t is))"
  shows "freshenLC (iAnnot (tree_at t is)) var \<notin> subst_lconsts (iSubst (tree_at t is))"
  using assms
  by (induction arbitrary: "is" rule: iwf.induct)
     (auto 4 4 elim!: it_paths_RNodeE local_fresh_check.cases dest: list_all2_lengthD list_all2_nthD2)

lemma iwf_length_inPorts_not_HNode:
  assumes "iwf fc t ent"
  assumes "is \<in> it_paths t"
  assumes "\<not> (isHNode (tree_at t is))"
  shows "length (iAnts (tree_at t is)) = length (inPorts' (iNodeOf (tree_at t is)))"
  using assms
  by (induction arbitrary: "is" rule: iwf.induct)
     (auto 4 4 elim!: it_paths_RNodeE  dest: list_all2_lengthD list_all2_nthD2)

lemma iNodeOf_outPorts:
  "iwf fc t ent \<Longrightarrow> is \<in> it_paths t \<Longrightarrow> outPorts (iNodeOf (tree_at t is)) = {||} \<Longrightarrow> False"
  by (induction arbitrary: "is" rule: iwf.induct)
     (auto 4 4 elim!: it_paths_RNodeE  dest: list_all2_lengthD list_all2_nthD2)

lemma iwf_outPort:
  assumes "iwf fc t ent"
  assumes "is \<in> it_paths t"
  shows "Reg (iOutPort (tree_at t is)) |\<in>| outPorts (iNodeOf (tree_at t is))"
  using assms
  by (induction arbitrary: "is" rule: iwf.induct)
     (auto 4 4 elim!: it_paths_RNodeE  dest: list_all2_lengthD list_all2_nthD2)

inductive_set hyps_along for t "is" where
 "prefix (is'@[i]) is \<Longrightarrow>
  i < length (inPorts' (iNodeOf (tree_at t is'))) \<Longrightarrow>
  hyps (iNodeOf (tree_at t is')) h = Some (inPorts' (iNodeOf (tree_at t is')) ! i) \<Longrightarrow>
  subst (iSubst (tree_at t is')) (freshen (iAnnot (tree_at t is')) (labelsOut (iNodeOf (tree_at t is')) h)) \<in> hyps_along t is"

lemma hyps_along_Nil[simp]: "hyps_along t [] = {}"
  by (auto simp add: hyps_along.simps)

lemma prefix_app_Cons_elim:
  assumes "prefix (xs@[y]) (z#zs)"
  obtains "xs = []" and "y = z"
   | xs' where "xs = z#xs'" and "prefix (xs'@[y]) zs"
using assms by (cases xs) auto

lemma hyps_along_Cons:
  assumes "iwf fc t ent"
  assumes "i#is \<in> it_paths t"
  shows "hyps_along t (i#is) =
    (\<lambda>h. subst (iSubst t) (freshen (iAnnot t) (labelsOut (iNodeOf t) h))) ` fset (hyps_for (iNodeOf t) (inPorts' (iNodeOf t) ! i))
    \<union> hyps_along (iAnts t ! i) is" (is "?S1 = ?S2 \<union> ?S3")
proof-
  from assms
  have "i < length (iAnts t)" and "is \<in> it_paths (iAnts t ! i)"
    by (auto elim: it_paths_ConsE)
  let "?t'" = "iAnts t ! i"

  show ?thesis
  proof (rule; rule)
    fix x
    assume "x \<in> hyps_along t (i # is)"
    then obtain is' i' h where
      "prefix (is'@[i']) (i#is)"
      and "i' < length (inPorts' (iNodeOf (tree_at t is')))"
      and "hyps (iNodeOf (tree_at t is')) h = Some (inPorts' (iNodeOf (tree_at t is')) ! i')"
      and [simp]: "x = subst (iSubst (tree_at t is')) (freshen (iAnnot (tree_at t is')) (labelsOut (iNodeOf (tree_at t is')) h))"
    by (auto elim!: hyps_along.cases)
    from this(1)
    show "x \<in> ?S2 \<union> ?S3"
    proof(cases rule: prefix_app_Cons_elim)
      assume "is' = []" and "i' = i"
      with \<open>hyps (iNodeOf (tree_at t is')) h = Some _\<close>
      have "x \<in> ?S2" by auto
      thus ?thesis..
    next
      fix is''
      assume [simp]: "is' = i # is''" and "prefix (is'' @ [i']) is"
      have "tree_at t is' = tree_at ?t' is''" by simp

      note \<open>prefix (is'' @ [i']) is\<close>
           \<open>i' < length (inPorts' (iNodeOf (tree_at t is')))\<close>
           \<open>hyps (iNodeOf (tree_at t is')) h = Some (inPorts' (iNodeOf (tree_at t is')) ! i')\<close>
      from this[unfolded \<open>tree_at t is' = tree_at ?t' is''\<close>]
      have "subst (iSubst (tree_at (iAnts t ! i) is'')) (freshen (iAnnot (tree_at (iAnts t ! i) is'')) (labelsOut (iNodeOf (tree_at (iAnts t ! i) is'')) h))
          \<in> hyps_along (iAnts t ! i) is" by (rule hyps_along.intros)
      hence "x \<in> ?S3" by simp
      thus ?thesis..
    qed
  next
    fix x
    assume "x \<in> ?S2 \<union> ?S3"
    thus "x \<in> ?S1"
    proof
      have "prefix ([]@[i]) (i#is)" by simp
      moreover
      from \<open>iwf _ t _\<close>
      have "length (iAnts t) \<le> length (inPorts' (iNodeOf (tree_at t []))) "
        by cases (auto dest: list_all2_lengthD)
      with \<open>i < _\<close>
      have "i < length (inPorts' (iNodeOf (tree_at t [])))" by simp
      moreover
      assume "x \<in> ?S2"
      then obtain h where "h |\<in>| hyps_for (iNodeOf t) (inPorts' (iNodeOf t) ! i)"
        and [simp]: "x = subst (iSubst t) (freshen (iAnnot t) (labelsOut (iNodeOf t) h))" by auto
      from this(1)
      have "hyps (iNodeOf (tree_at t [])) h = Some (inPorts' (iNodeOf (tree_at t [])) ! i)" by simp
      ultimately
      have "subst (iSubst (tree_at t [])) (freshen (iAnnot (tree_at t [])) (labelsOut (iNodeOf (tree_at t [])) h)) \<in> hyps_along t (i # is)"
        by (rule hyps_along.intros)
      thus "x \<in> hyps_along t (i # is)" by simp
    next
      assume "x \<in> ?S3"
      thus "x \<in> ?S1"
        apply (auto simp add: hyps_along.simps)
        apply (rule_tac x = "i#is'" in exI)
        apply auto
        done
    qed
  qed
qed

lemma iwf_hyps_exist:
  assumes "iwf lc it ent"
  assumes "is \<in> it_paths it"
  assumes "tree_at it is = (HNode i s ants')"
  assumes "fst ent |\<subseteq>| ass_forms"
  shows "subst s (freshen i anyP) \<in> hyps_along it is"
proof-
  from assms(1,2,3)
  have "subst s (freshen i anyP) \<in> hyps_along it is
     \<or> subst s (freshen i anyP) |\<in>| fst ent
       \<and> subst s (freshen i anyP) |\<notin>| ass_forms"
  proof(induction arbitrary: "is" rule: iwf.induct)
    case (iwf n p  s' a' \<Gamma> ants c "is")

    have "iwf lc (INode n p a' s' ants) (\<Gamma> \<turnstile> c)"
      using iwf(1,2,3,4,5)
      by (auto intro!: iwf.intros elim!: list_all2_mono)

    show ?case
    proof(cases "is")
      case Nil
      with \<open>tree_at (INode n p a' s' ants) is = HNode i s ants'\<close>
      show ?thesis by auto
    next
      case (Cons i' "is'")
      with \<open>is \<in> it_paths (INode n p a' s' ants)\<close>
      have "i' < length ants" and "is' \<in> it_paths (ants ! i')"
        by (auto elim: it_paths_ConsE)

      let ?\<Gamma>' = "(\<lambda>h. subst s' (freshen a' (labelsOut n h))) |`| hyps_for n (inPorts' n ! i')"

      from \<open>tree_at (INode n p a' s' ants) is = HNode i s ants'\<close>
      have "tree_at (ants ! i') is' = HNode i s ants'" using Cons by simp

      from  iwf.IH \<open>i' < length ants\<close>  \<open>is' \<in> it_paths (ants ! i')\<close> this
      have  "subst s (freshen i anyP) \<in> hyps_along (ants ! i') is'
        \<or> subst s (freshen i anyP) |\<in>| ?\<Gamma>' |\<union>| \<Gamma> \<and> subst s (freshen i anyP) |\<notin>| ass_forms"
        by (auto dest: list_all2_nthD2)
      moreover
      from  \<open>is \<in> it_paths (INode n p a' s' ants)\<close>
      have "hyps_along (INode n p a' s' ants) is = fset ?\<Gamma>' \<union> hyps_along (ants ! i') is'"
        using \<open>is = _\<close>
        by (simp add: hyps_along_Cons[OF \<open>iwf lc (INode n p a' s' ants) (\<Gamma> \<turnstile> c)\<close>])
      ultimately
      show ?thesis by auto
    qed
  next
    case (iwfH c  \<Gamma> s' i' "is")
    hence [simp]: "is = []" "i' = i" "s' = s" by simp_all
    from \<open>c = subst s' (freshen i' anyP)\<close> \<open>c |\<in>| \<Gamma>\<close> \<open>c |\<notin>| ass_forms\<close>
    show ?case by simp
  qed
  with assms(4)
  show ?thesis by blast
qed

definition hyp_port_for' :: "('form, 'rule, 'subst, 'var) itree \<Rightarrow> nat list \<Rightarrow> 'form \<Rightarrow> nat list \<times> nat \<times> ('form, 'var) out_port" where
  "hyp_port_for' t is f = (SOME x.
   (case x of (is', i, h) \<Rightarrow>
      prefix (is' @ [i]) is \<and>
      i < length (inPorts' (iNodeOf (tree_at t is'))) \<and>
      hyps (iNodeOf (tree_at t is')) h =  Some (inPorts' (iNodeOf (tree_at t is')) ! i) \<and>
      f = subst (iSubst  (tree_at t is')) (freshen (iAnnot (tree_at t is')) (labelsOut (iNodeOf (tree_at t is')) h))
   ))"

lemma hyp_port_for_spec':
  assumes "f \<in> hyps_along t is"
  shows "(case hyp_port_for' t is f of (is', i, h) \<Rightarrow>
      prefix (is' @ [i]) is \<and>
      i < length (inPorts' (iNodeOf (tree_at t is'))) \<and>
      hyps (iNodeOf (tree_at t is')) h =  Some (inPorts' (iNodeOf (tree_at t is')) ! i) \<and>
      f = subst (iSubst  (tree_at t is')) (freshen (iAnnot (tree_at t is')) (labelsOut (iNodeOf (tree_at t is')) h)))"
using assms unfolding hyps_along.simps hyp_port_for'_def by -(rule someI_ex, blast)

definition hyp_port_path_for :: "('form, 'rule, 'subst, 'var) itree \<Rightarrow> nat list \<Rightarrow> 'form \<Rightarrow> nat list"
  where "hyp_port_path_for t is f = fst (hyp_port_for' t is f)"
definition hyp_port_i_for ::  "('form, 'rule, 'subst, 'var) itree \<Rightarrow> nat list \<Rightarrow> 'form \<Rightarrow> nat"
  where "hyp_port_i_for t is f = fst (snd (hyp_port_for' t is f))"
definition hyp_port_h_for :: "('form, 'rule, 'subst, 'var) itree \<Rightarrow> nat list \<Rightarrow> 'form \<Rightarrow> ('form, 'var) out_port"
  where "hyp_port_h_for t is f = snd (snd (hyp_port_for' t is f))"

lemma hyp_port_prefix:
  assumes "f \<in> hyps_along t is"
  shows "prefix (hyp_port_path_for t is f@[hyp_port_i_for t is f]) is"
using hyp_port_for_spec'[OF assms] unfolding hyp_port_path_for_def hyp_port_i_for_def by auto

lemma hyp_port_strict_prefix:
  assumes "f \<in> hyps_along t is"
  shows "strict_prefix (hyp_port_path_for t is f) is"
using hyp_port_prefix[OF assms] by (simp add: strict_prefixI' prefix_order.dual_order.strict_trans1)

lemma hyp_port_it_paths:
  assumes "is \<in> it_paths t"
  assumes "f \<in> hyps_along t is"
  shows "hyp_port_path_for t is f \<in> it_paths t"
using assms by (rule it_paths_strict_prefix[OF _ hyp_port_strict_prefix] )

lemma hyp_port_hyps:
  assumes "f \<in> hyps_along t is"
  shows "hyps (iNodeOf (tree_at t (hyp_port_path_for t is f))) (hyp_port_h_for t is f) = Some (inPorts' (iNodeOf (tree_at t (hyp_port_path_for t is f))) ! hyp_port_i_for t is f)"
using hyp_port_for_spec'[OF assms] unfolding hyp_port_path_for_def hyp_port_i_for_def hyp_port_h_for_def by auto

lemma hyp_port_outPort:
  assumes "f \<in> hyps_along t is"
  shows "(hyp_port_h_for t is f) |\<in>| outPorts (iNodeOf (tree_at t (hyp_port_path_for t is f)))"
using hyps_correct[OF hyp_port_hyps[OF assms]]..

lemma hyp_port_eq:
  assumes "f \<in> hyps_along t is"
  shows "f = subst (iSubst (tree_at t (hyp_port_path_for t is f))) (freshen (iAnnot (tree_at t (hyp_port_path_for t is f))) (labelsOut (iNodeOf (tree_at t (hyp_port_path_for t is f))) (hyp_port_h_for t is f)))"
using hyp_port_for_spec'[OF assms] unfolding hyp_port_path_for_def hyp_port_i_for_def hyp_port_h_for_def by auto

definition isidx :: "nat list \<Rightarrow> nat" where "isidx xs = to_nat (Some xs)"
definition v_away :: "nat" where "v_away = to_nat (None :: nat list option)"
lemma isidx_inj[simp]: "isidx xs = isidx ys \<longleftrightarrow> xs = ys"
  unfolding isidx_def by simp
lemma isidx_v_away[simp]: "isidx xs \<noteq> v_away"
  unfolding isidx_def v_away_def by simp

definition mapWithIndex where "mapWithIndex f xs = map (\<lambda> (i,t) . f i t) (List.enumerate 0 xs)"
lemma mapWithIndex_cong [fundef_cong]:
  "xs = ys \<Longrightarrow> (\<And>x i. x \<in> set ys \<Longrightarrow> f i x = g i x) \<Longrightarrow> mapWithIndex f xs = mapWithIndex g ys"
unfolding mapWithIndex_def by (auto simp add: in_set_enumerate_eq)

lemma mapWithIndex_Nil[simp]: "mapWithIndex f [] = []"
  unfolding mapWithIndex_def by simp

lemma length_mapWithIndex[simp]: "length (mapWithIndex f xs) = length xs"
  unfolding mapWithIndex_def by simp

lemma nth_mapWithIndex[simp]: "i < length xs \<Longrightarrow> mapWithIndex f xs ! i = f i (xs ! i)"
  unfolding mapWithIndex_def by (auto simp add: nth_enumerate_eq)

lemma list_all2_mapWithIndex2E:
  assumes "list_all2 P as bs"
  assumes "\<And> i a b . i < length bs \<Longrightarrow> P a b \<Longrightarrow> Q a (f i b)"
  shows "list_all2 Q as (mapWithIndex f bs)"
using assms(1)
by (auto simp add: list_all2_conv_all_nth mapWithIndex_def nth_enumerate_eq intro: assms(2) split: prod.split)

text \<open>The globalize function, which renames all local constants so that they cannot clash with
local constants occurring anywhere else in the tree.\<close>

fun globalize_node :: "nat list \<Rightarrow> ('var \<Rightarrow> 'var) \<Rightarrow> ('form,'rule,'subst,'var) itnode \<Rightarrow>  ('form,'rule,'subst,'var) itnode"  where
  "globalize_node is f (I n p i s) =  I n p (isidx is) (subst_renameLCs f s)"
  | "globalize_node is f (H i s) = H (isidx is) (subst_renameLCs f s)"

fun globalize :: "nat list \<Rightarrow> ('var \<Rightarrow> 'var) \<Rightarrow> ('form,'rule,'subst,'var) itree \<Rightarrow> ('form,'rule,'subst,'var) itree" where
  "globalize is f (RNode r ants) = RNode
    (globalize_node is f r)
    (mapWithIndex (\<lambda> i' t.
      globalize (is@[i'])
                (rerename (a_fresh (inPorts' (iNodeOf (RNode r ants)) ! i'))
                          (iAnnot (RNode r ants)) (isidx is) f)
                t
      ) ants)"

lemma iAnnot'_globalize_node[simp]: "iAnnot' (globalize_node is f n) = isidx is"
  by (cases n) auto

lemma iAnnot_globalize:
  assumes "is' \<in> it_paths (globalize is f t)"
  shows  "iAnnot (tree_at (globalize is f t) is') = isidx (is@is')"
  using assms
  by (induction t arbitrary: f "is" is') (auto elim!: it_paths_RNodeE)

lemma all_local_consts_listed':
  assumes "n \<in> sset nodes"
  assumes "p |\<in>| inPorts n"
  shows "lconsts (a_conc p) \<union> (\<Union>(lconsts ` fset (a_hyps p))) \<subseteq> a_fresh p "
  using assms
  by (auto simp add: nodes_def stream.set_map lconsts_anyP closed_no_lconsts conclusions_closed fmember.rep_eq f_antecedent_def dest!: all_local_consts_listed)

lemma no_local_consts_in_consequences':
  "n \<in> sset nodes \<Longrightarrow> Reg p |\<in>| outPorts n \<Longrightarrow>  lconsts p = {}"
  using no_local_consts_in_consequences
  by (auto simp add: nodes_def lconsts_anyP closed_no_lconsts assumptions_closed stream.set_map f_consequent_def)

lemma iwf_globalize:
  assumes "local_iwf t (\<Gamma> \<turnstile> c)"
  shows "plain_iwf (globalize is f t) (renameLCs f |`| \<Gamma> \<turnstile> renameLCs f c)"
using assms
proof (induction t "\<Gamma> \<turnstile> c" arbitrary: "is" f \<Gamma> c rule: iwf.induct)
  case (iwf n p s i \<Gamma> ants c "is" f)

  note \<open>n \<in> sset nodes\<close>
  moreover
  note \<open>Reg p |\<in>| outPorts n\<close>
  moreover
  { fix i'
    let ?V = "a_fresh (inPorts' n ! i')"
    let ?f' = "rerename ?V i (isidx is) f"
    let ?t = "globalize (is @ [i']) ?f' (ants ! i')"
    let ?ip = "inPorts' n ! i'"
    let ?\<Gamma>' = "(\<lambda>h. subst (subst_renameLCs f s) (freshen (isidx is) (labelsOut n h))) |`| hyps_for n ?ip"
    let ?c' = "subst (subst_renameLCs f s) (freshen (isidx is) (labelsIn n ?ip))"

    assume "i' < length (inPorts' n)"
    hence "(inPorts' n ! i') |\<in>| inPorts n" by (simp add: inPorts_fset_of)

    from \<open>i' < length (inPorts' n)\<close>
    have subset_V: "?V \<subseteq> all_local_vars n"
      unfolding all_local_vars_def
      by (auto simp add: inPorts_fset_of set_conv_nth)

    from \<open>local_fresh_check n i s (\<Gamma> \<turnstile> c)\<close>
    have "freshenLC i ` all_local_vars n \<inter> subst_lconsts s = {}"
      by (rule local_fresh_check.cases) simp
    hence "freshenLC i ` ?V \<inter> subst_lconsts s = {}"
      using subset_V  by auto
    hence rerename_subst: "subst_renameLCs ?f' s = subst_renameLCs f s"
      by (rule rerename_subst_noop)

    from all_local_consts_listed'[OF \<open> n \<in> sset nodes\<close> \<open>(inPorts' n ! i') |\<in>| inPorts n\<close>]
    have subset_conc: "lconsts (a_conc (inPorts' n ! i')) \<subseteq> ?V"
      and subset_hyp': "\<And> hyp . hyp |\<in>| a_hyps (inPorts' n ! i') \<Longrightarrow> lconsts hyp \<subseteq> ?V"
      by (auto simp add: fmember.rep_eq)

    from List.list_all2_nthD[OF \<open>list_all2 _ _ _\<close> \<open>i' < length (inPorts' n)\<close>,simplified]
    have "plain_iwf ?t
           (renameLCs ?f' |`| ((\<lambda>h. subst s (freshen i (labelsOut n h))) |`| hyps_for n ?ip |\<union>|  \<Gamma>) \<turnstile>
            renameLCs ?f' (subst s (freshen i (a_conc ?ip))))"
         by simp
    also have "renameLCs ?f' |`| ((\<lambda>h. subst s (freshen i (labelsOut n h))) |`| hyps_for n ?ip |\<union>|  \<Gamma>)
      = (\<lambda>x. subst (subst_renameLCs ?f' s) (renameLCs ?f' (freshen i (labelsOut n x)))) |`|  hyps_for n ?ip |\<union>| renameLCs ?f' |`| \<Gamma>"
     by (simp add: fimage_fimage fimage_funion comp_def rename_subst)
    also have "renameLCs ?f' |`| \<Gamma> =  renameLCs f |`| \<Gamma>"
    proof(rule fimage_cong[OF refl])
      fix x
      assume "x |\<in>| \<Gamma>"
      with \<open>local_fresh_check n i s (\<Gamma> \<turnstile> c)\<close>
      have "freshenLC i ` all_local_vars n \<inter> lconsts x = {}"
        by (elim local_fresh_check.cases) simp
      hence "freshenLC i ` ?V \<inter> lconsts x = {}"
        using subset_V  by auto
      thus "renameLCs ?f' x = renameLCs f x"
        by (rule rerename_rename_noop)
    qed
    also have "(\<lambda>x. subst (subst_renameLCs ?f' s) (renameLCs ?f' (freshen i (labelsOut n x)))) |`|  hyps_for n ?ip = ?\<Gamma>'"
    proof(rule fimage_cong[OF refl])
      fix hyp
      assume "hyp |\<in>| hyps_for n (inPorts' n ! i')"
      hence "labelsOut n hyp |\<in>| a_hyps (inPorts' n ! i')"
        apply (cases hyp)
        apply (solves simp)
        apply (cases n)
        apply (auto split: if_splits)
        done
      from subset_hyp'[OF this]
      have subset_hyp: "lconsts (labelsOut n hyp) \<subseteq> ?V".

      show "subst (subst_renameLCs ?f' s) (renameLCs ?f' (freshen i (labelsOut n hyp))) =
            subst (subst_renameLCs f s)  (freshen (isidx is) (labelsOut n hyp))"
        apply (simp add: freshen_def rename_rename  rerename_subst)
        apply (rule arg_cong[OF renameLCs_cong])
        apply (auto dest: subsetD[OF subset_hyp])
        done
    qed
    also have "renameLCs ?f' (subst s (freshen i (a_conc ?ip))) = subst (subst_renameLCs ?f' s) (renameLCs ?f' (freshen i (a_conc ?ip)))" by (simp add: rename_subst)
    also have "... = ?c'"
        apply (simp add: freshen_def rename_rename  rerename_subst)
        apply (rule arg_cong[OF renameLCs_cong])
        apply (auto dest: subsetD[OF subset_conc])
        done
    finally
    have "plain_iwf ?t (?\<Gamma>' |\<union>| renameLCs f |`| \<Gamma> \<turnstile> ?c')".
  }
  with list_all2_lengthD[OF \<open>list_all2 _ _ _\<close>]
  have "list_all2
     (\<lambda>ip t. plain_iwf t ((\<lambda>h. subst (subst_renameLCs f s)
       (freshen (isidx is) (labelsOut n h))) |`| hyps_for n ip |\<union>|  renameLCs f |`| \<Gamma> \<turnstile> subst (subst_renameLCs f s) (freshen (isidx is) (labelsIn n ip))))
     (inPorts' n)
     (mapWithIndex (\<lambda> i' t. globalize (is@[i']) (rerename (a_fresh (inPorts' n ! i')) i (isidx is) f) t) ants)"
   by (auto simp add: list_all2_conv_all_nth)
  moreover
  have "no_fresh_check n (isidx is) (subst_renameLCs f s) (renameLCs f |`| \<Gamma> \<turnstile> renameLCs f c)"..
  moreover
  from \<open>n \<in> sset nodes\<close> \<open>Reg p |\<in>| outPorts n\<close>
  have "lconsts p = {}" by (rule no_local_consts_in_consequences')
  with \<open>c = subst s (freshen i p)\<close>
  have "renameLCs f c = subst (subst_renameLCs f s) (freshen (isidx is) p)"
    by (simp add: rename_subst rename_closed freshen_closed)
  ultimately
  show ?case
    unfolding globalize.simps globalize_node.simps iNodeOf.simps iAnnot.simps itnode.sel rose_tree.sel  Let_def
    by (rule iwf.intros(1))
next
  case (iwfH c \<Gamma> s i "is" f)
  from \<open>c |\<notin>| ass_forms\<close>
  have "renameLCs f c |\<notin>| ass_forms"
    using assumptions_closed closed_no_lconsts lconsts_renameLCs rename_closed by fastforce
  moreover
  from \<open>c |\<in>| \<Gamma>\<close>
  have "renameLCs f c |\<in>| renameLCs f |`| \<Gamma>"  by auto
  moreover
  from \<open>c = subst s (freshen i anyP)\<close>
  have "renameLCs f c = subst (subst_renameLCs f s)  (freshen (isidx is) anyP)"
    by (metis freshen_closed lconsts_anyP rename_closed rename_subst)
  ultimately
  show "plain_iwf (globalize is f (HNode i s [])) (renameLCs f |`| \<Gamma> \<turnstile> renameLCs f c)"
    unfolding globalize.simps globalize_node.simps  mapWithIndex_Nil  Let_def
    by (rule iwf.intros(2))
qed

definition fresh_at where
  "fresh_at t xs =
   (case rev xs of [] \<Rightarrow> {}
                 | (i#is') \<Rightarrow> freshenLC (iAnnot (tree_at t (rev is'))) ` (a_fresh (inPorts' (iNodeOf (tree_at t (rev is'))) ! i)))"

lemma fresh_at_Nil[simp]:
  "fresh_at t [] = {}"
  unfolding fresh_at_def by simp

lemma fresh_at_snoc[simp]:
  "fresh_at t (is@[i]) = freshenLC (iAnnot (tree_at t is)) ` (a_fresh (inPorts' (iNodeOf (tree_at t is)) ! i))"
  unfolding fresh_at_def by simp

lemma fresh_at_def':
  "fresh_at t is =
   (if is = [] then {}
    else freshenLC (iAnnot (tree_at t (butlast is))) ` (a_fresh (inPorts' (iNodeOf (tree_at t (butlast is))) ! last is)))"
  unfolding fresh_at_def by (auto split: list.split)

lemma fresh_at_Cons[simp]:
  "fresh_at t (i#is) = (if is = [] then freshenLC (iAnnot t) ` (a_fresh (inPorts' (iNodeOf t) ! i)) else (let t' = iAnts t ! i in fresh_at t' is))"
  unfolding fresh_at_def'
  by (auto simp add: Let_def)

definition fresh_at_path where
  "fresh_at_path t is = \<Union>(fresh_at t ` set (prefixes is))"

lemma fresh_at_path_Nil[simp]:
  "fresh_at_path t [] = {}"
  unfolding fresh_at_path_def by simp

lemma fresh_at_path_Cons[simp]:
  "fresh_at_path t (i#is) = fresh_at t [i] \<union> fresh_at_path (iAnts t ! i) is"
  unfolding fresh_at_path_def
  by (fastforce split: if_splits)

lemma globalize_local_consts:
  assumes "is' \<in> it_paths (globalize is f t)"
  shows "subst_lconsts (iSubst (tree_at (globalize is f t) is')) \<subseteq>
    fresh_at_path (globalize is f t) is' \<union> range f"
  using assms
  apply (induction "is" f t  arbitrary: is' rule:globalize.induct)
  apply (rename_tac "is" f r ants is')
  apply (case_tac r)
   apply (auto simp add: subst_lconsts_subst_renameLCs  elim!: it_paths_RNodeE)
   apply (solves \<open>force dest!: subsetD[OF range_rerename]\<close>)
  apply (solves \<open>force dest!: subsetD[OF range_rerename]\<close>)
  done

lemma iwf_globalize':
  assumes "local_iwf t ent"
  assumes "\<And> x. x |\<in>| fst ent \<Longrightarrow> closed x"
  assumes "closed (snd ent)"
  shows "plain_iwf (globalize is (freshenLC v_away) t) ent"
using assms
proof(induction ent rule: prod.induct)
  case (Pair \<Gamma> c)
  have "plain_iwf (globalize is (freshenLC v_away) t) (renameLCs (freshenLC v_away) |`| \<Gamma> \<turnstile> renameLCs (freshenLC v_away) c)"
    by (rule iwf_globalize[OF Pair(1)])
  also
  from Pair(3) have "closed c" by simp
  hence "renameLCs (freshenLC v_away) c = c" by (simp add: closed_no_lconsts rename_closed)
  also
  from Pair(2)
  have "renameLCs (freshenLC v_away) |`| \<Gamma> = \<Gamma>"
    by (auto simp add: closed_no_lconsts rename_closed fmember.rep_eq image_iff)
  finally show ?case.
qed
end

end


(*  Title:      statecharts/SA/Expr.thy

    Author:     Steffen Helke, Software Engineering Group
    Copyright   2010 Technische Universitaet Berlin
*)

section \<open>Label Expressions\<close>
theory Expr
imports Update
begin

no_notation not ("NOT")

datatype ('s,'e)expr = true
                        | In 's
                        | En 'e
                        | NOT "('s,'e)expr"
                        | And "('s,'e)expr" "('s,'e)expr"
                        | Or  "('s,'e)expr" "('s,'e)expr"

type_synonym 'd guard = "('d data) => bool"
type_synonym ('e,'d)action = "('e set * 'd pupdate)"
type_synonym ('s,'e,'d)label = "(('s,'e)expr * 'd guard * ('e,'d)action)"
type_synonym ('s,'e,'d)trans = "('s * ('s,'e,'d)label * 's)"

primrec
   eval_expr :: "[('s set * 'e set), ('s,'e)expr] \<Rightarrow> bool" where
     "eval_expr sc true          = True"
   | "eval_expr sc (En ev)       = (ev \<in> snd sc)"
   | "eval_expr sc (In st)       = (st \<in> fst sc)"
   | "eval_expr sc (NOT e1)      = (\<not> (eval_expr sc e1))"
   | "eval_expr sc (And e1 e2)   = ((eval_expr sc e1) \<and> (eval_expr sc e2))"
   | "eval_expr sc (Or  e1 e2)   = ((eval_expr sc e1) \<or> (eval_expr sc e2))"

primrec
   ExprEvents :: "('s,'e)expr \<Rightarrow> 'e set" where
      "ExprEvents true        = {}"
   |  "ExprEvents (En ev)     = {ev}"
   |  "ExprEvents (In st)     = {}"
   |  "ExprEvents (NOT e)     = (ExprEvents e)"
   |  "ExprEvents (And e1 e2) = ((ExprEvents e1) \<union> (ExprEvents e2))"
   |  "ExprEvents (Or  e1 e2) = ((ExprEvents e1) \<union> (ExprEvents e2))"

(* atomar propositions for Sequential Automata, will be necessary for CTL-interpretation *)

datatype ('s, 'e, dead 'd)atomar =
                          TRUE
                          | FALSE
                          | IN 's
                          | EN 'e
                          | VAL "'d data => bool"

definition
  source     :: "('s,'e,'d)trans => 's" where
  "source t  = fst t"

definition
   Source     :: "('s,'e,'d)trans set => 's set" where
  "Source T == source ` T"

definition
   target     :: "('s,'e,'d)trans => 's" where
  "target t  = snd(snd t)"

definition
   Target     :: "('s,'e,'d)trans set => 's set" where
  "Target T = target ` T"

definition
   label      :: "('s,'e,'d)trans => ('s,'e,'d)label" where
  "label t  = fst (snd t)"

definition
   Label      :: "('s,'e,'d)trans set => ('s,'e,'d)label set" where
  "Label T = label ` T"

definition
   expr       :: "('s,'e,'d)label => ('s,'e)expr" where
  "expr  = fst"

definition
   action     :: "('s,'e,'d)label  => ('e,'d)action" where
  "action = snd o snd"

definition
   Action     :: "('s,'e,'d)label set => ('e,'d)action set" where
  "Action L = action ` L"

definition
   pupdate     :: "('s,'e,'d)label => 'd pupdate" where
  "pupdate   = snd o action"

definition
  PUpdate     :: "('s,'e,'d)label set => ('d pupdate) set" where
  "PUpdate L = pupdate ` L"

definition
   actevent   :: "('s,'e,'d)label => 'e set" where
  "actevent  = fst o action"

definition
   Actevent   :: "('s,'e,'d)label set => ('e set) set" where
  "Actevent L = actevent ` L"

definition
   guard      :: "('s,'e,'d)label  => 'd guard" where
  "guard = fst o snd"

definition
   Guard      :: "('s,'e,'d)label set => ('d guard) set" where
  "Guard L = guard ` L"

definition
   defaultexpr :: "('s,'e)expr" where
  "defaultexpr = true"

definition
   defaultaction :: "('e,'d)action" where
  "defaultaction = ({},DefaultPUpdate)"

definition
   defaultguard :: "('d guard)" where
  "defaultguard = (\<lambda> d. True)"

definition
   defaultlabel :: "('s,'e,'d)label" where
  "defaultlabel = (defaultexpr, defaultguard, defaultaction)"

definition
   eval :: "[('s set * 'e set * 'd data), ('s,'e,'d)label] => bool"
                                                       ("_ |= _" [91,90]90) where
  "eval scd l = (let (s,e,d) = scd
                 in
                    ((eval_expr (s,e) (expr l)) \<and> ((guard l) d)))"

lemma Source_EmptySet [simp]:
 "Source {} = {}"
by (unfold Source_def, auto)

lemma Target_EmptySet [simp]:
 "Target {} = {}"
by (unfold Target_def, auto)

lemma Label_EmptySet [simp]:
 "Label {} = {}"
by (unfold Label_def, auto)

lemma Action_EmptySet [simp]:
 "Action {} = {}"
by (unfold Action_def, auto)

lemma PUpdate_EmptySet [simp]:
 "PUpdate {} = {}"
by (unfold PUpdate_def, auto)

lemma Actevent_EmptySet [simp]:
 "Actevent {} = {}"
by (unfold Actevent_def, auto)

lemma Union_Actevent_subset:
  "\<lbrakk> m \<in> M; ((\<Union> (Actevent (Label (Union M)))) \<subseteq> (N::'a set)) \<rbrakk> \<Longrightarrow>
   ((\<Union> (Actevent (Label m))) \<subseteq> N)"
by (unfold Actevent_def Label_def, auto)

lemma action_select [simp]:
 "action (a,b,c) = c"
by (unfold action_def, auto)

lemma label_select [simp]:
 "label (a,b,c) = b"
by (unfold label_def, auto)

lemma target_select [simp]:
 "target (a,b,c) = c"
by (unfold target_def, auto)

lemma actevent_select [simp]:
 "actevent (a,b,(c,d)) = c"
by (unfold actevent_def, auto)

lemma pupdate_select [simp]:
 "pupdate (a,b,c,d) = d"
by (unfold pupdate_def, auto)

lemma source_select [simp]:
 "source (a,b) = a"
by (unfold source_def, auto)

lemma finite_PUpdate [simp]:
 "finite S \<Longrightarrow> finite(PUpdate S)"
by (unfold PUpdate_def, auto)

lemma finite_Label [simp]:
 "finite S \<Longrightarrow> finite(Label S)"
by (unfold Label_def, auto)

lemma fst_defaultaction [simp]:
 "fst defaultaction = {}"
by (unfold defaultaction_def, auto)

lemma action_defaultlabel [simp]:
 "(action defaultlabel) = defaultaction"
by (unfold defaultlabel_def action_def, auto)

lemma fst_defaultlabel [simp]:
 "(fst defaultlabel) = defaultexpr"
by (unfold defaultlabel_def, auto)

lemma ExprEvents_defaultexpr [simp]:
 "(ExprEvents defaultexpr) = {}"
by (unfold defaultexpr_def, auto)

lemma defaultlabel_defaultexpr [simp]:
 "expr defaultlabel = defaultexpr"
by (unfold defaultlabel_def expr_def, auto)

lemma target_Target [simp]:
  "t \<in> T \<Longrightarrow> target t \<in> Target T"
by (unfold Target_def, auto)

lemma Source_union : "Source s \<union> Source t = Source (s \<union> t)"
apply (unfold Source_def)
apply auto
done

lemma Target_union : "Target s \<union> Target t = Target (s \<union> t)"
apply (unfold Target_def)
apply auto
done

end


section "Soundness of the standard Hoare logic"

theory StdLogicSoundness imports StdLogic WhileLangLemmas begin

theorem Hoare_soundness:
  "hoare P c Q \<Longrightarrow> hoare_sem P c Q"
proof (induct P c Q rule: hoare.induct)
  case (h_while P x p R)
  then show ?case
    apply (clarsimp simp only: hoare_sem_def)
    apply (rename_tac a b)
    apply (erule_tac P="P (a, b)" in rev_mp)
    apply (erule wfP_induct)
    apply clarsimp
    apply (simp (no_asm) add: terminates_While)
    apply (simp (no_asm) add: terminates_If terminates_Seq terminates_Skip)
    by blast
next
  case (h_weaken P P' p Q' Q)
  then show ?case
    apply (clarsimp simp: hoare_sem_def)
    apply (rename_tac a b)
    apply (drule_tac x=a and y=b in meta_spec2)
    by fastforce
qed (fastforce simp: hoare_sem_def terminates_Skip terminates_Assign
                     terminates_Print terminates_Seq terminates_If)+

end


(*  Title:      HOL/HOLCF/Tutorial/Domain_ex.thy
    Author:     Brian Huffman
*)

section \<open>Domain package examples\<close>

theory Domain_ex
imports HOLCF
begin

text \<open>Domain constructors are strict by default.\<close>

domain d1 = d1a | d1b "d1" "d1"

lemma "d1b\<cdot>\<bottom>\<cdot>y = \<bottom>" by simp

text \<open>Constructors can be made lazy using the \<open>lazy\<close> keyword.\<close>

domain d2 = d2a | d2b (lazy "d2")

lemma "d2b\<cdot>x \<noteq> \<bottom>" by simp

text \<open>Strict and lazy arguments may be mixed arbitrarily.\<close>

domain d3 = d3a | d3b (lazy "d2") "d2"

lemma "P (d3b\<cdot>x\<cdot>y = \<bottom>) \<longleftrightarrow> P (y = \<bottom>)" by simp

text \<open>Selectors can be used with strict or lazy constructor arguments.\<close>

domain d4 = d4a | d4b (lazy d4b_left :: "d2") (d4b_right :: "d2")

lemma "y \<noteq> \<bottom> \<Longrightarrow> d4b_left\<cdot>(d4b\<cdot>x\<cdot>y) = x" by simp

text \<open>Mixfix declarations can be given for data constructors.\<close>

domain d5 = d5a | d5b (lazy "d5") "d5" (infixl ":#:" 70)

lemma "d5a \<noteq> x :#: y :#: z" by simp

text \<open>Mixfix declarations can also be given for type constructors.\<close>

domain ('a, 'b) lazypair (infixl ":*:" 25) =
  lpair (lazy lfst :: 'a) (lazy lsnd :: 'b) (infixl ":*:" 75)

lemma "\<forall>p::('a :*: 'b). p \<sqsubseteq> lfst\<cdot>p :*: lsnd\<cdot>p"
by (rule allI, case_tac p, simp_all)

text \<open>Non-recursive constructor arguments can have arbitrary types.\<close>

domain ('a, 'b) d6 = d6 "int lift" "'a \<oplus> 'b u" (lazy "('a :*: 'b) \<times> ('b \<rightarrow> 'a)")

text \<open>
  Indirect recusion is allowed for sums, products, lifting, and the
  continuous function space.  However, the domain package does not
  generate an induction rule in terms of the constructors.
\<close>

domain 'a d7 = d7a "'a d7 \<oplus> int lift" | d7b "'a \<otimes> 'a d7" | d7c (lazy "'a d7 \<rightarrow> 'a")
  \<comment> "Indirect recursion detected, skipping proofs of (co)induction rules"

text \<open>Note that \<open>d7.induct\<close> is absent.\<close>

text \<open>
  Indirect recursion is also allowed using previously-defined datatypes.
\<close>

domain 'a slist = SNil | SCons 'a "'a slist"

domain 'a stree = STip | SBranch "'a stree slist"

text \<open>Mutually-recursive datatypes can be defined using the \<open>and\<close> keyword.\<close>

domain d8 = d8a | d8b "d9" and d9 = d9a | d9b (lazy "d8")

text \<open>Non-regular recursion is not allowed.\<close>
(*
domain ('a, 'b) altlist = ANil | ACons 'a "('b, 'a) altlist"
  -- "illegal direct recursion with different arguments"
domain 'a nest = Nest1 'a | Nest2 "'a nest nest"
  -- "illegal direct recursion with different arguments"
*)

text \<open>
  Mutually-recursive datatypes must have all the same type arguments,
  not necessarily in the same order.
\<close>

domain ('a, 'b) list1 = Nil1 | Cons1 'a "('b, 'a) list2"
   and ('b, 'a) list2 = Nil2 | Cons2 'b "('a, 'b) list1"

text \<open>Induction rules for flat datatypes have no admissibility side-condition.\<close>

domain 'a flattree = Tip | Branch "'a flattree" "'a flattree"

lemma "\<lbrakk>P \<bottom>; P Tip; \<And>x y. \<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>; P x; P y\<rbrakk> \<Longrightarrow> P (Branch\<cdot>x\<cdot>y)\<rbrakk> \<Longrightarrow> P x"
by (rule flattree.induct) \<comment> "no admissibility requirement"

text \<open>Trivial datatypes will produce a warning message.\<close>

domain triv = Triv triv triv
  \<comment> "domain \<open>Domain_ex.triv\<close> is empty!"

lemma "(x::triv) = \<bottom>" by (induct x, simp_all)

text \<open>Lazy constructor arguments may have unpointed types.\<close>

domain natlist = nnil | ncons (lazy "nat discr") natlist

text \<open>Class constraints may be given for type parameters on the LHS.\<close>

domain ('a::predomain) box = Box (lazy 'a)

domain ('a::countable) stream = snil | scons (lazy "'a discr") "'a stream"

subsection \<open>Generated constants and theorems\<close>

domain 'a tree = Leaf (lazy 'a) | Node (left :: "'a tree") (right :: "'a tree")

lemmas tree_abs_bottom_iff =
  iso.abs_bottom_iff [OF iso.intro [OF tree.abs_iso tree.rep_iso]]

text \<open>Rules about ismorphism\<close>
term tree_rep
term tree_abs
thm tree.rep_iso
thm tree.abs_iso
thm tree.iso_rews

text \<open>Rules about constructors\<close>
term Leaf
term Node
thm Leaf_def Node_def
thm tree.nchotomy
thm tree.exhaust
thm tree.compacts
thm tree.con_rews
thm tree.dist_les
thm tree.dist_eqs
thm tree.inverts
thm tree.injects

text \<open>Rules about case combinator\<close>
term tree_case
thm tree.tree_case_def
thm tree.case_rews

text \<open>Rules about selectors\<close>
term left
term right
thm tree.sel_rews

text \<open>Rules about discriminators\<close>
term is_Leaf
term is_Node
thm tree.dis_rews

text \<open>Rules about monadic pattern match combinators\<close>
term match_Leaf
term match_Node
thm tree.match_rews

text \<open>Rules about take function\<close>
term tree_take
thm tree.take_def
thm tree.take_0
thm tree.take_Suc
thm tree.take_rews
thm tree.chain_take
thm tree.take_take
thm tree.deflation_take
thm tree.take_below
thm tree.take_lemma
thm tree.lub_take
thm tree.reach
thm tree.finite_induct

text \<open>Rules about finiteness predicate\<close>
term tree_finite
thm tree.finite_def
thm tree.finite (* only generated for flat datatypes *)

text \<open>Rules about bisimulation predicate\<close>
term tree_bisim
thm tree.bisim_def
thm tree.coinduct

text \<open>Induction rule\<close>
thm tree.induct

subsection \<open>Known bugs\<close>

text \<open>Declaring a mixfix with spaces causes some strange parse errors.\<close>
(*
domain xx = xx ("x y")
  -- "Inner syntax error: unexpected end of input"
*)

end


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

consts weakBisimSubst :: "(pi \<times> pi) set"
abbreviation weakEarlyBisimSubstJudge (infixr "\<approx>\<^sup>s" 65) where "P \<approx>\<^sup>s Q \<equiv> (P, Q) \<in> (substClosed weakBisim)"

lemma congBisim:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<approx>\<^sup>s Q"

  shows "P \<approx> Q"
using assms substClosedSubset
by blast

lemma strongBisimWeakBisim:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<sim>\<^sup>s Q"

  shows "P \<approx>\<^sup>s Q"
using assms
by(auto simp add: substClosed_def intro: strongBisimWeakBisim)

lemma eqvt:
  shows "eqvt (substClosed weakBisim)"
by(rule eqvtSubstClosed[OF Weak_Early_Bisim.eqvt])

lemma eqvtI[eqvt]:
  fixes P :: pi
  and   Q :: pi
  and   perm :: "name prm"

  assumes "P \<approx>\<^sup>s Q"

  shows "(perm \<bullet> P) \<approx>\<^sup>s (perm \<bullet> Q)"
using assms
by(rule eqvtRelI[OF eqvt])

lemma reflexive:
  fixes P :: pi

  shows "P \<approx>\<^sup>s P"
by(force simp add: substClosed_def intro: Weak_Early_Bisim.reflexive)

lemma symetric:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<approx>\<^sup>s Q"

  shows "Q \<approx>\<^sup>s P"
using assms
by(force simp add: substClosed_def intro: Weak_Early_Bisim.symetric)

lemma partUnfold:
  fixes P :: pi
  and   Q :: pi
  and   s :: "(name \<times> name) list"

  assumes "P \<approx>\<^sup>s Q"

  shows "P[<s>] \<approx>\<^sup>s Q[<s>]"
using assms
proof(auto simp add: substClosed_def)
  fix s'
  assume "\<forall>s. P[<s>] \<approx> Q[<s>]"
  hence "P[<(s@s')>] \<approx> Q[<(s@s')>]" by blast
  moreover have "P[<(s@s')>] = (P[<s>])[<s'>]"
    by(induct s', auto)
  moreover have "Q[<(s@s')>] = (Q[<s>])[<s'>]"
    by(induct s', auto)

  ultimately show "(P[<s>])[<s'>] \<approx> (Q[<s>])[<s'>]"
    by simp
qed

end