(*
    Author: Asta Halkjær From, DTU Compute, 2019
    Contributors: Alexander Birch Jensen, Anders Schlichtkrull & Jørgen Villadsen
    See also the Natural Deduction Assistant: https://nadea.compute.dtu.dk/
*)

section \<open>Sequent Calculus\<close>

theory Sequent imports Tableau begin

inductive SC :: \<open>('a, 'b) form list \<Rightarrow> bool\<close> (\<open>\<turnstile> _\<close> 0) where
  Basic: \<open>\<turnstile> Pred i l # Neg (Pred i l) # G\<close>
| BasicNegFF: \<open>\<turnstile> Neg \<bottom> # G\<close>
| BasicTT: \<open>\<turnstile> \<top> # G\<close>
| AlphaNegNeg: \<open>\<turnstile> A # G \<Longrightarrow> \<turnstile> Neg (Neg A) # G\<close>
| AlphaNegAnd: \<open>\<turnstile> Neg A # Neg B # G \<Longrightarrow> \<turnstile> Neg (And A B) # G\<close>
| AlphaOr: \<open>\<turnstile> A # B # G \<Longrightarrow> \<turnstile> Or A B # G\<close>
| AlphaImpl: \<open>\<turnstile> Neg A # B # G \<Longrightarrow> \<turnstile> Impl A B # G\<close>
| BetaAnd: \<open>\<turnstile> A # G \<Longrightarrow> \<turnstile> B # G \<Longrightarrow> \<turnstile> And A B # G\<close>
| BetaNegOr: \<open>\<turnstile> Neg A # G \<Longrightarrow> \<turnstile> Neg B # G \<Longrightarrow> \<turnstile> Neg (Or A B) # G\<close>
| BetaNegImpl: \<open>\<turnstile> A # G \<Longrightarrow> \<turnstile> Neg B # G \<Longrightarrow> \<turnstile> Neg (Impl A B) # G\<close>
| GammaExists: \<open>\<turnstile> subst A t 0 # G \<Longrightarrow> \<turnstile> Exists A # G\<close>
| GammaNegForall: \<open>\<turnstile> Neg (subst A t 0) # G \<Longrightarrow> \<turnstile> Neg (Forall A) # G\<close>
| DeltaForall: \<open>\<turnstile> subst A (App n []) 0 # G \<Longrightarrow> news n (A # G) \<Longrightarrow> \<turnstile> Forall A # G\<close>
| DeltaNegExists: \<open>\<turnstile> Neg (subst A (App n []) 0) # G \<Longrightarrow> news n (A # G) \<Longrightarrow> \<turnstile> Neg (Exists A) # G\<close>
| Order: \<open>\<turnstile> G \<Longrightarrow> set G = set G' \<Longrightarrow> \<turnstile> G'\<close>

lemma Shift: \<open>\<turnstile> rotate1 G \<Longrightarrow> \<turnstile> G\<close>
  by (simp add: Order)

lemma Swap: \<open>\<turnstile> B # A # G \<Longrightarrow> \<turnstile> A # B # G\<close>
  by (simp add: Order insert_commute)

lemma \<open>\<turnstile> [Neg (Pred ''A'' []), Pred ''A'' []]\<close>
  by (rule Shift, simp) (rule Basic)

lemma \<open>\<turnstile> [And (Pred ''A'' []) (Pred ''B'' []), Neg (And (Pred ''B'' []) (Pred ''A'' []))]\<close>
  apply (rule BetaAnd)
   apply (rule Swap)
   apply (rule AlphaNegAnd)
   apply (rule Shift, simp, rule Swap)
   apply (rule Basic)
  apply (rule Swap)
  apply (rule AlphaNegAnd)
  apply (rule Shift, rule Shift, simp)
  apply (rule Basic)
  done

subsection \<open>Soundness\<close>

lemma SC_soundness: \<open>\<turnstile> G \<Longrightarrow> \<exists>p \<in> set G. eval e f g p\<close>
proof (induct G arbitrary: f rule: SC.induct)
  case (DeltaForall A n G)
  then consider
    \<open>\<forall>x. eval e (f(n := \<lambda>w. x)) g (subst A (App n []) 0)\<close> |
    \<open>\<exists>x. \<exists>p \<in> set G. eval e (f(n := \<lambda>w. x)) g p\<close>
    by fastforce
  then show ?case
  proof cases
    case 1
    then have \<open>\<forall>x. eval (shift e 0 x) (f(n := \<lambda>w. x)) g A\<close>
      by simp
    then have \<open>\<forall>x. eval (shift e 0 x) f g A\<close>
      using \<open>news n (A # G)\<close> by simp
    then show ?thesis
      by simp
  next
    case 2
    then have \<open>\<exists>p \<in> set G. eval e f g p\<close>
      using \<open>news n (A # G)\<close> using Ball_set insert_iff list.set(2) upd_lemma by metis
    then show ?thesis
      by simp
  qed
next
  case (DeltaNegExists A n G)
  then consider
    \<open>\<forall>x. eval e (f(n := \<lambda>w. x)) g (Neg (subst A (App n []) 0))\<close> |
    \<open>\<exists>x. \<exists>p \<in> set G. eval e (f(n := \<lambda>w. x)) g p\<close>
    by fastforce
  then show ?case
  proof cases
    case 1
    then have \<open>\<forall>x. eval (shift e 0 x) (f(n := \<lambda>w. x)) g (Neg A)\<close>
      by simp
    then have \<open>\<forall>x. eval (shift e 0 x) f g (Neg A)\<close>
      using \<open>news n (A # G)\<close> by simp
    then show ?thesis
      by simp
  next
    case 2
    then have \<open>\<exists>p \<in> set G. eval e f g p\<close>
      using \<open>news n (A # G)\<close> using Ball_set insert_iff list.set(2) upd_lemma by metis
    then show ?thesis
      by simp
  qed
qed auto

subsection \<open>Tableau Calculus Equivalence\<close>

fun compl :: \<open>('a, 'b) form \<Rightarrow> ('a, 'b) form\<close> where
  \<open>compl (Neg p) = p\<close>
| \<open>compl p = Neg p\<close>

lemma compl: \<open>compl p = Neg p \<or> (\<exists>q. compl p = q \<and> p = Neg q)\<close>
  by (cases p rule: compl.cases) simp_all

lemma new_compl: \<open>new n p \<Longrightarrow> new n (compl p)\<close>
  by (cases p rule: compl.cases) simp_all

lemma news_compl: \<open>news n G \<Longrightarrow> news n (map compl G)\<close>
  using new_compl by (induct G) fastforce+

theorem TC_SC: \<open>\<stileturn> G \<Longrightarrow> \<turnstile> map compl G\<close>
proof (induct G rule: TC.induct)
  case (Basic i l G)
  then show ?case
    using SC.Basic Swap by fastforce
next
  case (AlphaNegNeg A G)
  then show ?case
    using SC.AlphaNegNeg compl by (metis compl.simps(1) list.simps(9))
next
  case (AlphaAnd A B G)
  then have *: \<open>\<turnstile> compl A # compl B # map compl G\<close>
    by simp
  then have \<open>\<turnstile> Neg A # Neg B # map compl G\<close>
    using compl AlphaNegNeg Swap by metis
  then show ?case
    using AlphaNegAnd by simp
next
  case (AlphaNegImpl A B G)
  then have \<open>\<turnstile> compl A # B # map compl G\<close>
    by simp
  then have \<open>\<turnstile> Neg A # B # map compl G\<close>
    using compl AlphaNegNeg by metis
  then show ?case
    using AlphaImpl by simp
next
  case (BetaOr A G B)
  then have \<open>\<turnstile> compl A # map compl G\<close> \<open>\<turnstile> compl B # map compl G\<close>
    by simp_all
  then have \<open>\<turnstile> Neg A # map compl G\<close> \<open>\<turnstile> Neg B # map compl G\<close>
    using compl AlphaNegNeg by metis+
  then show ?case
    using BetaNegOr by simp
next
  case (BetaImpl A G B)
  then have \<open>\<turnstile> A # map compl G\<close> \<open>\<turnstile> compl B # map compl G\<close>
    by simp_all
  then have \<open>\<turnstile> A # map compl G\<close> \<open>\<turnstile> Neg B # map compl G\<close>
    by - (assumption, metis compl AlphaNegNeg)
  then have \<open>\<turnstile> Neg (Impl A B) # map compl G\<close>
    using BetaNegImpl by blast
  then have \<open>\<turnstile> compl (Impl A B) # map compl G\<close>
    using \<open>\<turnstile> A # map compl G\<close> compl by simp
  then show ?case
    by simp
next
  case (GammaForall A t G)
  then have \<open>\<turnstile> compl (subst A t 0) # map compl G\<close>
    by simp
  then have \<open>\<turnstile> Neg (subst A t 0) # map compl G\<close>
    using compl AlphaNegNeg by metis
  then show ?case
    using GammaNegForall by simp
next
  case (DeltaExists A n G)
  then have \<open>\<turnstile> compl (subst A (App n []) 0) # map compl G\<close>
    by simp
  then have \<open>\<turnstile> Neg (subst A (App n []) 0) # map compl G\<close>
    using compl AlphaNegNeg by metis
  moreover have \<open>news n (A # map compl G)\<close>
    using DeltaExists news_compl by fastforce
  ultimately show ?case
    using DeltaNegExists by simp
next
  case (DeltaNegForall A n G)
  then have \<open>\<turnstile> subst A (App n []) 0 # map compl G\<close>
    by simp
  moreover have \<open>news n (A # map compl G)\<close>
    using DeltaNegForall news_compl by fastforce
  ultimately show ?case
    using DeltaForall by simp
qed (simp_all add: SC.intros)

subsection \<open>Completeness\<close>

theorem SC_completeness:
  fixes p :: \<open>(nat, nat) form\<close>
  assumes \<open>\<forall>(e :: nat \<Rightarrow> nat hterm) f g. list_all (eval e f g) ps \<longrightarrow> eval e f g p\<close>
  shows \<open>\<turnstile> p # map compl ps\<close>
proof -
  have \<open>\<stileturn> Neg p # ps\<close>
    using assms tableau_completeness unfolding tableauproof_def by simp
  then show ?thesis
    using TC_SC by fastforce
qed

corollary
  fixes p :: \<open>(nat, nat) form\<close>
  assumes \<open>\<forall>(e :: nat \<Rightarrow> nat hterm) f g. eval e f g p\<close>
  shows \<open>\<turnstile> [p]\<close>
  using assms SC_completeness list.map(1) by metis

end


(*  Title:      Jinja/DefAss.thy
    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

section \<open>Definite assignment\<close>

theory DefAss imports BigStep begin

subsection "Hypersets"

type_synonym 'a hyperset = "'a set option"

definition hyperUn :: "'a hyperset \<Rightarrow> 'a hyperset \<Rightarrow> 'a hyperset"   (infixl "\<squnion>" 65)
where
  "A \<squnion> B  \<equiv>  case A of None \<Rightarrow> None
                 | \<lfloor>A\<rfloor> \<Rightarrow> (case B of None \<Rightarrow> None | \<lfloor>B\<rfloor> \<Rightarrow> \<lfloor>A \<union> B\<rfloor>)"

definition hyperInt :: "'a hyperset \<Rightarrow> 'a hyperset \<Rightarrow> 'a hyperset"   (infixl "\<sqinter>" 70)
where
  "A \<sqinter> B  \<equiv>  case A of None \<Rightarrow> B
                 | \<lfloor>A\<rfloor> \<Rightarrow> (case B of None \<Rightarrow> \<lfloor>A\<rfloor> | \<lfloor>B\<rfloor> \<Rightarrow> \<lfloor>A \<inter> B\<rfloor>)"

definition hyperDiff1 :: "'a hyperset \<Rightarrow> 'a \<Rightarrow> 'a hyperset"   (infixl "\<ominus>" 65)
where
  "A \<ominus> a  \<equiv>  case A of None \<Rightarrow> None | \<lfloor>A\<rfloor> \<Rightarrow> \<lfloor>A - {a}\<rfloor>"

definition hyper_isin :: "'a \<Rightarrow> 'a hyperset \<Rightarrow> bool"   (infix "\<in>\<in>" 50)
where
  "a \<in>\<in> A  \<equiv>  case A of None \<Rightarrow> True | \<lfloor>A\<rfloor> \<Rightarrow> a \<in> A"

definition hyper_subset :: "'a hyperset \<Rightarrow> 'a hyperset \<Rightarrow> bool"   (infix "\<sqsubseteq>" 50)
where
  "A \<sqsubseteq> B  \<equiv>  case B of None \<Rightarrow> True
                 | \<lfloor>B\<rfloor> \<Rightarrow> (case A of None \<Rightarrow> False | \<lfloor>A\<rfloor> \<Rightarrow> A \<subseteq> B)"

lemmas hyperset_defs =
 hyperUn_def hyperInt_def hyperDiff1_def hyper_isin_def hyper_subset_def

lemma [simp]: "\<lfloor>A\<rfloor> \<squnion> \<lfloor>B\<rfloor> = \<lfloor>A \<union> B\<rfloor> \<and> \<lfloor>A\<rfloor> \<ominus> a = \<lfloor>A - {a}\<rfloor>"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma [simp]: "None \<squnion> A = None \<and> A \<squnion> None = None"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma [simp]: "a \<in>\<in> None \<and> None \<ominus> a = None"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma hyperUn_assoc: "(A \<squnion> B) \<squnion> C = A \<squnion> (B \<squnion> C)"
(*<*)by(simp add:hyperset_defs Un_assoc)(*>*)

lemma hyper_insert_comm: "A \<squnion> \<lfloor>{a}\<rfloor> = \<lfloor>{a}\<rfloor> \<squnion> A \<and> A \<squnion> (\<lfloor>{a}\<rfloor> \<squnion> B) = \<lfloor>{a}\<rfloor> \<squnion> (A \<squnion> B)"
(*<*)by(simp add:hyperset_defs)(*>*)

subsection "Definite assignment"

primrec
  \  :: "'a exp \<Rightarrow> 'a hyperset"
  and \s :: "'a exp list \<Rightarrow> 'a hyperset"
where
  "\ (new C) = \<lfloor>{}\<rfloor>"
| "\ (Cast C e) = \ e"
| "\ (Val v) = \<lfloor>{}\<rfloor>"
| "\ (e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2) = \ e\<^sub>1 \<squnion> \ e\<^sub>2"
| "\ (Var V) = \<lfloor>{}\<rfloor>"
| "\ (LAss V e) = \<lfloor>{V}\<rfloor> \<squnion> \ e"
| "\ (e\<bullet>F{D}) = \ e"
| "\ (e\<^sub>1\<bullet>F{D}:=e\<^sub>2) = \ e\<^sub>1 \<squnion> \ e\<^sub>2"
| "\ (e\<bullet>M(es)) = \ e \<squnion> \s es"
| "\ ({V:T; e}) = \ e \<ominus> V"
| "\ (e\<^sub>1;;e\<^sub>2) = \ e\<^sub>1 \<squnion> \ e\<^sub>2"
| "\ (if (e) e\<^sub>1 else e\<^sub>2) =  \ e \<squnion> (\ e\<^sub>1 \<sqinter> \ e\<^sub>2)"
| "\ (while (b) e) = \ b"
| "\ (throw e) = None"
| "\ (try e\<^sub>1 catch(C V) e\<^sub>2) = \ e\<^sub>1 \<sqinter> (\ e\<^sub>2 \<ominus> V)"

| "\s ([]) = \<lfloor>{}\<rfloor>"
| "\s (e#es) = \ e \<squnion> \s es"

primrec
  \<D>  :: "'a exp \<Rightarrow> 'a hyperset \<Rightarrow> bool"
  and \<D>s :: "'a exp list \<Rightarrow> 'a hyperset \<Rightarrow> bool"
where
  "\<D> (new C) A = True"
| "\<D> (Cast C e) A = \<D> e A"
| "\<D> (Val v) A = True"
| "\<D> (e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2) A = (\<D> e\<^sub>1 A \<and> \<D> e\<^sub>2 (A \<squnion> \ e\<^sub>1))"
| "\<D> (Var V) A = (V \<in>\<in> A)"
| "\<D> (LAss V e) A = \<D> e A"
| "\<D> (e\<bullet>F{D}) A = \<D> e A"
| "\<D> (e\<^sub>1\<bullet>F{D}:=e\<^sub>2) A = (\<D> e\<^sub>1 A \<and> \<D> e\<^sub>2 (A \<squnion> \ e\<^sub>1))"
| "\<D> (e\<bullet>M(es)) A = (\<D> e A \<and> \<D>s es (A \<squnion> \ e))"
| "\<D> ({V:T; e}) A = \<D> e (A \<ominus> V)"
| "\<D> (e\<^sub>1;;e\<^sub>2) A = (\<D> e\<^sub>1 A \<and> \<D> e\<^sub>2 (A \<squnion> \ e\<^sub>1))"
| "\<D> (if (e) e\<^sub>1 else e\<^sub>2) A =
  (\<D> e A \<and> \<D> e\<^sub>1 (A \<squnion> \ e) \<and> \<D> e\<^sub>2 (A \<squnion> \ e))"
| "\<D> (while (e) c) A = (\<D> e A \<and> \<D> c (A \<squnion> \ e))"
| "\<D> (throw e) A = \<D> e A"
| "\<D> (try e\<^sub>1 catch(C V) e\<^sub>2) A = (\<D> e\<^sub>1 A \<and> \<D> e\<^sub>2 (A \<squnion> \<lfloor>{V}\<rfloor>))"

| "\<D>s ([]) A = True"
| "\<D>s (e#es) A = (\<D> e A \<and> \<D>s es (A \<squnion> \ e))"

lemma As_map_Val[simp]: "\s (map Val vs) = \<lfloor>{}\<rfloor>"
(*<*)by (induct vs) simp_all(*>*)

lemma D_append[iff]: "\<And>A. \<D>s (es @ es') A = (\<D>s es A \<and> \<D>s es' (A \<squnion> \s es))"
(*<*)by (induct es type:list) (auto simp:hyperUn_assoc)(*>*)

lemma A_fv: "\<And>A. \ e = \<lfloor>A\<rfloor> \<Longrightarrow> A \<subseteq> fv e"
and  "\<And>A. \s es = \<lfloor>A\<rfloor> \<Longrightarrow> A \<subseteq> fvs es"
(*<*)
apply(induct e and es rule: \.induct \s.induct)
apply (simp_all add:hyperset_defs)
apply blast+
done
(*>*)

lemma sqUn_lem: "A \<sqsubseteq> A' \<Longrightarrow> A \<squnion> B \<sqsubseteq> A' \<squnion> B"
(*<*)by(simp add:hyperset_defs) blast(*>*)

lemma diff_lem: "A \<sqsubseteq> A' \<Longrightarrow> A \<ominus> b \<sqsubseteq> A' \<ominus> b"
(*<*)by(simp add:hyperset_defs) blast(*>*)

(* This order of the premises avoids looping of the simplifier *)
lemma D_mono: "\<And>A A'. A \<sqsubseteq> A' \<Longrightarrow> \<D> e A \<Longrightarrow> \<D> (e::'a exp) A'"
and Ds_mono: "\<And>A A'. A \<sqsubseteq> A' \<Longrightarrow> \<D>s es A \<Longrightarrow> \<D>s (es::'a exp list) A'"
(*<*)
apply(induct e and es rule: \<D>.induct \<D>s.induct)
apply simp
apply simp
apply simp
apply simp apply (iprover dest:sqUn_lem)
apply (fastforce simp add:hyperset_defs)
apply simp
apply simp
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:diff_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp
apply simp apply (iprover dest:sqUn_lem)
apply simp
apply simp apply (iprover dest:sqUn_lem)
done
(*>*)

(* And this is the order of premises preferred during application: *)
lemma D_mono': "\<D> e A \<Longrightarrow> A \<sqsubseteq> A' \<Longrightarrow> \<D> e A'"
and Ds_mono': "\<D>s es A \<Longrightarrow> A \<sqsubseteq> A' \<Longrightarrow> \<D>s es A'"
(*<*)by(blast intro:D_mono, blast intro:Ds_mono)(*>*)

(*
text{* @{term"\"} is sound w.r.t.\ the big step semantics: it
computes a conservative approximation of the variables actually
assigned to. *}

lemma "P \<turnstile> \<langle>e,(h\<^sub>0,l\<^sub>0)\<rangle> \<Rightarrow> \<langle>e',(h\<^sub>1,l\<^sub>1)\<rangle> \<Longrightarrow> (!!A. \ e = \<lfloor>A\<rfloor> \<Longrightarrow> A \<subseteq> dom l\<^sub>1)"
and "P \<turnstile> \<langle>es,(h\<^sub>0,l\<^sub>0)\<rangle> [\<Rightarrow>] \<langle>es',(h\<^sub>1,l\<^sub>1)\<rangle> \<Longrightarrow> (!!A. \s es = \<lfloor>A\<rfloor> \<Longrightarrow> A \<subseteq> dom l\<^sub>1)"

proof (induct rule:eval_evals_induct)
  case LAss thus ?case apply(simp add:dom_def hyperset_defs) apply blast
apply blast
next
  case FAss thus ?case by simp (blast dest:eval_lcl_incr)
next
  case BinOp thus ?case by simp (blast dest:eval_lcl_incr)
next
  case Call thus  ?case by simp (blast dest:evals_lcl_incr)
next
  case Cons thus ?case by simp (blast dest:evals_lcl_incr)
next
  case Block thus ?case by(simp del: fun_upd_apply) blast
next
  case Seq thus ?case by simp (blast dest:eval_lcl_incr)
next
  case CondT thus ?case by simp (blast dest:eval_lcl_incr)
next
  case CondF thus ?case by simp (blast dest:eval_lcl_incr)
next
  case Try thus ?case by(fastforce dest!: eval_lcl_incr)
next
  case TryCatch thus ?case by(fastforce dest!: eval_lcl_incr)
qed auto
*)
end


theory Homework6_2
imports Main "~~/src/HOL/Eisbach/Eisbach"
begin

(*
  ISSUED: Wednesday, October 25
  DUE: Wednesday, November 1, 11:59pm
  POINTS: 5
*)

(*
  We extend IMP by arrays.
  Each variable is now a list of integers, and variable
  access takes an additional index.

  Hint: Use the standard IMP theories as a template
*)

type_synonym vname = string
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val list"

datatype aexp =
    N int
  | V vname aexp     (* x[i], i.e., array x at index i, where i is an arithmetic expression *)
  | Plus aexp aexp

(*
  Unfortunately, array access may be out of bounds.
  Thus, we model evaluation of expressions as partial function,
  returning None if array index is out of bounds.
*)

(*
  Complete the following function definition.
  Note:
    l!i selects the ith element of list l,
    and nat converts an int to a nat.
*)
fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val option" where
"aval (N n) s = Some n" |
"aval (V x i) s = (
  case aval i s of
    None \<Rightarrow> None
  | Some i \<Rightarrow> (
      if 0\<le>i \<and> nat i<length (s x) then
        Some (s x ! nat i)
      else None)
  )" |
"aval (Plus a\<^sub>1 a\<^sub>2) s = undefined" (* Insert meaningful equation here! *)

text {* A little syntax magic to write larger states compactly: *}

(* All variables are arrays of length 1, initialized by zero.
  This simulates the behaviour of original IMP.
*)
definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. [0]"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

lemma null_state_app[simp]: "<> x = [0]" by (auto simp: null_state_def)

abbreviation "V0 x \<equiv> V x (N 0)" (* Abbreviation for x[0].
  Again, models the behaviour of original IMP. *)

(* Test cases *)
value "aval (Plus (V ''x'' (V0 ''y'')) (V ''x'' (N 1))) <''x'':=[1,2,3], ''y'':=[2]> = Some 5"
value "aval (Plus (N 2) (V ''x'' (N 2))) <''x'':=[1,2]> = None" (* Index out of bounds *)

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

(* Complete the following function definition!   *)
fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool option" where
"bval (Bc v) s = Some v" |
"bval (Not b) s = (case bval b s of None \<Rightarrow> None | Some b \<Rightarrow> Some (\<not>b))" |
"bval (And b\<^sub>1 b\<^sub>2) s = undefined" |
"bval (Less a\<^sub>1 a\<^sub>2) s = undefined"

datatype
  com = SKIP
      | Assign vname aexp aexp  ("_[_] ::= _" [1000,900, 61] 61)
      | Seq    com  com         ("_;;/ _"  [60, 61] 60)
      | If     bexp com com     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61)
      | While  bexp com         ("(WHILE _/ DO _)"  [0, 61] 61)

(* Abbreviation to get x ::= e syntax, as abbreviation for x[N 0] ::= e *)
abbreviation Assign0 ("_ ::= _" [1000, 61] 61) where
  "x ::= v \<equiv> (x[N 0] ::= v)"

(*
  Give Skip,Assign,Seq rule.

  The big-step semantics shall get stuck in case of array-index-out-of-bounds.
  That is, the preconditions of the rules assume that the indexes are in bounds,
  and that aval/bval return Some result.

  Note: l[i:=v] replaces ith element of list l by v
*)
inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
Skip: "(SKIP,s) \<Rightarrow> s" |
Assign: "\<lbrakk>
  aval a s = Some v;
  aval i s = Some idx;
  0\<le>idx;
  nat idx<length (s x) \<rbrakk>
\<Longrightarrow> (x[i] ::= a,s) \<Rightarrow> s(x := ((s x)[nat idx := v]))" |
Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
(* add reasonable preconditions for the following rules! *)
IfTrue: "\<lbrakk> undefined \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse: "\<lbrakk> undefined \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "\<lbrakk> undefined \<rbrakk> \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue: "\<lbrakk> undefined \<rbrakk> \<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3"

(* Setup for program derivation *)
method If = (rule IfTrue, (simp;fail)) | (rule IfFalse, (simp;fail))
method While = (rule WhileTrue, (simp;fail)) | (rule WhileFalse, (simp;fail))
method BigStep = simp?; ((rule Skip Assign Seq) | If | While)
method BigSteps = BigStep+

(* Automation setup *)
declare big_step.intros [intro]

lemmas big_step_induct = big_step.induct[split_format(complete)]

inductive_cases SkipE[elim!]: "(SKIP,s) \<Rightarrow> t"

inductive_cases AssignE[elim!]: "(x[i] ::= a,s) \<Rightarrow> t"
thm AssignE
inductive_cases SeqE[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
thm IfE
inductive_cases WhileE[elim]: "(WHILE b DO c,s) \<Rightarrow> t"
thm WhileE

(* This proof should not change ... *)
lemma Seq_assoc:
  "(c1;; c2;; c3, s) \<Rightarrow> s' \<longleftrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
proof
  assume "(c1;; c2;; c3, s) \<Rightarrow> s'"
  then obtain s1 s2 where
    c1: "(c1, s) \<Rightarrow> s1" and
    c2: "(c2, s1) \<Rightarrow> s2" and
    c3: "(c3, s2) \<Rightarrow> s'" by auto
  from c2 c3
  have "(c2;; c3, s1) \<Rightarrow> s'" by (rule Seq)
  with c1
  show "(c1;; (c2;; c3), s) \<Rightarrow> s'" by (rule Seq)
next
  -- "The other direction is analogous"
  assume "(c1;; (c2;; c3), s) \<Rightarrow> s'"
  thus "(c1;; c2;; c3, s) \<Rightarrow> s'" by auto
qed

(*
  Prove that the big-step semantics is deterministic.

  The proof is analogous to its counterpart in BigStep.thy.
  However, you will probably have to perform an Isar-proof here, or try to fiddle
  through with sledgehammer.
  The problem is that the induction generates goals like

  \<And>b s c\<^sub>1 t c\<^sub>2 u.
     \<lbrakk> bval b s = Some True;
      (c\<^sub>1, s) \<Rightarrow> t;
      \<And>u. (c\<^sub>1, s) \<Rightarrow> u \<Longrightarrow> u = t;
      (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> u
     \<rbrakk>
     \<Longrightarrow> u = t

  This will crash the simplifier, which uses the 2nd and 3rd premise to rewrite with t=t.
  In the Isar-proof, try to only use the necessary premises \<dots>
*)

theorem big_step_determ: "\<lbrakk> (c,s) \<Rightarrow> t; (c,s) \<Rightarrow> u \<rbrakk> \<Longrightarrow> u = t"
  oops

(*
  Write a program that sums up the elements from indexes l..<h of array a, and
  returns the result in r.

  Hint:
    r=0;
    while (l<h) r+=a[l++];

*)

abbreviation "array_sum \<equiv> SKIP"

(* Use automatic big-step derivation to test your program!
  Test for various test cases, in particular making sure you have no off-by-one errors!

  Note that the BigSteps method will fail to generate a derivation if
  execution gets stuck b/c index-out-of-bounds
*)

schematic_goal "(array_sum,<''l'':=[1], ''h'':=[5], ''a'':=[100,1,2,3,4,200,300]>) \<Rightarrow> ?s"
  by BigSteps

(*
  Write another program that sums up the elements in between indexes l..<h of array a,
  but ignores elements with a value less than or equal to 5.
  The result must be returned in variable r.
  Test your program!

  Hint: Start with the array_sum program and extend it.
*)

abbreviation "array_sum_gt5 \<equiv> SKIP"

schematic_goal "(array_sum_gt5,<''l'':=[1], ''h'':=[5], ''a'':=[100,1,7,13,4,200,300]>) \<Rightarrow> ?s"
  by BigSteps

end


theory formulas
  imports Main "/Volumes/Setup/Isabelle/Isabelle-Code/September/Skolemize/libs"
begin

lemma p_p2_equiv: "((\<forall>p \<in> set Peers. (speak(p) \<longrightarrow> (isReg(p, Rp) \<and> broadcast(Rp) \<and> (\<forall>p1 \<in> set Peers - {p}.(isReg(p1,Rp) \<longrightarrow> \<not>speak(p1))))))
\<and>
(\<forall>p1 \<in> set Peers. (speak(p1) \<longrightarrow> (isReg(p1, Rp1) \<and> broadcast(Rp1) \<and> (\<forall>p2 \<in> set Peers - {p1}.(isReg(p2,Rp1) \<longrightarrow> \<not>speak(p2)))))))
\<longleftrightarrow>
((\<forall>p \<in> set Peers. (speak(p) \<longrightarrow> (isReg(p, Rp) \<and> broadcast(Rp) \<and> (\<forall>p1 \<in> set Peers - {p}.(isReg(p1,Rp) \<longrightarrow> \<not>speak(p1))))))
\<and> (\<forall>p1 \<in> set Peers. (speak(p1) \<longrightarrow> (isReg(p1, Rp1) \<and> broadcast(Rp1) \<and> (\<forall>p \<in> set Peers - {p1}.(isReg(p,Rp1) \<longrightarrow> \<not>speak(p))))))
)"
  by meson

value "((\<forall>p \<in> set Peers. (speak(p) \<longrightarrow> (isReg(p, Rp) \<and> broadcast(Rp) \<and> (\<forall>p1 \<in> set Peers - {p}.(isReg(p1,Rp) \<longrightarrow> \<not>speak(p1)))))
\<and>
(\<forall>p1 \<in> set Peers-{p}. (speak(p1) \<longrightarrow> (isReg(p1, Rp1) \<and> broadcast(Rp1) \<and> (\<forall>p2 \<in> set Peers - {p1}.(isReg(p2,Rp1) \<longrightarrow> \<not>speak(p2))))))))"

(*------------------------*)
lemma p_p2_equiv_2: "
((\<forall>p \<in> set Peers. (speak(p) \<longrightarrow> (isReg(p, Rp) \<and> broadcast(Rp) \<and> (\<forall>p1 \<in> set Peers.(p1\<noteq>p \<and> isReg(p1,Rp) \<longrightarrow> \<not>speak(p1))))))
\<and>
(\<forall>p1 \<in> set Peers. (speak(p1) \<longrightarrow> (isReg(p1, Rp1) \<and> broadcast(Rp1) \<and> (\<forall>p2 \<in> set Peers.(p1\<noteq>p2 \<and> isReg(p2,Rp1) \<longrightarrow> \<not>speak(p2)))))))
\<longleftrightarrow>
((\<forall>p \<in> set Peers. (speak(p) \<longrightarrow> (isReg(p, Rp) \<and> broadcast(Rp) \<and> (\<forall>p1 \<in> set Peers.(p1\<noteq>p \<and> isReg(p1,Rp) \<longrightarrow> \<not>speak(p1))))))
\<and>
(\<forall>p1 \<in> set Peers. (speak(p1) \<longrightarrow> (isReg(p1, Rp1) \<and> broadcast(Rp1) \<and> (\<forall>p \<in> set Peers.(p1\<noteq>p \<and> isReg(p,Rp1) \<longrightarrow> \<not>speak(p))))))
)"
  by blast

(*------------------------*)
lemma p_p2_equiv_rutgon: "
((\<forall>p \<in> set Peers. (speak(p) \<longrightarrow> (isReg(p, Rp) \<and> broadcast(Rp) \<and> (\<forall>p1 \<in> set Peers.(p1\<noteq>p \<and> isReg(p1,Rp) \<longrightarrow> \<not>speak(p1)))))
\<and>
(\<forall>p1 \<in> set Peers. (p1\<noteq>p \<and> speak(p1) \<longrightarrow> (isReg(p1, Rp1) \<and> broadcast(Rp1) \<and> (\<forall>p2 \<in> set Peers.(p1\<noteq>p2 \<and> isReg(p2,Rp1) \<longrightarrow> \<not>speak(p2))))))))
\<longleftrightarrow>
((\<forall>p \<in> set Peers. (speak(p) \<longrightarrow> (isReg(p, Rp) \<and> broadcast(Rp) \<and> (\<forall>p1 \<in> set Peers.(p1\<noteq>p \<and> isReg(p1,Rp) \<longrightarrow> \<not>speak(p1)))))
\<and>
(\<forall>p1 \<in> set Peers. (p1\<noteq>p \<and> speak(p1) \<longrightarrow> (isReg(p1, Rp1) \<and> broadcast(Rp1) \<and> (isReg(p,Rp1) \<longrightarrow> \<not>speak(p))))))
)"
  by blast

(*-----------without changing the order-------------*)
(*\<Longrightarrow> no need to care about removing the independent predicates*)
lemma p_p2_equiv_27_09: "
((\<forall>p \<in> set Peers. (speak(p) \<longrightarrow> (isReg(p, Rp) \<and> broadcast(Rp) \<and> (\<forall>p1 \<in> set Peers.(p1\<noteq>p \<and> isReg(p1,Rp) \<longrightarrow> \<not>speak(p1)))))
\<and>
(\<forall>p1 \<in> set Peers. (speak(p1) \<longrightarrow> (isReg(p1, Rp1) \<and> broadcast(Rp1) \<and> (\<forall>p2 \<in> set Peers.(p1\<noteq>p2 \<and> isReg(p2,Rp1) \<longrightarrow> \<not>speak(p2))))))))
\<longleftrightarrow>
((\<forall>p \<in> set Peers. (speak(p) \<longrightarrow> (isReg(p, Rp) \<and> broadcast(Rp) \<and> (\<forall>p1 \<in> set Peers.(p1\<noteq>p \<and> isReg(p1,Rp) \<longrightarrow> \<not>speak(p1)))))
\<and>
(\<forall>p1 \<in> set Peers. (speak(p1) \<longrightarrow> (isReg(p1, Rp1) \<and> broadcast(Rp1) \<and> (p1\<noteq>p \<and> isReg(p,Rp1) \<longrightarrow> \<not>speak(p))))))
)"
  by blast
(*
p == p2 = Peers - {p1}
NEXT: test p, p1, p2
*)

end


(*  Title:      HOL/MicroJava/BV/SemilatAlg.thy
    Author:     Gerwin Klein
    Copyright   2002 Technische Universitaet Muenchen
*)

header {* \isaheader{More on Semilattices} *}

theory SemilatAlg
imports Typing_Framework
begin

consts
  lesubstep_type :: "(nat \<times> 's) set \<Rightarrow> 's ord \<Rightarrow> (nat \<times> 's) set \<Rightarrow> bool"
(*<*)
notation
  lesubstep_type  ("(_ /{<='__} _)" [50, 0, 51] 50)
(*>*)
notation (xsymbols)
  lesubstep_type  ("(_ /{\<sqsubseteq>\<^bsub>_\<^esub>} _)" [50, 0, 51] 50)
defs lesubstep_type_def:
  "A {\<sqsubseteq>\<^bsub>r\<^esub>} B \<equiv> \<forall>(p,\<tau>) \<in> A. \<exists>\<tau>'. (p,\<tau>') \<in> B \<and> \<tau> \<sqsubseteq>\<^sub>r \<tau>'"

primrec pluslussub :: "'a list \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a"
where
  "pluslussub [] f y = y"
| "pluslussub (x#xs) f y = pluslussub xs f (x \<squnion>\<^sub>f y)"
(*<*)
notation
  pluslussub  ("(_ /++'__ _)" [65, 1000, 66] 65)
(*>*)
notation (xsymbols)
  pluslussub  ("(_ /\<Squnion>\<^bsub>_\<^esub> _)" [65, 0, 66] 65)

definition bounded :: "'s step_type \<Rightarrow> nat \<Rightarrow> bool"
where
  "bounded step n \<longleftrightarrow> (\<forall>p<n. \<forall>\<tau>. \<forall>(q,\<tau>') \<in> set (step p \<tau>). q<n)"

definition pres_type :: "'s step_type \<Rightarrow> nat \<Rightarrow> 's set \<Rightarrow> bool"
where
  "pres_type step n A \<longleftrightarrow> (\<forall>\<tau>\<in>A. \<forall>p<n. \<forall>(q,\<tau>') \<in> set (step p \<tau>). \<tau>' \<in> A)"

definition mono :: "'s ord \<Rightarrow> 's step_type \<Rightarrow> nat \<Rightarrow> 's set \<Rightarrow> bool"
where
  "mono r step n A \<longleftrightarrow>
    (\<forall>\<tau> p \<tau>'. \<tau> \<in> A \<and> p<n \<and> \<tau> \<sqsubseteq>\<^sub>r \<tau>' \<longrightarrow> set (step p \<tau>) {\<sqsubseteq>\<^bsub>r\<^esub>} set (step p \<tau>'))"

lemma [iff]: "(A {\<sqsubseteq>\<^bsub>r\<^esub>} {}) = (A = {})"
  (*<*) by (cases "A={}") (auto simp add: lesubstep_type_def) (*>*)

lemma lesubstep_union:
  "\<lbrakk> A\<^sub>1 {\<sqsubseteq>\<^bsub>r\<^esub>} B\<^sub>1; A\<^sub>2 {\<sqsubseteq>\<^bsub>r\<^esub>} B\<^sub>2 \<rbrakk> \<Longrightarrow> A\<^sub>1 \<union> A\<^sub>2 {\<sqsubseteq>\<^bsub>r\<^esub>} B\<^sub>1 \<union> B\<^sub>2"
  (*<*) by (auto simp add: lesubstep_type_def) (*>*)

lemma pres_typeD:
  "\<lbrakk> pres_type step n A; s\<in>A; p<n; (q,s')\<in>set (step p s) \<rbrakk> \<Longrightarrow> s' \<in> A"
(*<*) by (unfold pres_type_def, blast) (*>*)

lemma monoD:
  "\<lbrakk> mono r step n A; p < n; s\<in>A; s \<sqsubseteq>\<^sub>r t \<rbrakk> \<Longrightarrow> set (step p s) {\<sqsubseteq>\<^bsub>r\<^esub>} set (step p t)"
(*<*) by (unfold mono_def, blast) (*>*)

lemma boundedD:
  "\<lbrakk> bounded step n; p < n; (q,t) \<in> set (step p xs) \<rbrakk> \<Longrightarrow> q < n"
(*<*) by (unfold bounded_def, blast) (*>*)

lemma lesubstep_type_refl [simp, intro]:
  "(\<And>x. x \<sqsubseteq>\<^sub>r x) \<Longrightarrow> A {\<sqsubseteq>\<^bsub>r\<^esub>} A"
(*<*) by (unfold lesubstep_type_def) auto (*>*)

lemma lesub_step_typeD:
  "A {\<sqsubseteq>\<^bsub>r\<^esub>} B \<Longrightarrow> (x,y) \<in> A \<Longrightarrow> \<exists>y'. (x, y') \<in> B \<and> y \<sqsubseteq>\<^sub>r y'"
(*<*) by (unfold lesubstep_type_def) blast (*>*)

lemma list_update_le_listI [rule_format]:
  "set xs \<subseteq> A \<longrightarrow> set ys \<subseteq> A \<longrightarrow> xs [\<sqsubseteq>\<^sub>r] ys \<longrightarrow> p < size xs \<longrightarrow>
   x \<sqsubseteq>\<^sub>r ys!p \<longrightarrow> semilat(A,r,f) \<longrightarrow> x\<in>A \<longrightarrow>
   xs[p := x \<squnion>\<^sub>f xs!p] [\<sqsubseteq>\<^sub>r] ys"
(*<*)
  apply (unfold Listn.le_def lesub_def semilat_def)
  apply (simp add: list_all2_conv_all_nth nth_list_update)
  apply (simp add: lesub_def)
  done
(*>*)

lemma plusplus_closed: assumes "Semilat A r f" shows
  "\<And>y. \<lbrakk> set x \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> x \<Squnion>\<^bsub>f\<^esub> y \<in> A"
(*<*)
proof (induct x)
  interpret Semilat A r f by fact
  show "\<And>y. y \<in> A \<Longrightarrow> [] \<Squnion>\<^bsub>f\<^esub> y \<in> A" by simp
  fix y x xs
  assume y: "y \<in> A" and xxs: "set (x#xs) \<subseteq> A"
  assume IH: "\<And>y. \<lbrakk> set xs \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> xs \<Squnion>\<^bsub>f\<^esub> y \<in> A"
  from xxs obtain x: "x \<in> A" and xs: "set xs \<subseteq> A" by simp
  from x y have "x \<squnion>\<^bsub>f\<^esub> y \<in> A" ..
  with xs have "xs \<Squnion>\<^bsub>f\<^esub> (x \<squnion>\<^bsub>f\<^esub> y) \<in> A" by (rule IH)
  thus "x#xs \<Squnion>\<^bsub>f\<^esub> y \<in> A" by simp
qed
(*>*)

lemma (in Semilat) pp_ub2:
 "\<And>y. \<lbrakk> set x \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> y \<sqsubseteq>\<^bsub>r\<^esub> x \<Squnion>\<^bsub>f\<^esub> y"
(*<*)
proof (induct x)
  from semilat show "\<And>y. y \<sqsubseteq>\<^bsub>r\<^esub> [] \<Squnion>\<^bsub>f\<^esub> y" by simp

  fix y a l assume y:  "y \<in> A" and "set (a#l) \<subseteq> A"
  then obtain a: "a \<in> A" and x: "set l \<subseteq> A" by simp
  assume "\<And>y. \<lbrakk>set l \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> y \<sqsubseteq>\<^bsub>r\<^esub> l \<Squnion>\<^bsub>f\<^esub> y"
  from this and x have IH: "\<And>y. y \<in> A \<Longrightarrow> y \<sqsubseteq>\<^bsub>r\<^esub> l \<Squnion>\<^bsub>f\<^esub> y" .

  from a y have "y \<sqsubseteq>\<^bsub>r\<^esub> a \<squnion>\<^bsub>f\<^esub> y" ..
  also from a y have "a \<squnion>\<^bsub>f\<^esub> y \<in> A" ..
  hence "(a \<squnion>\<^bsub>f\<^esub> y) \<sqsubseteq>\<^bsub>r\<^esub> l \<Squnion>\<^bsub>f\<^esub> (a \<squnion>\<^bsub>f\<^esub> y)" by (rule IH)
  finally have "y \<sqsubseteq>\<^bsub>r\<^esub> l \<Squnion>\<^bsub>f\<^esub> (a \<squnion>\<^bsub>f\<^esub> y)" .
  thus "y \<sqsubseteq>\<^bsub>r\<^esub> (a#l) \<Squnion>\<^bsub>f\<^esub> y" by simp
qed
(*>*)

  fix y s ls
  assume "set (s#ls) \<subseteq> A"
  then obtain s: "s \<in> A" and ls: "set ls \<subseteq> A" by simp
  assume y: "y \<in> A"

  assume "\<And>y. \<lbrakk>set ls \<subseteq> A; y \<in> A; x \<in> set ls\<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^bsub>r\<^esub> ls \<Squnion>\<^bsub>f\<^esub> y"
  from this and ls have IH: "\<And>y. x \<in> set ls \<Longrightarrow> y \<in> A \<Longrightarrow> x \<sqsubseteq>\<^bsub>r\<^esub> ls \<Squnion>\<^bsub>f\<^esub> y" .

  assume "x \<in> set (s#ls)"
  then obtain xls: "x = s \<or> x \<in> set ls" by simp
  moreover {
    assume xs: "x = s"
    from s y have "s \<sqsubseteq>\<^bsub>r\<^esub> s \<squnion>\<^bsub>f\<^esub> y" ..
    also from s y have "s \<squnion>\<^bsub>f\<^esub> y \<in> A" ..
    with ls have "(s \<squnion>\<^bsub>f\<^esub> y) \<sqsubseteq>\<^bsub>r\<^esub> ls \<Squnion>\<^bsub>f\<^esub> (s \<squnion>\<^bsub>f\<^esub> y)" by (rule pp_ub2)
    finally have "s \<sqsubseteq>\<^bsub>r\<^esub> ls \<Squnion>\<^bsub>f\<^esub> (s \<squnion>\<^bsub>f\<^esub> y)" .
    with xs have "x \<sqsubseteq>\<^bsub>r\<^esub> ls \<Squnion>\<^bsub>f\<^esub> (s \<squnion>\<^bsub>f\<^esub> y)" by simp
  }
  moreover {
    assume "x \<in> set ls"
    hence "\<And>y. y \<in> A \<Longrightarrow> x \<sqsubseteq>\<^bsub>r\<^esub> ls \<Squnion>\<^bsub>f\<^esub> y" by (rule IH)
    moreover from s y have "s \<squnion>\<^bsub>f\<^esub> y \<in> A" ..
    ultimately have "x \<sqsubseteq>\<^bsub>r\<^esub> ls \<Squnion>\<^bsub>f\<^esub> (s \<squnion>\<^bsub>f\<^esub> y)" .
  }
  ultimately
  have "x \<sqsubseteq>\<^bsub>r\<^esub> ls \<Squnion>\<^bsub>f\<^esub> (s \<squnion>\<^bsub>f\<^esub> y)" by blast
  thus "x \<sqsubseteq>\<^bsub>r\<^esub> (s#ls) \<Squnion>\<^bsub>f\<^esub> y" by simp
qed
(*>*)

lemma (in Semilat) pp_lub:
  assumes z: "z \<in> A"
  shows
  "\<And>y. y \<in> A \<Longrightarrow> set xs \<subseteq> A \<Longrightarrow> \<forall>x \<in> set xs. x \<sqsubseteq>\<^bsub>r\<^esub> z \<Longrightarrow> y \<sqsubseteq>\<^bsub>r\<^esub> z \<Longrightarrow> xs \<Squnion>\<^bsub>f\<^esub> y \<sqsubseteq>\<^bsub>r\<^esub> z"
(*<*)
proof (induct xs)
  fix y assume "y \<sqsubseteq>\<^bsub>r\<^esub> z" thus "[] \<Squnion>\<^bsub>f\<^esub> y \<sqsubseteq>\<^bsub>r\<^esub> z" by simp
next
  fix y l ls assume y: "y \<in> A" and "set (l#ls) \<subseteq> A"
  then obtain l: "l \<in> A" and ls: "set ls \<subseteq> A" by auto
  assume "\<forall>x \<in> set (l#ls). x \<sqsubseteq>\<^bsub>r\<^esub> z"
  then obtain lz: "l \<sqsubseteq>\<^bsub>r\<^esub> z" and lsz: "\<forall>x \<in> set ls. x \<sqsubseteq>\<^bsub>r\<^esub> z" by auto
  assume "y \<sqsubseteq>\<^bsub>r\<^esub> z" with lz have "l \<squnion>\<^bsub>f\<^esub> y \<sqsubseteq>\<^bsub>r\<^esub> z" using l y z ..
  moreover
  from l y have "l \<squnion>\<^bsub>f\<^esub> y \<in> A" ..
  moreover
  assume "\<And>y. y \<in> A \<Longrightarrow> set ls \<subseteq> A \<Longrightarrow> \<forall>x \<in> set ls. x \<sqsubseteq>\<^bsub>r\<^esub> z \<Longrightarrow> y \<sqsubseteq>\<^bsub>r\<^esub> z
          \<Longrightarrow> ls \<Squnion>\<^bsub>f\<^esub> y \<sqsubseteq>\<^bsub>r\<^esub> z"
  ultimately
  have "ls \<Squnion>\<^bsub>f\<^esub> (l \<squnion>\<^bsub>f\<^esub> y) \<sqsubseteq>\<^bsub>r\<^esub> z" using ls lsz by -
  thus "(l#ls) \<Squnion>\<^bsub>f\<^esub> y \<sqsubseteq>\<^bsub>r\<^esub> z" by simp
qed
(*>*)

lemma ub1': assumes "Semilat A r f"
shows "\<lbrakk>\<forall>(p,s) \<in> set S. s \<in> A; y \<in> A; (a,b) \<in> set S\<rbrakk>
  \<Longrightarrow> b \<sqsubseteq>\<^bsub>r\<^esub> map snd [(p', t') \<leftarrow> S. p' = a] \<Squnion>\<^bsub>f\<^esub> y"
(*<*)
proof -
  interpret Semilat A r f by fact
  let "b \<sqsubseteq>\<^bsub>r\<^esub> ?map \<Squnion>\<^bsub>f\<^esub> y" = ?thesis

  assume "y \<in> A"
  moreover
  assume "\<forall>(p,s) \<in> set S. s \<in> A"
  hence "set ?map \<subseteq> A" by auto
  moreover
  assume "(a,b) \<in> set S"
  hence "b \<in> set ?map" by (induct S, auto)
  ultimately
  show ?thesis by - (rule pp_ub1)
qed
(*>*)

lemma plusplus_empty:
  "\<forall>s'. (q, s') \<in> set S \<longrightarrow> s' \<squnion>\<^bsub>f\<^esub> ss ! q = ss ! q \<Longrightarrow>
   (map snd [(p', t') \<leftarrow> S. p' = q] \<Squnion>\<^bsub>f\<^esub> ss ! q) = ss ! q"
(*<*)
apply (induct S)
apply auto
done
(*>*)

end


theory Lappend
  imports Main "$HIPSTER_HOME/IsaHipster"
    "types/Llist"
begin
setup Tactic_Data.set_coinduct_sledgehammer
setup Misc_Data.set_noisy

primcorec lappend :: "'a Llist \<Rightarrow> 'a Llist \<Rightarrow> 'a Llist" where
"lnull xs \<Longrightarrow> lnull ys \<Longrightarrow> lnull (lappend xs ys)"
| "lhd (lappend xs ys) = lhd (if lnull xs then ys else xs)"
| "ltl (lappend xs ys) = (if lnull xs then ltl ys else lappend (ltl xs) ys)"

(* cohipster lappend *)
(* Discovered and proved the follwing in ca. 25 seconds*)
lemma lemma_a [thy_expl]: "lappend y LNil = y"
  by (coinduction arbitrary: y rule: Llist.Llist.coinduct_strong)
    simp

lemma lemma_aa [thy_expl]: "lappend LNil y = y"
  by (coinduction arbitrary: y rule: Llist.Llist.coinduct_strong)
    simp

lemma lemma_ab [thy_expl]: "ltl (lappend y y) = lappend (ltl y) y"
  by (coinduction arbitrary: y rule: Llist.Llist.coinduct_strong)
    (metis Llist.sel(2) lappend.code lappend.simps(4) lnull_def)

lemma lemma_ac [thy_expl]: "lappend (LCons y z) x2 = LCons y (lappend z x2)"
  by (coinduction arbitrary: x2 y z rule: Llist.Llist.coinduct_strong)
    simp

(* Associativity of lappend *)
lemma lemma_ad [thy_expl]: "lappend (lappend y z) x2 = lappend y (lappend z x2)"
  by (coinduction arbitrary: x2 y z rule: Llist.Llist.coinduct_strong)
    auto

lemma lemma_ae [thy_expl]: "ltl (lappend y (ltl y)) = lappend (ltl y) (ltl y)"
  by (coinduction arbitrary: y rule: Llist.Llist.coinduct_strong)
    (metis Llist.sel(2) lappend.disc(1) lappend.simps(4) lnull_def)

end


(* The definitions for a challenge suggested by Adam Chlipala *)

theory Compile
imports "../Nominal"
begin

atom_decl name

nominal_datatype data =
    DNat
  | DProd "data" "data"
  | DSum "data" "data"

nominal_datatype ty =
    Data "data"
  | Arrow "ty" "ty" ("_\<rightarrow>_" [100,100] 100)

nominal_datatype trm =
  Var "name"
  | Lam "\<guillemotleft>name\<guillemotright>trm" ("Lam [_]._" [100,100] 100)
  | App "trm" "trm"
  | Const "nat"
  | Pr "trm" "trm"
  | Fst "trm"
  | Snd "trm"
  | InL "trm"
  | InR "trm"
  | Case "trm" "\<guillemotleft>name\<guillemotright>trm" "\<guillemotleft>name\<guillemotright>trm"
          ("Case _ of inl _ \<rightarrow> _ | inr _ \<rightarrow> _" [100,100,100,100,100] 100)

nominal_datatype dataI = OneI | NatI

nominal_datatype tyI =
    DataI "dataI"
  | ArrowI "tyI" "tyI" ("_\<rightarrow>_" [100,100] 100)

nominal_datatype trmI =
    IVar "name"
  | ILam "\<guillemotleft>name\<guillemotright>trmI" ("ILam [_]._" [100,100] 100)
  | IApp "trmI" "trmI"
  | IUnit
  | INat "nat"
  | ISucc "trmI"
  | IAss "trmI" "trmI" ("_\<mapsto>_" [100,100] 100)
  | IRef "trmI"
  | ISeq "trmI" "trmI" ("_;;_" [100,100] 100)
  | Iif "trmI" "trmI" "trmI"

text \<open>valid contexts\<close>

inductive
  valid :: "(name\<times>'a::pt_name) list \<Rightarrow> bool"
where
  v1[intro]: "valid []"
| v2[intro]: "\<lbrakk>valid \<Gamma>;a\<sharp>\<Gamma>\<rbrakk>\<Longrightarrow> valid ((a,\<sigma>)#\<Gamma>)" (* maybe dom of \<Gamma> *)

text \<open>typing judgements for trms\<close>

inductive
  typing :: "(name\<times>ty) list\<Rightarrow>trm\<Rightarrow>ty\<Rightarrow>bool" (" _ \<turnstile> _ : _ " [80,80,80] 80)
where
  t0[intro]: "\<lbrakk>valid \<Gamma>; (x,\<tau>)\<in>set \<Gamma>\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> Var x : \<tau>"
| t1[intro]: "\<lbrakk>\<Gamma> \<turnstile> e1 : \<tau>1\<rightarrow>\<tau>2; \<Gamma> \<turnstile> e2 : \<tau>1\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> App e1 e2 : \<tau>2"
| t2[intro]: "\<lbrakk>x\<sharp>\<Gamma>;((x,\<tau>1)#\<Gamma>) \<turnstile> t : \<tau>2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Lam [x].t : \<tau>1\<rightarrow>\<tau>2"
| t3[intro]: "valid \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> Const n : Data(DNat)"
| t4[intro]: "\<lbrakk>\<Gamma> \<turnstile> e1 : Data(\<sigma>1); \<Gamma> \<turnstile> e2 : Data(\<sigma>2)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Pr e1 e2 : Data (DProd \<sigma>1 \<sigma>2)"
| t5[intro]: "\<lbrakk>\<Gamma> \<turnstile> e : Data(DProd \<sigma>1 \<sigma>2)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Fst e : Data(\<sigma>1)"
| t6[intro]: "\<lbrakk>\<Gamma> \<turnstile> e : Data(DProd \<sigma>1 \<sigma>2)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Snd e : Data(\<sigma>2)"
| t7[intro]: "\<lbrakk>\<Gamma> \<turnstile> e : Data(\<sigma>1)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> InL e : Data(DSum \<sigma>1 \<sigma>2)"
| t8[intro]: "\<lbrakk>\<Gamma> \<turnstile> e : Data(\<sigma>2)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> InR e : Data(DSum \<sigma>1 \<sigma>2)"
| t9[intro]: "\<lbrakk>x1\<sharp>\<Gamma>; x2\<sharp>\<Gamma>; \<Gamma> \<turnstile> e: Data(DSum \<sigma>1 \<sigma>2);
             ((x1,Data(\<sigma>1))#\<Gamma>) \<turnstile> e1 : \<tau>; ((x2,Data(\<sigma>2))#\<Gamma>) \<turnstile> e2 : \<tau>\<rbrakk>
             \<Longrightarrow> \<Gamma> \<turnstile> (Case e of inl x1 \<rightarrow> e1 | inr x2 \<rightarrow> e2) : \<tau>"

text \<open>typing judgements for Itrms\<close>

inductive
  Ityping :: "(name\<times>tyI) list\<Rightarrow>trmI\<Rightarrow>tyI\<Rightarrow>bool" (" _ I\<turnstile> _ : _ " [80,80,80] 80)
where
  t0[intro]: "\<lbrakk>valid \<Gamma>; (x,\<tau>)\<in>set \<Gamma>\<rbrakk>\<Longrightarrow> \<Gamma> I\<turnstile> IVar x : \<tau>"
| t1[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e1 : \<tau>1\<rightarrow>\<tau>2; \<Gamma> I\<turnstile> e2 : \<tau>1\<rbrakk>\<Longrightarrow> \<Gamma> I\<turnstile> IApp e1 e2 : \<tau>2"
| t2[intro]: "\<lbrakk>x\<sharp>\<Gamma>;((x,\<tau>1)#\<Gamma>) I\<turnstile> t : \<tau>2\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> ILam [x].t : \<tau>1\<rightarrow>\<tau>2"
| t3[intro]: "valid \<Gamma> \<Longrightarrow> \<Gamma> I\<turnstile> IUnit : DataI(OneI)"
| t4[intro]: "valid \<Gamma> \<Longrightarrow> \<Gamma> I\<turnstile> INat(n) : DataI(NatI)"
| t5[intro]: "\<Gamma> I\<turnstile> e : DataI(NatI) \<Longrightarrow> \<Gamma> I\<turnstile> ISucc(e) : DataI(NatI)"
| t6[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e : DataI(NatI)\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> IRef e : DataI (NatI)"
| t7[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e1 : DataI(NatI); \<Gamma> I\<turnstile> e2 : DataI(NatI)\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> e1\<mapsto>e2 : DataI(OneI)"
| t8[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e1 : DataI(NatI); \<Gamma> I\<turnstile> e2 : \<tau>\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> e1;;e2 : \<tau>"
| t9[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e: DataI(NatI); \<Gamma> I\<turnstile> e1 : \<tau>; \<Gamma> I\<turnstile> e2 : \<tau>\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> Iif e e1 e2 : \<tau>"

text \<open>capture-avoiding substitution\<close>

class subst =
  fixes subst :: "'a \<Rightarrow> name \<Rightarrow> 'a \<Rightarrow> 'a"  ("_[_::=_]" [100,100,100] 100)

instantiation trm :: subst
begin

nominal_primrec subst_trm
where
  "(Var x)[y::=t'] = (if x=y then t' else (Var x))"
| "(App t1 t2)[y::=t'] = App (t1[y::=t']) (t2[y::=t'])"
| "\<lbrakk>x\<sharp>y; x\<sharp>t'\<rbrakk> \<Longrightarrow> (Lam [x].t)[y::=t'] = Lam [x].(t[y::=t'])"
| "(Const n)[y::=t'] = Const n"
| "(Pr e1 e2)[y::=t'] = Pr (e1[y::=t']) (e2[y::=t'])"
| "(Fst e)[y::=t'] = Fst (e[y::=t'])"
| "(Snd e)[y::=t'] = Snd (e[y::=t'])"
| "(InL e)[y::=t'] = InL (e[y::=t'])"
| "(InR e)[y::=t'] = InR (e[y::=t'])"
| "\<lbrakk>z\<noteq>x; x\<sharp>y; x\<sharp>e; x\<sharp>e2; z\<sharp>y; z\<sharp>e; z\<sharp>e1; x\<sharp>t'; z\<sharp>t'\<rbrakk> \<Longrightarrow>
     (Case e of inl x \<rightarrow> e1 | inr z \<rightarrow> e2)[y::=t'] =
       (Case (e[y::=t']) of inl x \<rightarrow> (e1[y::=t']) | inr z \<rightarrow> (e2[y::=t']))"
  apply(finite_guess)+
  apply(rule TrueI)+
  apply(simp add: abs_fresh)+
  apply(fresh_guess)+
  done

instance ..

end

instantiation trmI :: subst
begin

nominal_primrec subst_trmI
where
  "(IVar x)[y::=t'] = (if x=y then t' else (IVar x))"
| "(IApp t1 t2)[y::=t'] = IApp (t1[y::=t']) (t2[y::=t'])"
| "\<lbrakk>x\<sharp>y; x\<sharp>t'\<rbrakk> \<Longrightarrow> (ILam [x].t)[y::=t'] = ILam [x].(t[y::=t'])"
| "(INat n)[y::=t'] = INat n"
| "(IUnit)[y::=t'] = IUnit"
| "(ISucc e)[y::=t'] = ISucc (e[y::=t'])"
| "(IAss e1 e2)[y::=t'] = IAss (e1[y::=t']) (e2[y::=t'])"
| "(IRef e)[y::=t'] = IRef (e[y::=t'])"
| "(ISeq e1 e2)[y::=t'] = ISeq (e1[y::=t']) (e2[y::=t'])"
| "(Iif e e1 e2)[y::=t'] = Iif (e[y::=t']) (e1[y::=t']) (e2[y::=t'])"
  apply(finite_guess)+
  apply(rule TrueI)+
  apply(simp add: abs_fresh)+
  apply(fresh_guess)+
  done

instance ..

end

lemma Isubst_eqvt[eqvt]:
  fixes pi::"name prm"
  and   t1::"trmI"
  and   t2::"trmI"
  and   x::"name"
  shows "pi\<bullet>(t1[x::=t2]) = ((pi\<bullet>t1)[(pi\<bullet>x)::=(pi\<bullet>t2)])"
  apply (nominal_induct t1 avoiding: x t2 rule: trmI.strong_induct)
  apply (simp_all add: subst_trmI.simps eqvts fresh_bij)
  done

lemma Isubst_supp:
  fixes t1::"trmI"
  and   t2::"trmI"
  and   x::"name"
  shows "((supp (t1[x::=t2]))::name set) \<subseteq> (supp t2)\<union>((supp t1)-{x})"
  apply (nominal_induct t1 avoiding: x t2 rule: trmI.strong_induct)
  apply (auto simp add: subst_trmI.simps trmI.supp supp_atm abs_supp supp_nat)
  apply blast+
  done

lemma Isubst_fresh:
  fixes x::"name"
  and   y::"name"
  and   t1::"trmI"
  and   t2::"trmI"
  assumes a: "x\<sharp>[y].t1" "x\<sharp>t2"
  shows "x\<sharp>(t1[y::=t2])"
using a
apply(auto simp add: fresh_def Isubst_supp)
apply(drule rev_subsetD)
apply(rule Isubst_supp)
apply(simp add: abs_supp)
done

text \<open>big-step evaluation for trms\<close>

inductive
  big :: "trm\<Rightarrow>trm\<Rightarrow>bool" ("_ \<Down> _" [80,80] 80)
where
  b0[intro]: "Lam [x].e \<Down> Lam [x].e"
| b1[intro]: "\<lbrakk>e1\<Down>Lam [x].e; e2\<Down>e2'; e[x::=e2']\<Down>e'\<rbrakk> \<Longrightarrow> App e1 e2 \<Down> e'"
| b2[intro]: "Const n \<Down> Const n"
| b3[intro]: "\<lbrakk>e1\<Down>e1'; e2\<Down>e2'\<rbrakk> \<Longrightarrow> Pr e1 e2 \<Down> Pr e1' e2'"
| b4[intro]: "e\<Down>Pr e1 e2 \<Longrightarrow> Fst e\<Down>e1"
| b5[intro]: "e\<Down>Pr e1 e2 \<Longrightarrow> Snd e\<Down>e2"
| b6[intro]: "e\<Down>e' \<Longrightarrow> InL e \<Down> InL e'"
| b7[intro]: "e\<Down>e' \<Longrightarrow> InR e \<Down> InR e'"
| b8[intro]: "\<lbrakk>e\<Down>InL e'; e1[x::=e']\<Down>e''\<rbrakk> \<Longrightarrow> Case e of inl x1 \<rightarrow> e1 | inr x2 \<rightarrow> e2 \<Down> e''"
| b9[intro]: "\<lbrakk>e\<Down>InR e'; e2[x::=e']\<Down>e''\<rbrakk> \<Longrightarrow> Case e of inl x1 \<rightarrow> e1 | inr x2 \<rightarrow> e2 \<Down> e''"

inductive
  Ibig :: "((nat\<Rightarrow>nat)\<times>trmI)\<Rightarrow>((nat\<Rightarrow>nat)\<times>trmI)\<Rightarrow>bool" ("_ I\<Down> _" [80,80] 80)
where
  m0[intro]: "(m,ILam [x].e) I\<Down> (m,ILam [x].e)"
| m1[intro]: "\<lbrakk>(m,e1)I\<Down>(m',ILam [x].e); (m',e2)I\<Down>(m'',e3); (m'',e[x::=e3])I\<Down>(m''',e4)\<rbrakk>
            \<Longrightarrow> (m,IApp e1 e2) I\<Down> (m''',e4)"
| m2[intro]: "(m,IUnit) I\<Down> (m,IUnit)"
| m3[intro]: "(m,INat(n))I\<Down>(m,INat(n))"
| m4[intro]: "(m,e)I\<Down>(m',INat(n)) \<Longrightarrow> (m,ISucc(e))I\<Down>(m',INat(n+1))"
| m5[intro]: "(m,e)I\<Down>(m',INat(n)) \<Longrightarrow> (m,IRef(e))I\<Down>(m',INat(m' n))"
| m6[intro]: "\<lbrakk>(m,e1)I\<Down>(m',INat(n1)); (m',e2)I\<Down>(m'',INat(n2))\<rbrakk> \<Longrightarrow> (m,e1\<mapsto>e2)I\<Down>(m''(n1:=n2),IUnit)"
| m7[intro]: "\<lbrakk>(m,e1)I\<Down>(m',IUnit); (m',e2)I\<Down>(m'',e)\<rbrakk> \<Longrightarrow> (m,e1;;e2)I\<Down>(m'',e)"
| m8[intro]: "\<lbrakk>(m,e)I\<Down>(m',INat(n)); n\<noteq>0; (m',e1)I\<Down>(m'',e)\<rbrakk> \<Longrightarrow> (m,Iif e e1 e2)I\<Down>(m'',e)"
| m9[intro]: "\<lbrakk>(m,e)I\<Down>(m',INat(0)); (m',e2)I\<Down>(m'',e)\<rbrakk> \<Longrightarrow> (m,Iif e e1 e2)I\<Down>(m'',e)"

text \<open>Translation functions\<close>

nominal_primrec
  trans :: "trm \<Rightarrow> trmI"
where
  "trans (Var x) = (IVar x)"
| "trans (App e1 e2) = IApp (trans e1) (trans e2)"
| "trans (Lam [x].e) = ILam [x].(trans e)"
| "trans (Const n) = INat n"
| "trans (Pr e1 e2) =
       (let limit = IRef(INat 0) in
        let v1 = (trans e1) in
        let v2 = (trans e2) in
        (((ISucc limit)\<mapsto>v1);;(ISucc(ISucc limit)\<mapsto>v2));;(INat 0 \<mapsto> ISucc(ISucc(limit))))"
| "trans (Fst e) = IRef (ISucc (trans e))"
| "trans (Snd e) = IRef (ISucc (ISucc (trans e)))"
| "trans (InL e) =
        (let limit = IRef(INat 0) in
         let v = (trans e) in
         (((ISucc limit)\<mapsto>INat(0));;(ISucc(ISucc limit)\<mapsto>v));;(INat 0 \<mapsto> ISucc(ISucc(limit))))"
| "trans (InR e) =
        (let limit = IRef(INat 0) in
         let v = (trans e) in
         (((ISucc limit)\<mapsto>INat(1));;(ISucc(ISucc limit)\<mapsto>v));;(INat 0 \<mapsto> ISucc(ISucc(limit))))"
| "\<lbrakk>x2\<noteq>x1; x1\<sharp>e; x1\<sharp>e2; x2\<sharp>e; x2\<sharp>e1\<rbrakk> \<Longrightarrow>
   trans (Case e of inl x1 \<rightarrow> e1 | inr x2 \<rightarrow> e2) =
       (let v = (trans e) in
        let v1 = (trans e1) in
        let v2 = (trans e2) in
        Iif (IRef (ISucc v)) (v2[x2::=IRef (ISucc (ISucc v))]) (v1[x1::=IRef (ISucc (ISucc v))]))"
  apply(finite_guess add: Let_def)+
  apply(rule TrueI)+
  apply(simp add: abs_fresh Isubst_fresh)+
  apply(fresh_guess add: Let_def)+
  done

nominal_primrec
  trans_type :: "ty \<Rightarrow> tyI"
where
  "trans_type (Data \<sigma>) = DataI(NatI)"
| "trans_type (\<tau>1\<rightarrow>\<tau>2) = (trans_type \<tau>1)\<rightarrow>(trans_type \<tau>2)"
  by (rule TrueI)+

end