(*  Title:      HOL/HOLCF/ex/Pattern_Match.thy
    Author:     Brian Huffman
*)

section {* An experimental pattern-matching notation *}

theory Pattern_Match
imports HOLCF
begin

default_sort pcpo

text {* FIXME: Find a proper way to un-hide constants. *}

abbreviation fail :: "'a match"
where "fail \<equiv> Fixrec.fail"

abbreviation succeed :: "'a \<rightarrow> 'a match"
where "succeed \<equiv> Fixrec.succeed"

abbreviation run :: "'a match \<rightarrow> 'a"
where "run \<equiv> Fixrec.run"

subsection {* Fatbar combinator *}

definition
  fatbar :: "('a \<rightarrow> 'b match) \<rightarrow> ('a \<rightarrow> 'b match) \<rightarrow> ('a \<rightarrow> 'b match)" where
  "fatbar = (\<Lambda> a b x. a\<cdot>x +++ b\<cdot>x)"

abbreviation
  fatbar_syn :: "['a \<rightarrow> 'b match, 'a \<rightarrow> 'b match] \<Rightarrow> 'a \<rightarrow> 'b match" (infixr "\<parallel>" 60)  where
  "m1 \<parallel> m2 == fatbar\<cdot>m1\<cdot>m2"

lemma fatbar1: "m\<cdot>x = \<bottom> \<Longrightarrow> (m \<parallel> ms)\<cdot>x = \<bottom>"
by (simp add: fatbar_def)

lemma fatbar2: "m\<cdot>x = fail \<Longrightarrow> (m \<parallel> ms)\<cdot>x = ms\<cdot>x"
by (simp add: fatbar_def)

lemma fatbar3: "m\<cdot>x = succeed\<cdot>y \<Longrightarrow> (m \<parallel> ms)\<cdot>x = succeed\<cdot>y"
by (simp add: fatbar_def)

lemmas fatbar_simps = fatbar1 fatbar2 fatbar3

lemma run_fatbar1: "m\<cdot>x = \<bottom> \<Longrightarrow> run\<cdot>((m \<parallel> ms)\<cdot>x) = \<bottom>"
by (simp add: fatbar_def)

lemma run_fatbar2: "m\<cdot>x = fail \<Longrightarrow> run\<cdot>((m \<parallel> ms)\<cdot>x) = run\<cdot>(ms\<cdot>x)"
by (simp add: fatbar_def)

lemma run_fatbar3: "m\<cdot>x = succeed\<cdot>y \<Longrightarrow> run\<cdot>((m \<parallel> ms)\<cdot>x) = y"
by (simp add: fatbar_def)

lemmas run_fatbar_simps [simp] = run_fatbar1 run_fatbar2 run_fatbar3

subsection {* Bind operator for match monad *}

definition match_bind :: "'a match \<rightarrow> ('a \<rightarrow> 'b match) \<rightarrow> 'b match" where
  "match_bind = (\<Lambda> m k. sscase\<cdot>(\<Lambda> _. fail)\<cdot>(fup\<cdot>k)\<cdot>(Rep_match m))"

lemma match_bind_simps [simp]:
  "match_bind\<cdot>\<bottom>\<cdot>k = \<bottom>"
  "match_bind\<cdot>fail\<cdot>k = fail"
  "match_bind\<cdot>(succeed\<cdot>x)\<cdot>k = k\<cdot>x"
unfolding match_bind_def fail_def succeed_def
by (simp_all add: cont_Rep_match cont_Abs_match
  Rep_match_strict Abs_match_inverse)

subsection {* Case branch combinator *}

definition
  branch :: "('a \<rightarrow> 'b match) \<Rightarrow> ('b \<rightarrow> 'c) \<rightarrow> ('a \<rightarrow> 'c match)" where
  "branch p \<equiv> \<Lambda> r x. match_bind\<cdot>(p\<cdot>x)\<cdot>(\<Lambda> y. succeed\<cdot>(r\<cdot>y))"

lemma branch_simps:
  "p\<cdot>x = \<bottom> \<Longrightarrow> branch p\<cdot>r\<cdot>x = \<bottom>"
  "p\<cdot>x = fail \<Longrightarrow> branch p\<cdot>r\<cdot>x = fail"
  "p\<cdot>x = succeed\<cdot>y \<Longrightarrow> branch p\<cdot>r\<cdot>x = succeed\<cdot>(r\<cdot>y)"
by (simp_all add: branch_def)

lemma branch_succeed [simp]: "branch succeed\<cdot>r\<cdot>x = succeed\<cdot>(r\<cdot>x)"
by (simp add: branch_def)

subsection {* Cases operator *}

definition
  cases :: "'a match \<rightarrow> 'a::pcpo" where
  "cases = Fixrec.run"

text {* rewrite rules for cases *}

lemma cases_strict [simp]: "cases\<cdot>\<bottom> = \<bottom>"
by (simp add: cases_def)

lemma cases_fail [simp]: "cases\<cdot>fail = \<bottom>"
by (simp add: cases_def)

lemma cases_succeed [simp]: "cases\<cdot>(succeed\<cdot>x) = x"
by (simp add: cases_def)

subsection {* Case syntax *}

nonterminal Case_pat and Case_syn and Cases_syn

syntax
  "_Case_syntax":: "['a, Cases_syn] => 'b"               ("(Case _ of/ _)" 10)
  "_Case1"      :: "[Case_pat, 'b] => Case_syn"          ("(2_ =>/ _)" 10)
  ""            :: "Case_syn => Cases_syn"               ("_")
  "_Case2"      :: "[Case_syn, Cases_syn] => Cases_syn"  ("_/ | _")
  "_strip_positions" :: "'a => Case_pat"                 ("_")

syntax (xsymbols)
  "_Case1"      :: "[Case_pat, 'b] => Case_syn"          ("(2_ \<Rightarrow>/ _)" 10)

translations
  "_Case_syntax x ms" == "CONST cases\<cdot>(ms\<cdot>x)"
  "_Case2 m ms" == "m \<parallel> ms"

text {* Parsing Case expressions *}

syntax
  "_pat" :: "'a"
  "_variable" :: "'a"
  "_noargs" :: "'a"

translations
  "_Case1 p r" => "CONST branch (_pat p)\<cdot>(_variable p r)"
  "_variable (_args x y) r" => "CONST csplit\<cdot>(_variable x (_variable y r))"
  "_variable _noargs r" => "CONST unit_when\<cdot>r"

parse_translation {*
(* rewrite (_pat x) => (succeed) *)
(* rewrite (_variable x t) => (Abs_cfun (%x. t)) *)
 [(@{syntax_const "_pat"}, fn _ => fn _ => Syntax.const @{const_syntax Fixrec.succeed}),
  Syntax_Trans.mk_binder_tr (@{syntax_const "_variable"}, @{const_syntax Abs_cfun})];
*}

text {* Printing Case expressions *}

syntax
  "_match" :: "'a"

print_translation {*
  let
    fun dest_LAM (Const (@{const_syntax Rep_cfun},_) $ Const (@{const_syntax unit_when},_) $ t) =
          (Syntax.const @{syntax_const "_noargs"}, t)
    |   dest_LAM (Const (@{const_syntax Rep_cfun},_) $ Const (@{const_syntax csplit},_) $ t) =
          let
            val (v1, t1) = dest_LAM t;
            val (v2, t2) = dest_LAM t1;
          in (Syntax.const @{syntax_const "_args"} $ v1 $ v2, t2) end
    |   dest_LAM (Const (@{const_syntax Abs_cfun},_) $ t) =
          let
            val abs =
              case t of Abs abs => abs
                | _ => ("x", dummyT, incr_boundvars 1 t $ Bound 0);
            val (x, t') = Syntax_Trans.atomic_abs_tr' abs;
          in (Syntax.const @{syntax_const "_variable"} $ x, t') end
    |   dest_LAM _ = raise Match; (* too few vars: abort translation *)

    fun Case1_tr' [Const(@{const_syntax branch},_) $ p, r] =
          let val (v, t) = dest_LAM r in
            Syntax.const @{syntax_const "_Case1"} $
              (Syntax.const @{syntax_const "_match"} $ p $ v) $ t
          end;

  in [(@{const_syntax Rep_cfun}, K Case1_tr')] end;
*}

translations
  "x" <= "_match (CONST succeed) (_variable x)"

subsection {* Pattern combinators for data constructors *}

type_synonym ('a, 'b) pat = "'a \<rightarrow> 'b match"

definition
  cpair_pat :: "('a, 'c) pat \<Rightarrow> ('b, 'd) pat \<Rightarrow> ('a \<times> 'b, 'c \<times> 'd) pat" where
  "cpair_pat p1 p2 = (\<Lambda>(x, y).
    match_bind\<cdot>(p1\<cdot>x)\<cdot>(\<Lambda> a. match_bind\<cdot>(p2\<cdot>y)\<cdot>(\<Lambda> b. succeed\<cdot>(a, b))))"

definition
  spair_pat ::
  "('a, 'c) pat \<Rightarrow> ('b, 'd) pat \<Rightarrow> ('a::pcpo \<otimes> 'b::pcpo, 'c \<times> 'd) pat" where
  "spair_pat p1 p2 = (\<Lambda>(:x, y:). cpair_pat p1 p2\<cdot>(x, y))"

definition
  sinl_pat :: "('a, 'c) pat \<Rightarrow> ('a::pcpo \<oplus> 'b::pcpo, 'c) pat" where
  "sinl_pat p = sscase\<cdot>p\<cdot>(\<Lambda> x. fail)"

definition
  sinr_pat :: "('b, 'c) pat \<Rightarrow> ('a::pcpo \<oplus> 'b::pcpo, 'c) pat" where
  "sinr_pat p = sscase\<cdot>(\<Lambda> x. fail)\<cdot>p"

definition
  up_pat :: "('a, 'b) pat \<Rightarrow> ('a u, 'b) pat" where
  "up_pat p = fup\<cdot>p"

definition
  TT_pat :: "(tr, unit) pat" where
  "TT_pat = (\<Lambda> b. If b then succeed\<cdot>() else fail)"

definition
  FF_pat :: "(tr, unit) pat" where
  "FF_pat = (\<Lambda> b. If b then fail else succeed\<cdot>())"

definition
  ONE_pat :: "(one, unit) pat" where
  "ONE_pat = (\<Lambda> ONE. succeed\<cdot>())"

text {* Parse translations (patterns) *}
translations
  "_pat (XCONST Pair x y)" => "CONST cpair_pat (_pat x) (_pat y)"
  "_pat (XCONST spair\<cdot>x\<cdot>y)" => "CONST spair_pat (_pat x) (_pat y)"
  "_pat (XCONST sinl\<cdot>x)" => "CONST sinl_pat (_pat x)"
  "_pat (XCONST sinr\<cdot>x)" => "CONST sinr_pat (_pat x)"
  "_pat (XCONST up\<cdot>x)" => "CONST up_pat (_pat x)"
  "_pat (XCONST TT)" => "CONST TT_pat"
  "_pat (XCONST FF)" => "CONST FF_pat"
  "_pat (XCONST ONE)" => "CONST ONE_pat"

text {* CONST version is also needed for constructors with special syntax *}
translations
  "_pat (CONST Pair x y)" => "CONST cpair_pat (_pat x) (_pat y)"
  "_pat (CONST spair\<cdot>x\<cdot>y)" => "CONST spair_pat (_pat x) (_pat y)"

text {* Parse translations (variables) *}
translations
  "_variable (XCONST Pair x y) r" => "_variable (_args x y) r"
  "_variable (XCONST spair\<cdot>x\<cdot>y) r" => "_variable (_args x y) r"
  "_variable (XCONST sinl\<cdot>x) r" => "_variable x r"
  "_variable (XCONST sinr\<cdot>x) r" => "_variable x r"
  "_variable (XCONST up\<cdot>x) r" => "_variable x r"
  "_variable (XCONST TT) r" => "_variable _noargs r"
  "_variable (XCONST FF) r" => "_variable _noargs r"
  "_variable (XCONST ONE) r" => "_variable _noargs r"

translations
  "_variable (CONST Pair x y) r" => "_variable (_args x y) r"
  "_variable (CONST spair\<cdot>x\<cdot>y) r" => "_variable (_args x y) r"

text {* Print translations *}
translations
  "CONST Pair (_match p1 v1) (_match p2 v2)"
      <= "_match (CONST cpair_pat p1 p2) (_args v1 v2)"
  "CONST spair\<cdot>(_match p1 v1)\<cdot>(_match p2 v2)"
      <= "_match (CONST spair_pat p1 p2) (_args v1 v2)"
  "CONST sinl\<cdot>(_match p1 v1)" <= "_match (CONST sinl_pat p1) v1"
  "CONST sinr\<cdot>(_match p1 v1)" <= "_match (CONST sinr_pat p1) v1"
  "CONST up\<cdot>(_match p1 v1)" <= "_match (CONST up_pat p1) v1"
  "CONST TT" <= "_match (CONST TT_pat) _noargs"
  "CONST FF" <= "_match (CONST FF_pat) _noargs"
  "CONST ONE" <= "_match (CONST ONE_pat) _noargs"

lemma cpair_pat1:
  "branch p\<cdot>r\<cdot>x = \<bottom> \<Longrightarrow> branch (cpair_pat p q)\<cdot>(csplit\<cdot>r)\<cdot>(x, y) = \<bottom>"
apply (simp add: branch_def cpair_pat_def)
apply (cases "p\<cdot>x", simp_all)
done

lemma cpair_pat2:
  "branch p\<cdot>r\<cdot>x = fail \<Longrightarrow> branch (cpair_pat p q)\<cdot>(csplit\<cdot>r)\<cdot>(x, y) = fail"
apply (simp add: branch_def cpair_pat_def)
apply (cases "p\<cdot>x", simp_all)
done

lemma cpair_pat3:
  "branch p\<cdot>r\<cdot>x = succeed\<cdot>s \<Longrightarrow>
   branch (cpair_pat p q)\<cdot>(csplit\<cdot>r)\<cdot>(x, y) = branch q\<cdot>s\<cdot>y"
apply (simp add: branch_def cpair_pat_def)
apply (cases "p\<cdot>x", simp_all)
apply (cases "q\<cdot>y", simp_all)
done

lemmas cpair_pat [simp] =
  cpair_pat1 cpair_pat2 cpair_pat3

lemma spair_pat [simp]:
  "branch (spair_pat p1 p2)\<cdot>r\<cdot>\<bottom> = \<bottom>"
  "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk>
     \<Longrightarrow> branch (spair_pat p1 p2)\<cdot>r\<cdot>(:x, y:) =
         branch (cpair_pat p1 p2)\<cdot>r\<cdot>(x, y)"
by (simp_all add: branch_def spair_pat_def)

lemma sinl_pat [simp]:
  "branch (sinl_pat p)\<cdot>r\<cdot>\<bottom> = \<bottom>"
  "x \<noteq> \<bottom> \<Longrightarrow> branch (sinl_pat p)\<cdot>r\<cdot>(sinl\<cdot>x) = branch p\<cdot>r\<cdot>x"
  "y \<noteq> \<bottom> \<Longrightarrow> branch (sinl_pat p)\<cdot>r\<cdot>(sinr\<cdot>y) = fail"
by (simp_all add: branch_def sinl_pat_def)

lemma sinr_pat [simp]:
  "branch (sinr_pat p)\<cdot>r\<cdot>\<bottom> = \<bottom>"
  "x \<noteq> \<bottom> \<Longrightarrow> branch (sinr_pat p)\<cdot>r\<cdot>(sinl\<cdot>x) = fail"
  "y \<noteq> \<bottom> \<Longrightarrow> branch (sinr_pat p)\<cdot>r\<cdot>(sinr\<cdot>y) = branch p\<cdot>r\<cdot>y"
by (simp_all add: branch_def sinr_pat_def)

lemma up_pat [simp]:
  "branch (up_pat p)\<cdot>r\<cdot>\<bottom> = \<bottom>"
  "branch (up_pat p)\<cdot>r\<cdot>(up\<cdot>x) = branch p\<cdot>r\<cdot>x"
by (simp_all add: branch_def up_pat_def)

lemma TT_pat [simp]:
  "branch TT_pat\<cdot>(unit_when\<cdot>r)\<cdot>\<bottom> = \<bottom>"
  "branch TT_pat\<cdot>(unit_when\<cdot>r)\<cdot>TT = succeed\<cdot>r"
  "branch TT_pat\<cdot>(unit_when\<cdot>r)\<cdot>FF = fail"
by (simp_all add: branch_def TT_pat_def)

lemma FF_pat [simp]:
  "branch FF_pat\<cdot>(unit_when\<cdot>r)\<cdot>\<bottom> = \<bottom>"
  "branch FF_pat\<cdot>(unit_when\<cdot>r)\<cdot>TT = fail"
  "branch FF_pat\<cdot>(unit_when\<cdot>r)\<cdot>FF = succeed\<cdot>r"
by (simp_all add: branch_def FF_pat_def)

lemma ONE_pat [simp]:
  "branch ONE_pat\<cdot>(unit_when\<cdot>r)\<cdot>\<bottom> = \<bottom>"
  "branch ONE_pat\<cdot>(unit_when\<cdot>r)\<cdot>ONE = succeed\<cdot>r"
by (simp_all add: branch_def ONE_pat_def)

subsection {* Wildcards, as-patterns, and lazy patterns *}

definition
  wild_pat :: "'a \<rightarrow> unit match" where
  "wild_pat = (\<Lambda> x. succeed\<cdot>())"

definition
  as_pat :: "('a \<rightarrow> 'b match) \<Rightarrow> 'a \<rightarrow> ('a \<times> 'b) match" where
  "as_pat p = (\<Lambda> x. match_bind\<cdot>(p\<cdot>x)\<cdot>(\<Lambda> a. succeed\<cdot>(x, a)))"

definition
  lazy_pat :: "('a \<rightarrow> 'b::pcpo match) \<Rightarrow> ('a \<rightarrow> 'b match)" where
  "lazy_pat p = (\<Lambda> x. succeed\<cdot>(cases\<cdot>(p\<cdot>x)))"

text {* Parse translations (patterns) *}
translations
  "_pat _" => "CONST wild_pat"

text {* Parse translations (variables) *}
translations
  "_variable _ r" => "_variable _noargs r"

text {* Print translations *}
translations
  "_" <= "_match (CONST wild_pat) _noargs"

lemma wild_pat [simp]: "branch wild_pat\<cdot>(unit_when\<cdot>r)\<cdot>x = succeed\<cdot>r"
by (simp add: branch_def wild_pat_def)

lemma as_pat [simp]:
  "branch (as_pat p)\<cdot>(csplit\<cdot>r)\<cdot>x = branch p\<cdot>(r\<cdot>x)\<cdot>x"
apply (simp add: branch_def as_pat_def)
apply (cases "p\<cdot>x", simp_all)
done

lemma lazy_pat [simp]:
  "branch p\<cdot>r\<cdot>x = \<bottom> \<Longrightarrow> branch (lazy_pat p)\<cdot>r\<cdot>x = succeed\<cdot>(r\<cdot>\<bottom>)"
  "branch p\<cdot>r\<cdot>x = fail \<Longrightarrow> branch (lazy_pat p)\<cdot>r\<cdot>x = succeed\<cdot>(r\<cdot>\<bottom>)"
  "branch p\<cdot>r\<cdot>x = succeed\<cdot>s \<Longrightarrow> branch (lazy_pat p)\<cdot>r\<cdot>x = succeed\<cdot>s"
apply (simp_all add: branch_def lazy_pat_def)
apply (cases "p\<cdot>x", simp_all)+
done

subsection {* Examples *}

term "Case t of (:up\<cdot>(sinl\<cdot>x), sinr\<cdot>y:) \<Rightarrow> (x, y)"

term "\<Lambda> t. Case t of up\<cdot>(sinl\<cdot>a) \<Rightarrow> a | up\<cdot>(sinr\<cdot>b) \<Rightarrow> b"

term "\<Lambda> t. Case t of (:up\<cdot>(sinl\<cdot>_), sinr\<cdot>x:) \<Rightarrow> x"

subsection {* ML code for generating definitions *}

ML {*
local open HOLCF_Library in

infixr 6 ->>;
infix 9 ` ;

val beta_rules =
  @{thms beta_cfun cont_id cont_const cont2cont_APP cont2cont_LAM'} @
  @{thms cont2cont_fst cont2cont_snd cont2cont_Pair};

val beta_ss =
  simpset_of (put_simpset HOL_basic_ss @{context} addsimps (@{thms simp_thms} @ beta_rules));

fun define_consts
    (specs : (binding * term * mixfix) list)
    (thy : theory)
    : (term list * thm list) * theory =
  let
    fun mk_decl (b, t, mx) = (b, fastype_of t, mx);
    val decls = map mk_decl specs;
    val thy = Cont_Consts.add_consts decls thy;
    fun mk_const (b, T, mx) = Const (Sign.full_name thy b, T);
    val consts = map mk_const decls;
    fun mk_def c (b, t, mx) =
      (Thm.def_binding b, Logic.mk_equals (c, t));
    val defs = map2 mk_def consts specs;
    val (def_thms, thy) =
      Global_Theory.add_defs false (map Thm.no_attributes defs) thy;
  in
    ((consts, def_thms), thy)
  end;

fun prove
    (thy : theory)
    (defs : thm list)
    (goal : term)
    (tacs : {prems: thm list, context: Proof.context} -> tactic list)
    : thm =
  let
    fun tac {prems, context} =
      rewrite_goals_tac context defs THEN
      EVERY (tacs {prems = map (rewrite_rule context defs) prems, context = context})
  in
    Goal.prove_global thy [] [] goal tac
  end;

fun get_vars_avoiding
    (taken : string list)
    (args : (bool * typ) list)
    : (term list * term list) =
  let
    val Ts = map snd args;
    val ns = Name.variant_list taken (Old_Datatype_Prop.make_tnames Ts);
    val vs = map Free (ns ~~ Ts);
    val nonlazy = map snd (filter_out (fst o fst) (args ~~ vs));
  in
    (vs, nonlazy)
  end;

(******************************************************************************)
(************** definitions and theorems for pattern combinators **************)
(******************************************************************************)

fun add_pattern_combinators
    (bindings : binding list)
    (spec : (term * (bool * typ) list) list)
    (lhsT : typ)
    (exhaust : thm)
    (case_const : typ -> term)
    (case_rews : thm list)
    (thy : theory) =
  let

    (* utility functions *)
    fun mk_pair_pat (p1, p2) =
      let
        val T1 = fastype_of p1;
        val T2 = fastype_of p2;
        val (U1, V1) = apsnd dest_matchT (dest_cfunT T1);
        val (U2, V2) = apsnd dest_matchT (dest_cfunT T2);
        val pat_typ = [T1, T2] --->
            (mk_prodT (U1, U2) ->> mk_matchT (mk_prodT (V1, V2)));
        val pat_const = Const (@{const_name cpair_pat}, pat_typ);
      in
        pat_const $ p1 $ p2
      end;
    fun mk_tuple_pat [] = succeed_const HOLogic.unitT
      | mk_tuple_pat ps = foldr1 mk_pair_pat ps;
    fun branch_const (T,U,V) =
      Const (@{const_name branch},
        (T ->> mk_matchT U) --> (U ->> V) ->> T ->> mk_matchT V);

    (* define pattern combinators *)
    local
      val tns = map (fst o dest_TFree) (snd (dest_Type lhsT));

      fun pat_eqn (i, (bind, (con, args))) : binding * term * mixfix =
        let
          val pat_bind = Binding.suffix_name "_pat" bind;
          val Ts = map snd args;
          val Vs =
              (map (K "'t") args)
              |> Old_Datatype_Prop.indexify_names
              |> Name.variant_list tns
              |> map (fn t => TFree (t, @{sort pcpo}));
          val patNs = Old_Datatype_Prop.indexify_names (map (K "pat") args);
          val patTs = map2 (fn T => fn V => T ->> mk_matchT V) Ts Vs;
          val pats = map Free (patNs ~~ patTs);
          val fail = mk_fail (mk_tupleT Vs);
          val (vs, nonlazy) = get_vars_avoiding patNs args;
          val rhs = big_lambdas vs (mk_tuple_pat pats ` mk_tuple vs);
          fun one_fun (j, (_, args')) =
            let
              val (vs', nonlazy) = get_vars_avoiding patNs args';
            in if i = j then rhs else big_lambdas vs' fail end;
          val funs = map_index one_fun spec;
          val body = list_ccomb (case_const (mk_matchT (mk_tupleT Vs)), funs);
        in
          (pat_bind, lambdas pats body, NoSyn)
        end;
    in
      val ((pat_consts, pat_defs), thy) =
          define_consts (map_index pat_eqn (bindings ~~ spec)) thy
    end;

    (* syntax translations for pattern combinators *)
    local
      fun syntax c = Lexicon.mark_const (fst (dest_Const c));
      fun app s (l, r) = Ast.mk_appl (Ast.Constant s) [l, r];
      val capp = app @{const_syntax Rep_cfun};
      val capps = Library.foldl capp

      fun app_var x = Ast.mk_appl (Ast.Constant "_variable") [x, Ast.Variable "rhs"];
      fun app_pat x = Ast.mk_appl (Ast.Constant "_pat") [x];
      fun args_list [] = Ast.Constant "_noargs"
        | args_list xs = foldr1 (app "_args") xs;
      fun one_case_trans (pat, (con, args)) =
        let
          val cname = Ast.Constant (syntax con);
          val pname = Ast.Constant (syntax pat);
          val ns = 1 upto length args;
          val xs = map (fn n => Ast.Variable ("x"^(string_of_int n))) ns;
          val ps = map (fn n => Ast.Variable ("p"^(string_of_int n))) ns;
          val vs = map (fn n => Ast.Variable ("v"^(string_of_int n))) ns;
        in
          [Syntax.Parse_Rule (app_pat (capps (cname, xs)),
            Ast.mk_appl pname (map app_pat xs)),
           Syntax.Parse_Rule (app_var (capps (cname, xs)),
            app_var (args_list xs)),
           Syntax.Print_Rule (capps (cname, ListPair.map (app "_match") (ps,vs)),
            app "_match" (Ast.mk_appl pname ps, args_list vs))]
        end;
      val trans_rules : Ast.ast Syntax.trrule list =
          maps one_case_trans (pat_consts ~~ spec);
    in
      val thy = Sign.add_trrules trans_rules thy;
    end;

    (* prove strictness and reduction rules of pattern combinators *)
    local
      val tns = map (fst o dest_TFree) (snd (dest_Type lhsT));
      val rn = singleton (Name.variant_list tns) "'r";
      val R = TFree (rn, @{sort pcpo});
      fun pat_lhs (pat, args) =
        let
          val Ts = map snd args;
          val Vs =
              (map (K "'t") args)
              |> Old_Datatype_Prop.indexify_names
              |> Name.variant_list (rn::tns)
              |> map (fn t => TFree (t, @{sort pcpo}));
          val patNs = Old_Datatype_Prop.indexify_names (map (K "pat") args);
          val patTs = map2 (fn T => fn V => T ->> mk_matchT V) Ts Vs;
          val pats = map Free (patNs ~~ patTs);
          val k = Free ("rhs", mk_tupleT Vs ->> R);
          val branch1 = branch_const (lhsT, mk_tupleT Vs, R);
          val fun1 = (branch1 $ list_comb (pat, pats)) ` k;
          val branch2 = branch_const (mk_tupleT Ts, mk_tupleT Vs, R);
          val fun2 = (branch2 $ mk_tuple_pat pats) ` k;
          val taken = "rhs" :: patNs;
        in (fun1, fun2, taken) end;
      fun pat_strict (pat, (con, args)) =
        let
          val (fun1, fun2, taken) = pat_lhs (pat, args);
          val defs = @{thm branch_def} :: pat_defs;
          val goal = mk_trp (mk_strict fun1);
          val rules = @{thms match_bind_simps} @ case_rews;
          fun tacs ctxt = [simp_tac (put_simpset beta_ss ctxt addsimps rules) 1];
        in prove thy defs goal (tacs o #context) end;
      fun pat_apps (i, (pat, (con, args))) =
        let
          val (fun1, fun2, taken) = pat_lhs (pat, args);
          fun pat_app (j, (con', args')) =
            let
              val (vs, nonlazy) = get_vars_avoiding taken args';
              val con_app = list_ccomb (con', vs);
              val assms = map (mk_trp o mk_defined) nonlazy;
              val rhs = if i = j then fun2 ` mk_tuple vs else mk_fail R;
              val concl = mk_trp (mk_eq (fun1 ` con_app, rhs));
              val goal = Logic.list_implies (assms, concl);
              val defs = @{thm branch_def} :: pat_defs;
              val rules = @{thms match_bind_simps} @ case_rews;
              fun tacs ctxt = [asm_simp_tac (put_simpset beta_ss ctxt addsimps rules) 1];
            in prove thy defs goal (tacs o #context) end;
        in map_index pat_app spec end;
    in
      val pat_stricts = map pat_strict (pat_consts ~~ spec);
      val pat_apps = flat (map_index pat_apps (pat_consts ~~ spec));
    end;

  in
    (pat_stricts @ pat_apps, thy)
  end

end
*}

(*
Cut from HOLCF/Tools/domain_constructors.ML
in function add_domain_constructors:

    ( * define and prove theorems for pattern combinators * )
    val (pat_thms : thm list, thy : theory) =
      let
        val bindings = map #1 spec;
        fun prep_arg (lazy, sel, T) = (lazy, T);
        fun prep_con c (b, args, mx) = (c, map prep_arg args);
        val pat_spec = map2 prep_con con_consts spec;
      in
        add_pattern_combinators bindings pat_spec lhsT
          exhaust case_const cases thy
      end

*)

end


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

abbreviation TransitionsLate_judge ("_ \<longmapsto>\<^sub>l _" [80, 80] 80) where "P \<longmapsto>\<^sub>l Rs \<equiv> transitions P Rs"
abbreviation TransitionsEarly_judge ("_ \<longmapsto>\<^sub>e _" [80, 80] 80) where "P \<longmapsto>\<^sub>e Rs \<equiv> TransitionsEarly P Rs"

abbreviation Transitions_InputjudgeLate ("_<_> \<prec>\<^sub>l _" [80, 80] 80) where "a<x> \<prec>\<^sub>l P' \<equiv> (Late_Semantics.BoundR (Late_Semantics.InputS a) x P')"
abbreviation Transitions_OutputjudgeLate ("_[_] \<prec>\<^sub>l _" [80, 80] 80) where "a[b] \<prec>\<^sub>l P' \<equiv> (Late_Semantics.FreeR (Late_Semantics.OutputR a b) P')"
abbreviation Transitions_BoundOutputjudgeLate ("_<\<nu>_> \<prec>\<^sub>l _" [80, 80] 80) where "a<\<nu>x> \<prec>\<^sub>l P' \<equiv> (Late_Semantics.BoundR (Late_Semantics.BoundOutputS a) x P')"
abbreviation Transitions_TaujudgeLate ("\<tau> \<prec>\<^sub>l _" 80) where "\<tau> \<prec>\<^sub>l P' \<equiv> (Late_Semantics.FreeR Late_Semantics.TauR P')"

abbreviation Transitions_InputjudgeEarly ("_<_> \<prec>\<^sub>e _" [80, 80] 80) where "a<x> \<prec>\<^sub>e P' \<equiv> (Early_Semantics.FreeR (Early_Semantics.InputR a x) P')"
abbreviation Transitions_OutputjudgeEarly ("_[_] \<prec>\<^sub>e _" [80, 80] 80) where "a[b] \<prec>\<^sub>e P' \<equiv> (Early_Semantics.FreeR (Early_Semantics.OutputR a b) P')"
abbreviation Transitions_BoundOutputjudgeEarly ("_<\<nu>_> \<prec>\<^sub>e _" [80, 80] 80) where "a<\<nu>x> \<prec>\<^sub>e P' \<equiv>(Early_Semantics.BoundOutputR a x P')"
abbreviation Transitions_TaujudgeEarly ("\<tau> \<prec>\<^sub>e _" 80) where "\<tau> \<prec>\<^sub>e P' \<equiv> (Early_Semantics.FreeR Early_Semantics.TauR P')"

lemma earlyLateOutput:
  fixes P  :: pi
  and   a  :: name
  and   b  :: name
  and   P' :: pi

  assumes "P \<longmapsto>\<^sub>ea[b] \<prec>\<^sub>e P'"

  shows "P \<longmapsto>\<^sub>la[b] \<prec>\<^sub>l P'"
using assms
proof(nominal_induct rule: Early_Semantics.outputInduct)
  case(Output a b P)
  show ?case by(rule Late_Semantics.Output)
next
  case(Match P a b P' c)
  have "P \<longmapsto>\<^sub>la[b] \<prec>\<^sub>l P'" by fact
  thus ?case by(rule Late_Semantics.Match)
next
  case(Mismatch P a b P' c d)
  from \<open>P \<longmapsto>\<^sub>la[b] \<prec>\<^sub>l P'\<close> \<open>c \<noteq> d\<close>
  show ?case by(rule Late_Semantics.Mismatch)
next
  case(Sum1 P a b P' Q)
  have "P \<longmapsto>\<^sub>la[b] \<prec>\<^sub>l P'" by fact
  thus ?case by(rule Late_Semantics.Sum1)
next
  case(Sum2 Q a b Q' P)
  have "Q \<longmapsto>\<^sub>la[b] \<prec>\<^sub>l Q'" by fact
  thus ?case by(rule Late_Semantics.Sum2)
next
  case(Par1 P a b P' Q)
  have "P \<longmapsto>\<^sub>la[b] \<prec>\<^sub>l P'" by fact
  thus ?case by(rule Late_Semantics.Par1F)
next
  case(Par2 Q a b Q' P)
  have "Q \<longmapsto>\<^sub>la[b] \<prec>\<^sub>l Q'" by fact
  thus ?case by(rule Late_Semantics.Par2F)
next
  case(Res P a b P' x)
  have "P \<longmapsto>\<^sub>la[b] \<prec>\<^sub>l P'" and "x \<noteq> a" and "x \<noteq> b" by fact+
  thus ?case by(force intro: Late_Semantics.ResF)
next
  case(Bang P a b P')
  have "P \<parallel> !P \<longmapsto>\<^sub>la[b] \<prec>\<^sub>l P'" by fact
  thus ?case by(rule Late_Semantics.Bang)
qed

lemma lateEarlyOutput:
  fixes P  :: pi
  and   a  :: name
  and   b  :: name
  and   P' :: pi

  assumes "P \<longmapsto>\<^sub>la[b] \<prec>\<^sub>l P'"

  shows "P \<longmapsto>\<^sub>ea[b] \<prec>\<^sub>e P'"
using assms
proof(nominal_induct rule: Late_Semantics.outputInduct)
  case(Output a b P)
  thus ?case by(rule Early_Semantics.Output)
next
  case(Match P a b P' c)
  have "P \<longmapsto>\<^sub>ea[b] \<prec>\<^sub>e P'" by fact
  thus ?case by(rule Early_Semantics.Match)
next
  case(Mismatch P a b P' c d)
  have "P \<longmapsto>\<^sub>ea[b] \<prec>\<^sub>e P'" and "c \<noteq> d" by fact+
  thus ?case by(rule Early_Semantics.Mismatch)
next
  case(Sum1 P a b P' Q)
  have "P \<longmapsto>\<^sub>ea[b] \<prec>\<^sub>e P'" by fact
  thus ?case by(rule Early_Semantics.Sum1)
next
  case(Sum2 Q a b Q' P)
  have "Q \<longmapsto>\<^sub>ea[b] \<prec>\<^sub>e Q'" by fact
  thus ?case by(rule Early_Semantics.Sum2)
next
  case(Par1 P a b P' Q)
  have "P \<longmapsto>\<^sub>ea[b] \<prec>\<^sub>e P'" by fact
  thus ?case by(rule Early_Semantics.Par1F)
next
  case(Par2 Q a b Q' P)
  have "Q \<longmapsto>\<^sub>ea[b] \<prec>\<^sub>e Q'" by fact
  thus ?case by(rule Early_Semantics.Par2F)
next
  case(Res P a b P' x)
  have "P \<longmapsto>\<^sub>ea[b] \<prec>\<^sub>e P'" and "x \<noteq> a" and "x \<noteq> b" by fact+
  thus ?case by(force intro: Early_Semantics.ResF)
next
  case(Bang P a b P')
  have "P \<parallel> !P \<longmapsto>\<^sub>ea[b] \<prec>\<^sub>e P'" by fact
  thus ?case by(rule Early_Semantics.Bang)
qed

lemma outputEq:
  fixes P  :: pi
  and   a  :: name
  and   b  :: name
  and   P' :: pi

  shows "P \<longmapsto>\<^sub>ea[b] \<prec>\<^sub>e P' = P \<longmapsto>\<^sub>la[b] \<prec>\<^sub>l P'"
by(auto intro: lateEarlyOutput earlyLateOutput)

lemma lateEarlyBoundOutput:
  fixes P  :: pi
  and   a  :: name
  and   x  :: name
  and   P' :: pi

  assumes "P \<longmapsto>\<^sub>la<\<nu>x> \<prec>\<^sub>l P'"

  shows "P \<longmapsto>\<^sub>ea<\<nu>x> \<prec>\<^sub>e P'"
proof -
  have Goal: "\<And>P a x P'. \<lbrakk>P \<longmapsto>\<^sub>la<\<nu>x> \<prec>\<^sub>l P'; x \<sharp> P\<rbrakk> \<Longrightarrow> P \<longmapsto>\<^sub>ea<\<nu>x> \<prec>\<^sub>e P'"
  proof -
    fix P a x P'
    assume "P \<longmapsto>\<^sub>l a<\<nu>x> \<prec>\<^sub>l P'" and "x \<sharp> P"
    thus "P \<longmapsto>\<^sub>ea<\<nu>x> \<prec>\<^sub>e P'"
    proof(nominal_induct rule: Late_Semantics.boundOutputInduct)
      case(Match P a x P' b)
      have "P \<longmapsto>\<^sub>e a<\<nu>x> \<prec>\<^sub>e P'" by fact
      thus ?case by(rule Early_Semantics.Match)
    next
      case(Mismatch P a x P' b c)
      have "P \<longmapsto>\<^sub>e a<\<nu>x> \<prec>\<^sub>e P'" and "b \<noteq> c" by fact+
      thus ?case by(rule Early_Semantics.Mismatch)
    next
      case(Open P a x P')
      have "P \<longmapsto>\<^sub>la[x] \<prec>\<^sub>l P'" by fact
      hence "P \<longmapsto>\<^sub>ea[x] \<prec>\<^sub>e P'" by(rule lateEarlyOutput)
      moreover have "a \<noteq> x" by fact
      ultimately show ?case by(rule Early_Semantics.Open)
    next
      case(Sum1 P Q a x P')
      have "P \<longmapsto>\<^sub>e a<\<nu>x> \<prec>\<^sub>e P'" by fact
      thus ?case by(rule Early_Semantics.Sum1)
    next
      case(Sum2 P Q a x Q')
      have "Q \<longmapsto>\<^sub>e a<\<nu>x> \<prec>\<^sub>e Q'" by fact
      thus ?case by(rule Early_Semantics.Sum2)
    next
      case(Par1 P P' Q a x)
      have "P \<longmapsto>\<^sub>e a<\<nu>x> \<prec>\<^sub>e P'" and "x \<sharp> Q" by fact+
      thus ?case by(rule Early_Semantics.Par1B)
    next
      case(Par2 P Q Q' a x)
      have "Q \<longmapsto>\<^sub>e a<\<nu>x> \<prec>\<^sub>e Q'" and "x \<sharp> P" by fact+
      thus ?case by(rule Early_Semantics.Par2B)
    next
      case(Res P P' a x y)
      have "P \<longmapsto>\<^sub>e a<\<nu>x> \<prec>\<^sub>e P'" and "y \<noteq> a" and "y \<noteq> x" by fact+
      thus ?case by(force intro: Early_Semantics.ResB)
    next
      case(Bang P a x P')
      have "P \<parallel> !P \<longmapsto>\<^sub>e a<\<nu>x> \<prec>\<^sub>e P'" by fact
      thus ?case by(rule Early_Semantics.Bang)
    qed
  qed

  have "\<exists>c::name. c \<sharp> (P, P', x)" by(blast intro: name_exists_fresh)
  then obtain c::name where cFreshP: "c \<sharp> P" and cFreshP': "c \<sharp> P'" and "c \<noteq> x"
    by(force simp add: fresh_prod)
  from assms cFreshP' have "P \<longmapsto>\<^sub>la<\<nu>c> \<prec>\<^sub>l ([(x, c)] \<bullet> P')"
    by(simp add: Late_Semantics.alphaBoundResidual)
  hence "P \<longmapsto>\<^sub>e a<\<nu>c> \<prec>\<^sub>e ([(x, c)] \<bullet> P')" using cFreshP
    by(rule Goal)
  moreover from cFreshP' \<open>c \<noteq> x\<close> have "x \<sharp> [(x, c)] \<bullet> P'" by(simp add: name_fresh_left name_calc)
  ultimately show ?thesis by(simp add: Early_Semantics.alphaBoundOutput name_swap)
qed

lemma earlyLateBoundOutput:
  fixes P  :: pi
  and   a  :: name
  and   x  :: name
  and   P' :: pi

  assumes "P \<longmapsto>\<^sub>ea<\<nu>x> \<prec>\<^sub>e P'"

  shows "P \<longmapsto>\<^sub>la<\<nu>x> \<prec>\<^sub>l P'"
proof -
  have Goal: "\<And>P a x P'. \<lbrakk>P \<longmapsto>\<^sub>ea<\<nu>x> \<prec>\<^sub>e P'; x \<sharp> P\<rbrakk> \<Longrightarrow> P \<longmapsto>\<^sub>la<\<nu>x> \<prec>\<^sub>l P'"
  proof -
    fix P a x P'
    assume "P \<longmapsto>\<^sub>e a<\<nu>x> \<prec> P'" and "x \<sharp> P"
    thus "P \<longmapsto>\<^sub>la<\<nu>x> \<prec>\<^sub>l P'"
    proof(nominal_induct rule: Early_Semantics.boundOutputInduct)
      case(Match P a x P' b)
      have "P \<longmapsto>\<^sub>l a<\<nu>x> \<prec> P'" by fact
      thus ?case by(rule Late_Semantics.Match)
    next
      case(Mismatch P a x P' b c)
      have "P \<longmapsto>\<^sub>l a<\<nu>x> \<prec> P'" and "b \<noteq> c" by fact+
      thus ?case by(rule Late_Semantics.Mismatch)
    next
      case(Open P a x P')
      have "P \<longmapsto>\<^sub>ea[x] \<prec>\<^sub>e P'" by fact
      hence "P \<longmapsto>\<^sub>la[x] \<prec>\<^sub>l P'" by(rule earlyLateOutput)
      moreover have "a \<noteq> x" by fact
      ultimately show ?case by(rule Late_Semantics.Open)
    next
      case(Sum1 P Q a x P')
      have "P \<longmapsto>\<^sub>l a<\<nu>x> \<prec>\<^sub>l P'" by fact
      thus ?case by(rule Late_Semantics.Sum1)
    next
      case(Sum2 P Q a x Q')
      have "Q \<longmapsto>\<^sub>l a<\<nu>x> \<prec>\<^sub>l Q'" by fact
      thus ?case by(rule Late_Semantics.Sum2)
    next
      case(Par1 P P' Q a x)
      have "P \<longmapsto>\<^sub>l a<\<nu>x> \<prec>\<^sub>l P'" and "x \<sharp> Q" by fact+
      thus ?case by(rule Late_Semantics.Par1B)
    next
      case(Par2 P Q Q' a x)
      have "Q \<longmapsto>\<^sub>l a<\<nu>x> \<prec>\<^sub>l Q'" and "x \<sharp> P" by fact+
      thus ?case by(rule Late_Semantics.Par2B)
    next
      case(Res P P' a x y)
      have "P \<longmapsto>\<^sub>l a<\<nu>x> \<prec>\<^sub>l P'" and "y \<noteq> a" and "y \<noteq> x" by fact+
      thus ?case by(force intro: Late_Semantics.ResB)
    next
      case(Bang P a x P')
      have "P \<parallel> !P \<longmapsto>\<^sub>l a<\<nu>x> \<prec> P'" by fact
      thus ?case by(rule Late_Semantics.Bang)
    qed
  qed

  have "\<exists>c::name. c \<sharp> (P, P', x)" by(blast intro: name_exists_fresh)
  then obtain c::name where cFreshP: "c \<sharp> P" and cFreshP': "c \<sharp> P'" and "c \<noteq> x"
    by(force simp add: fresh_prod)
  from assms cFreshP' have "P \<longmapsto>\<^sub>ea<\<nu>c> \<prec>\<^sub>e ([(x, c)] \<bullet> P')"
    by(simp add: Early_Semantics.alphaBoundOutput)
  hence "P \<longmapsto>\<^sub>l a<\<nu>c> \<prec>\<^sub>l ([(x, c)] \<bullet> P')" using cFreshP
    by(rule Goal)
  moreover from cFreshP' \<open>c \<noteq> x\<close> have "x \<sharp> [(x, c)] \<bullet> P'" by(simp add: name_fresh_left name_calc)
  ultimately show ?thesis by(simp add: Late_Semantics.alphaBoundResidual name_swap)
qed

lemma BoundOutputEq:
  fixes P  :: pi
  and   a  :: name
  and   x  :: name
  and   P' :: pi

  shows "P \<longmapsto>\<^sub>ea<\<nu>x> \<prec>\<^sub>e P' = P \<longmapsto>\<^sub>la<\<nu>x> \<prec>\<^sub>l P'"
by(auto intro: earlyLateBoundOutput lateEarlyBoundOutput)

lemma lateEarlyInput:
  fixes P  :: pi
  and   a  :: name
  and   x  :: name
  and   P' :: pi
  and   u  :: name

  assumes PTrans: "P \<longmapsto>\<^sub>l a<x> \<prec>\<^sub>l P'"

  shows "P \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e (P'[x::=u])"
proof -
  have Goal: "\<And>P a x P' u. \<lbrakk>P \<longmapsto>\<^sub>l a<x> \<prec>\<^sub>l P'; x \<sharp> P\<rbrakk> \<Longrightarrow> P \<longmapsto>\<^sub>e a<u> \<prec>\<^sub>e (P'[x::=u])"
  proof -
    fix P a x P' u
    assume "P \<longmapsto>\<^sub>l a<x> \<prec>\<^sub>l P'" and "x \<sharp> P"
    thus "P \<longmapsto>\<^sub>e a<u> \<prec>\<^sub>e (P'[x::=u])"
    proof(nominal_induct avoiding: u rule: Late_Semantics.inputInduct)
      case(Input a x P)
      thus ?case by(rule Early_Semantics.Input)
    next
      case(Match P a x P' b u)
      have "P \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e (P'[x::=u])" by fact
      thus ?case by(rule Early_Semantics.Match)
    next
      case(Mismatch P a x P' b c u)
      have "P \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e (P'[x::=u])" by fact
      moreover have "b\<noteq>c" by fact
      ultimately show ?case by(rule Early_Semantics.Mismatch)
    next
      case(Sum1 P Q a x P')
      have "P \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e (P'[x::=u])" by fact
      thus ?case by(rule Early_Semantics.Sum1)
    next
      case(Sum2 P Q a x Q')
      have "Q \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e (Q'[x::=u])" by fact
      thus ?case by(rule Early_Semantics.Sum2)
    next
      case(Par1 P P' Q a x)
      have "P \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e (P'[x::=u])" by fact
      hence "P \<parallel> Q \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e (P'[x::=u] \<parallel> Q)" by(rule Early_Semantics.Par1F)
      moreover have "x \<sharp> Q" by fact
      ultimately show ?case by(simp add: forget)
    next
      case(Par2 P Q Q' a x)
      have "Q \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e (Q'[x::=u])" by fact
      hence "P \<parallel> Q \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e (P \<parallel> Q'[x::=u])" by(rule Early_Semantics.Par2F)
      moreover have "x \<sharp> P" by fact
      ultimately show ?case by(simp add: forget)
    next
      case(Res P P' a x y u)
      have "P \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e (P'[x::=u])" and "y \<noteq> a" and yinequ: "y \<sharp> u" by fact+
      hence "<\<nu>y>P \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e <\<nu>y>(P'[x::=u])" by(force intro: Early_Semantics.ResF)
      moreover have "y \<noteq> x" by fact
      ultimately show ?case using yinequ by simp
    next
      case(Bang P a x P' u)
      have "P \<parallel> !P \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e (P'[x::=u])" by fact
      thus ?case by(rule Early_Semantics.Bang)
    qed
  qed

  have "\<exists>c::name. c \<sharp> (P, P')" by(blast intro: name_exists_fresh)
  then obtain c::name where cFreshP: "c \<sharp> P" and cFreshP': "c \<sharp> P'"
    by(force simp add: fresh_prod)
  from assms cFreshP' have "P \<longmapsto>\<^sub>la<c> \<prec>\<^sub>l ([(x, c)] \<bullet> P')"
    by(simp add: Late_Semantics.alphaBoundResidual)
  hence "P \<longmapsto>\<^sub>e a<u> \<prec>\<^sub>e ([(x, c)] \<bullet> P')[c::=u]" using cFreshP
    by(rule Goal)
  with cFreshP' show ?thesis by(simp add: renaming name_swap)
qed

lemma earlyLateInput:
  fixes P  :: pi
  and   a  :: name
  and   x  :: name
  and   P' :: pi
  and   u  :: name
  and   C  :: "'a::fs_name"

  assumes "P \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e P'"
  and     "x \<sharp> P"

  shows "\<exists>P''. P \<longmapsto>\<^sub>la<x> \<prec>\<^sub>l P'' \<and> P' = P''[x::=u]"
proof -
  {
    fix P a u P'
    assume "P \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e P'"
    hence "\<exists>P'' x. P \<longmapsto>\<^sub>la<x> \<prec>\<^sub>l P'' \<and> P' = P''[x::=u]"
    proof(nominal_induct rule: Early_Semantics.inputInduct)
      case(cInput a x P u)
      have "a<x>.P \<longmapsto>\<^sub>la<x> \<prec> P" by(rule Late_Semantics.Input)
      thus ?case by blast
    next
      case(cMatch P a u P' b)
      have "\<exists>P'' x. P \<longmapsto>\<^sub>la<x> \<prec> P'' \<and> P' = P''[x::=u]" by fact
      then obtain P'' x where PTrans: "P \<longmapsto>\<^sub>la<x> \<prec> P''" and P'eqP'': "P' = P''[x::=u]" by blast
      from PTrans have "[b\<frown>b]P \<longmapsto>\<^sub>la<x> \<prec> P''" by(rule Late_Semantics.Match)
      with P'eqP'' show ?case by blast
    next
      case(cMismatch P a u P' b c)
      have "\<exists>P'' x. P \<longmapsto>\<^sub>la<x> \<prec> P'' \<and> P' = P''[x::=u]" by fact
      then obtain P'' x where PTrans: "P \<longmapsto>\<^sub>la<x> \<prec> P''" and P'eqP'': "P' = P''[x::=u]" by blast
      have "b \<noteq> c" by fact
      with PTrans have "[b\<noteq>c]P \<longmapsto>\<^sub>la<x> \<prec> P''" by(rule Late_Semantics.Mismatch)
      with P'eqP'' show ?case by blast
    next
      case(cSum1 P a u P' Q)
      have "\<exists>P'' x. P \<longmapsto>\<^sub>la<x> \<prec> P'' \<and> P' = P''[x::=u]" by fact
      then obtain P'' x where PTrans: "P \<longmapsto>\<^sub>la<x> \<prec> P''" and P'eqP'': "P' = P''[x::=u]" by blast
      from PTrans have "P \<oplus> Q \<longmapsto>\<^sub>la<x> \<prec> P''" by(rule Late_Semantics.Sum1)
      with P'eqP'' show ?case by blast
    next
      case(cSum2 Q a u Q' P)
      have "\<exists>Q'' x. Q \<longmapsto>\<^sub>la<x> \<prec> Q'' \<and> Q' = Q''[x::=u]" by fact
      then obtain Q'' x where QTrans: "Q \<longmapsto>\<^sub>la<x> \<prec> Q''" and Q'eqQ'': "Q' = Q''[x::=u]" by blast
      from QTrans have "P \<oplus> Q \<longmapsto>\<^sub>la<x> \<prec> Q''" by(rule Late_Semantics.Sum2)
      with Q'eqQ'' show ?case by blast
    next
      case(cPar1 P a u P' Q)
      have "\<exists>P'' x. P \<longmapsto>\<^sub>la<x> \<prec> P'' \<and> P' = P''[x::=u]" by fact
      then obtain P'' x where PTrans: "P \<longmapsto>\<^sub>la<x> \<prec> P''" and P'eqP'': "P' = P''[x::=u]" by blast
      have "\<exists>c::name. c \<sharp> (Q, P'')" by(blast intro: name_exists_fresh)
      then obtain c::name where cFreshQ: "c \<sharp> Q" and cFreshP'': "c \<sharp> P''" by(force simp add: fresh_prod)
      from PTrans cFreshP'' have "P \<longmapsto>\<^sub>la<c> \<prec> [(x, c)] \<bullet> P''" by(simp add: Late_Semantics.alphaBoundResidual)
      hence "P \<parallel> Q \<longmapsto>\<^sub>la<c> \<prec> ([(x, c)] \<bullet> P'') \<parallel> Q" using \<open>c \<sharp> Q\<close> by(rule Late_Semantics.Par1B)
      moreover from cFreshQ cFreshP'' P'eqP'' have "P' \<parallel> Q = (([(x, c)] \<bullet> P'') \<parallel> Q)[c::=u]"
        by(simp add: forget renaming name_swap)
      ultimately show ?case by blast
    next
      case(cPar2 Q a u Q' P)
      have "\<exists>Q'' x. Q \<longmapsto>\<^sub>la<x> \<prec> Q'' \<and> Q' = Q''[x::=u]" by fact
      then obtain Q'' x where QTrans: "Q \<longmapsto>\<^sub>la<x> \<prec> Q''" and Q'eqQ'': "Q' = Q''[x::=u]" by blast
      have "\<exists>c::name. c \<sharp> (P, Q'')" by(blast intro: name_exists_fresh)
      then obtain c::name where cFreshP: "c \<sharp> P" and cFreshQ'': "c \<sharp> Q''" by(force simp add: fresh_prod)
      from QTrans cFreshQ'' have "Q \<longmapsto>\<^sub>la<c> \<prec> [(x, c)] \<bullet> Q''" by(simp add: Late_Semantics.alphaBoundResidual)
      hence "P \<parallel> Q \<longmapsto>\<^sub>la<c> \<prec> P \<parallel> ([(x, c)] \<bullet> Q'')" using \<open>c \<sharp> P\<close> by(rule Late_Semantics.Par2B)
      moreover from cFreshP cFreshQ'' Q'eqQ'' have "P \<parallel> Q' = (P \<parallel> ([(x, c)] \<bullet> Q''))[c::=u]"
        by(simp add: forget renaming name_swap)
      ultimately show ?case by blast
    next
      case(cRes P a u P' y)
      have "\<exists>P'' x. P \<longmapsto>\<^sub>la<x> \<prec> P'' \<and> P' = P''[x::=u]" by fact
      then obtain P'' x where PTrans: "P \<longmapsto>\<^sub>la<x> \<prec> P''" and P'eqP'': "P' = P''[x::=u]" by blast
      have yinequ: "y \<noteq> u" by fact
      have "\<exists>c::name. c \<sharp> (y, P'')" by(blast intro: name_exists_fresh)
      then obtain c::name where cineqy: "c \<noteq> y" and cFreshP'': "c \<sharp> P''" by(force simp add: fresh_prod)
      from PTrans cFreshP'' have "P \<longmapsto>\<^sub>la<c> \<prec> [(x, c)] \<bullet> P''" by(simp add: Late_Semantics.alphaBoundResidual)
      moreover have "y \<noteq> a" by fact
      ultimately have "<\<nu>y>P \<longmapsto>\<^sub>la<c> \<prec> <\<nu>y>(([(x, c)] \<bullet> P''))" using cineqy
        by(force intro: Late_Semantics.ResB)
      moreover from cineqy cFreshP'' P'eqP'' yinequ have "<\<nu>y>P' = (<\<nu>y>([(x, c)] \<bullet> P''))[c::=u]"
        by(simp add: renaming name_swap)
      ultimately show ?case by blast
    next
      case(cBang P a u P')
      have "\<exists>P'' x. P \<parallel> !P \<longmapsto>\<^sub>la<x> \<prec> P'' \<and> P' = P''[x::=u]" by fact
      then obtain P'' x where PTrans: "P \<parallel> !P \<longmapsto>\<^sub>la<x> \<prec> P''" and P'eqP'': "P' = P''[x::=u]" by blast
      from PTrans have "!P \<longmapsto>\<^sub>la<x> \<prec> P''" by(rule Late_Semantics.Bang)
      with P'eqP'' show ?case by blast
    qed
  }
  with assms obtain P'' y where PTrans: "P \<longmapsto>\<^sub>la<y> \<prec> P''" and P'eqP'': "P' = P''[y::=u]" by blast
  show ?thesis
  proof(cases "x=y")
    case True
    from PTrans P'eqP'' \<open>x = y\<close> show ?thesis by blast
  next
    case False
    from PTrans \<open>x \<noteq> y\<close> \<open>x \<sharp> P\<close> have "x \<sharp> P''" by(fastforce dest: freshBoundDerivative simp add: residual.inject)
    with PTrans have "P \<longmapsto>\<^sub>la<x> \<prec>\<^sub>l ([(x, y)] \<bullet> P'')"
      by(simp add: Late_Semantics.alphaBoundResidual)
    moreover from \<open>x \<sharp> P''\<close> have "P''[y::=u] = ([(x, y)] \<bullet> P'')[x::=u]" by(simp add: renaming name_swap)
    ultimately show ?thesis using P'eqP'' by blast
  qed
qed
(*
lemma earlyLateInput:
  fixes P  :: pi
  and   a  :: name
  and   x  :: name
  and   P' :: pi
  and   u  :: name
  and   C  :: "'a::fs_name"

  assumes PTrans: "P \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e P'"

  shows "\<exists>P'' x. P \<longmapsto>\<^sub>la<x> \<prec>\<^sub>l P'' \<and> P' = P''[x::=u] \<and> x \<sharp> C"
proof -
  have "\<And>P a u P'. P \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e P' \<Longrightarrow> \<exists>P'' x. P \<longmapsto>\<^sub>la<x> \<prec>\<^sub>l P'' \<and> P' = P''[x::=u]"
  proof -
    fix P a u P'
    assume "P \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e P'"
    thus "\<exists>P'' x. P \<longmapsto>\<^sub>la<x> \<prec>\<^sub>l P'' \<and> P' = P''[x::=u]"
    proof(nominal_induct rule: Early_Semantics.inputInduct)
      case(cInput a x P u)
      have "a<x>.P \<longmapsto>\<^sub>la<x> \<prec> P" by(rule Late_Semantics.Input)
      thus ?case by blast
    next
      case(cMatch P a u P' b)
      have "\<exists>P'' x. P \<longmapsto>\<^sub>la<x> \<prec> P'' \<and> P' = P''[x::=u]" by fact
      then obtain P'' x where PTrans: "P \<longmapsto>\<^sub>la<x> \<prec> P''" and P'eqP'': "P' = P''[x::=u]" by blast
      from PTrans have "[b\<frown>b]P \<longmapsto>\<^sub>la<x> \<prec> P''" by(rule Late_Semantics.Match)
      with P'eqP'' show ?case by blast
    next
      case(cMismatch P a u P' b c)
      have "\<exists>P'' x. P \<longmapsto>\<^sub>la<x> \<prec> P'' \<and> P' = P''[x::=u]" by fact
      then obtain P'' x where PTrans: "P \<longmapsto>\<^sub>la<x> \<prec> P''" and P'eqP'': "P' = P''[x::=u]" by blast
      have "b \<noteq> c" by fact
      with PTrans have "[b\<noteq>c]P \<longmapsto>\<^sub>la<x> \<prec> P''" by(rule Late_Semantics.Mismatch)
      with P'eqP'' show ?case by blast
    next
      case(cSum1 P a u P' Q)
      have "\<exists>P'' x. P \<longmapsto>\<^sub>la<x> \<prec> P'' \<and> P' = P''[x::=u]" by fact
      then obtain P'' x where PTrans: "P \<longmapsto>\<^sub>la<x> \<prec> P''" and P'eqP'': "P' = P''[x::=u]" by blast
      from PTrans have "P \<oplus> Q \<longmapsto>\<^sub>la<x> \<prec> P''" by(rule Late_Semantics.Sum1)
      with P'eqP'' show ?case by blast
    next
      case(cSum2 Q a u Q' P)
      have "\<exists>Q'' x. Q \<longmapsto>\<^sub>la<x> \<prec> Q'' \<and> Q' = Q''[x::=u]" by fact
      then obtain Q'' x where QTrans: "Q \<longmapsto>\<^sub>la<x> \<prec> Q''" and Q'eqQ'': "Q' = Q''[x::=u]" by blast
      from QTrans have "P \<oplus> Q \<longmapsto>\<^sub>la<x> \<prec> Q''" by(rule Late_Semantics.Sum2)
      with Q'eqQ'' show ?case by blast
    next
      case(cPar1 P a u P' Q)
      have "\<exists>P'' x. P \<longmapsto>\<^sub>la<x> \<prec> P'' \<and> P' = P''[x::=u]" by fact
      then obtain P'' x where PTrans: "P \<longmapsto>\<^sub>la<x> \<prec> P''" and P'eqP'': "P' = P''[x::=u]" by blast
      have "\<exists>c::name. c \<sharp> (Q, P'')" by(blast intro: name_exists_fresh)
      then obtain c::name where cFreshQ: "c \<sharp> Q" and cFreshP'': "c \<sharp> P''" by(force simp add: fresh_prod)
      from PTrans cFreshP'' have "P \<longmapsto>\<^sub>la<c> \<prec> [(x, c)] \<bullet> P''" by(simp add: Late_Semantics.alphaBoundResidual)
      hence "P \<parallel> Q \<longmapsto>\<^sub>la<c> \<prec> ([(x, c)] \<bullet> P'') \<parallel> Q" using `c \<sharp> Q` by(rule Late_Semantics.Par1B)
      moreover from cFreshQ cFreshP'' P'eqP'' have "P' \<parallel> Q = (([(x, c)] \<bullet> P'') \<parallel> Q)[c::=u]"
        by(simp add: forget renaming name_swap)
      ultimately show ?case by blast
    next
      case(cPar2 Q a u Q' P)
      have "\<exists>Q'' x. Q \<longmapsto>\<^sub>la<x> \<prec> Q'' \<and> Q' = Q''[x::=u]" by fact
      then obtain Q'' x where QTrans: "Q \<longmapsto>\<^sub>la<x> \<prec> Q''" and Q'eqQ'': "Q' = Q''[x::=u]" by blast
      have "\<exists>c::name. c \<sharp> (P, Q'')" by(blast intro: name_exists_fresh)
      then obtain c::name where cFreshP: "c \<sharp> P" and cFreshQ'': "c \<sharp> Q''" by(force simp add: fresh_prod)
      from QTrans cFreshQ'' have "Q \<longmapsto>\<^sub>la<c> \<prec> [(x, c)] \<bullet> Q''" by(simp add: Late_Semantics.alphaBoundResidual)
      hence "P \<parallel> Q \<longmapsto>\<^sub>la<c> \<prec> P \<parallel> ([(x, c)] \<bullet> Q'')" using `c \<sharp> P` by(rule Late_Semantics.Par2B)
      moreover from cFreshP cFreshQ'' Q'eqQ'' have "P \<parallel> Q' = (P \<parallel> ([(x, c)] \<bullet> Q''))[c::=u]"
        by(simp add: forget renaming name_swap)
      ultimately show ?case by blast
    next
      case(cRes P a u P' y)
      have "\<exists>P'' x. P \<longmapsto>\<^sub>la<x> \<prec> P'' \<and> P' = P''[x::=u]" by fact
      then obtain P'' x where PTrans: "P \<longmapsto>\<^sub>la<x> \<prec> P''" and P'eqP'': "P' = P''[x::=u]" by blast
      have yinequ: "y \<noteq> u" by fact
      have "\<exists>c::name. c \<sharp> (y, P'')" by(blast intro: name_exists_fresh)
      then obtain c::name where cineqy: "c \<noteq> y" and cFreshP'': "c \<sharp> P''" by(force simp add: fresh_prod)
      from PTrans cFreshP'' have "P \<longmapsto>\<^sub>la<c> \<prec> [(x, c)] \<bullet> P''" by(simp add: Late_Semantics.alphaBoundResidual)
      moreover have "y \<noteq> a" by fact
      ultimately have "<\<nu>y>P \<longmapsto>\<^sub>la<c> \<prec> <\<nu>y>(([(x, c)] \<bullet> P''))" using cineqy
        by(force intro: Late_Semantics.ResB)
      moreover from cineqy cFreshP'' P'eqP'' yinequ have "<\<nu>y>P' = (<\<nu>y>([(x, c)] \<bullet> P''))[c::=u]"
        by(simp add: renaming name_swap)
      ultimately show ?case by blast
    next
      case(cBang P a u P')
      have "\<exists>P'' x. P \<parallel> !P \<longmapsto>\<^sub>la<x> \<prec> P'' \<and> P' = P''[x::=u]" by fact
      then obtain P'' x where PTrans: "P \<parallel> !P \<longmapsto>\<^sub>la<x> \<prec> P''" and P'eqP'': "P' = P''[x::=u]" by blast
      from PTrans have "!P \<longmapsto>\<^sub>la<x> \<prec> P''" by(rule Late_Semantics.Bang)
      with P'eqP'' show ?case by blast
    qed
  qed
  with PTrans obtain P'' x where PTrans: "P \<longmapsto>\<^sub>la<x> \<prec> P''" and P'eqP'': "P' = P''[x::=u]" by blast
  have "\<exists>c::name. c \<sharp> (P'', C)" by(blast intro: name_exists_fresh)
  then obtain c::name where cFreshP'': "c \<sharp> P''" and cFreshC: "c \<sharp> C" by force
  from cFreshP'' PTrans have "P \<longmapsto>\<^sub>la<c> \<prec>\<^sub>l ([(x, c)] \<bullet> P'')"
    by(simp add: Late_Semantics.alphaBoundResidual)
  moreover from cFreshP'' have "P''[x::=u] = ([(x, c)] \<bullet> P'')[c::=u]" by(simp add: renaming name_swap)
  ultimately show ?thesis using P'eqP'' cFreshC by blast
qed
*)
lemma lateEarlyTau:
  fixes P  :: pi
  and   P' :: pi

  assumes "P \<longmapsto>\<^sub>l\<tau> \<prec>\<^sub>l P'"

  shows "P \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e P'"
using assms
proof(nominal_induct rule: Late_Semantics.tauInduct)
  case(Tau P)
  thus ?case by(rule Early_Semantics.Tau)
next
  case(Match P P' a)
  have "P \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e P'" by fact
  thus "[a\<frown>a]P \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e P'" by(rule Early_Semantics.Match)
next
  case(Mismatch P P' a b)
  have "P \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e P'" by fact
  moreover have "a \<noteq> b" by fact
  ultimately show "[a\<noteq>b]P \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e P'" by(rule Early_Semantics.Mismatch)
next
  case(Sum1 P P' Q)
  have "P \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e P'" by fact
  thus "P \<oplus> Q \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e P'" by(rule Early_Semantics.Sum1)
next
  case(Sum2 Q Q' P)
  have "Q \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e Q'" by fact
  thus "P \<oplus> Q \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e Q'" by(rule Early_Semantics.Sum2)
next
  case(Par1 P P' Q)
  have "P \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e P'" by fact
  thus "P \<parallel> Q \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e P' \<parallel> Q" by(rule Early_Semantics.Par1F)
next
  case(Par2 Q Q' P)
  have "Q \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e Q'" by fact
  thus "P \<parallel> Q \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e P \<parallel> Q'" by(rule Early_Semantics.Par2F)
next
  case(Comm1 P a x P' Q b Q')
  have "P \<longmapsto>\<^sub>ea<b> \<prec>\<^sub>e P'[x::=b]"
  proof -
    have "P \<longmapsto>\<^sub>l a<x> \<prec> P'" by fact
    thus ?thesis by(rule lateEarlyInput)
  qed
  moreover have "Q \<longmapsto>\<^sub>ea[b] \<prec>\<^sub>e Q'"
  proof -
    have "Q \<longmapsto>\<^sub>la[b] \<prec>\<^sub>l Q'" by fact
    thus ?thesis by(rule lateEarlyOutput)
  qed
  ultimately show ?case by(rule Early_Semantics.Comm1)
next
  case(Comm2 P a b P' Q x Q')
  have "P \<longmapsto>\<^sub>ea[b] \<prec>\<^sub>e P'"
  proof -
    have "P \<longmapsto>\<^sub>la[b] \<prec>\<^sub>l P'" by fact
    thus ?thesis by(rule lateEarlyOutput)
  qed
  moreover have "Q \<longmapsto>\<^sub>ea<b> \<prec>\<^sub>e Q'[x::=b]"
  proof -
    have "Q \<longmapsto>\<^sub>la<x> \<prec>\<^sub>l Q'" by fact
    thus ?thesis by(rule lateEarlyInput)
  qed
  ultimately show ?case by(rule Early_Semantics.Comm2)
next
  case(Close1 P a x P' Q y Q')
  have "P \<longmapsto>\<^sub>ea<y> \<prec>\<^sub>e P'[x::=y]"
  proof -
    have "P \<longmapsto>\<^sub>l a<x> \<prec> P'" by fact
    thus ?thesis by(rule lateEarlyInput)
  qed
  moreover have "Q \<longmapsto>\<^sub>ea<\<nu>y> \<prec> Q'"
  proof -
    have "Q \<longmapsto>\<^sub>la<\<nu>y> \<prec>\<^sub>l Q'" by fact
    thus ?thesis by(rule lateEarlyBoundOutput)
  qed
  moreover have "y \<sharp> P" by fact
  ultimately show ?case by(rule Early_Semantics.Close1)
next
  case(Close2 P a y P' Q x Q')
  have "P \<longmapsto>\<^sub>ea<\<nu>y> \<prec> P'"
  proof -
    have "P \<longmapsto>\<^sub>la<\<nu>y> \<prec>\<^sub>l P'" by fact
    thus ?thesis by(rule lateEarlyBoundOutput)
  qed
  moreover have "Q \<longmapsto>\<^sub>ea<y> \<prec>\<^sub>e Q'[x::=y]"
  proof -
    have "Q \<longmapsto>\<^sub>la<x> \<prec>\<^sub>l Q'" by fact
    thus ?thesis by(rule lateEarlyInput)
  qed
  moreover have "y \<sharp> Q" by fact
  ultimately show ?case by(rule Early_Semantics.Close2)
next
  case(Res P P' x)
  have "P \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e P'" by fact
  thus ?case by(force intro: Early_Semantics.ResF)
next
  case(Bang P P')
  have "P \<parallel> !P \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e P'" by fact
  thus ?case by(rule Early_Semantics.Bang)
qed

lemma earlyLateTau:
  fixes P  :: pi
  and   P' :: pi

  assumes "P \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e P'"

  shows "P \<longmapsto>\<^sub>l\<tau> \<prec>\<^sub>l P'"
using assms
proof(nominal_induct rule: Early_Semantics.tauInduct)
  case(Tau P)
  thus ?case by(rule Late_Semantics.Tau)
next
  case(Match P P' a)
  have "P \<longmapsto>\<^sub>l\<tau> \<prec>\<^sub>l P'" by fact
  thus ?case by(rule Late_Semantics.Match)
next
  case(Mismatch P P' a b)
  have "P \<longmapsto>\<^sub>l\<tau> \<prec>\<^sub>l P'" by fact
  moreover have "a \<noteq> b" by fact
  ultimately show ?case by(rule Late_Semantics.Mismatch)
next
  case(Sum1 P P' Q)
  have "P \<longmapsto>\<^sub>l\<tau> \<prec>\<^sub>l P'" by fact
  thus ?case by(rule Late_Semantics.Sum1)
next
  case(Sum2 Q Q' P)
  have "Q \<longmapsto>\<^sub>l\<tau> \<prec>\<^sub>l Q'" by fact
  thus ?case by(rule Late_Semantics.Sum2)
next
  case(Par1 P P' Q)
  have "P \<longmapsto>\<^sub>l\<tau> \<prec>\<^sub>l P'" by fact
  thus ?case by(rule Late_Semantics.Par1F)
next
  case(Par2 Q Q' P)
  have "Q \<longmapsto>\<^sub>l\<tau> \<prec>\<^sub>l Q'" by fact
  thus ?case by(rule Late_Semantics.Par2F)
next
  case(Comm1 P a b P' Q Q')
  have "P \<longmapsto>\<^sub>ea<b> \<prec>\<^sub>e P'" by fact
  moreover obtain x::name  where "x \<sharp> P" by(generate_fresh "name") auto
  ultimately obtain P'' where PTrans: "P \<longmapsto>\<^sub>la<x> \<prec> P''" and P'eqP'': "P' = P''[x::=b]"
    by(blast dest: earlyLateInput)
  have "Q \<longmapsto>\<^sub>ea[b] \<prec>\<^sub>e Q'" by fact
  hence "Q \<longmapsto>\<^sub>la[b] \<prec>\<^sub>l Q'" by(rule earlyLateOutput)
  with PTrans P'eqP'' show ?case
    by(blast intro: Late_Semantics.Comm1)
next
  case(Comm2 P a b P' Q Q')
  have "P \<longmapsto>\<^sub>ea[b] \<prec>\<^sub>e P'" by fact
  hence QTrans: "P \<longmapsto>\<^sub>la[b] \<prec>\<^sub>l P'" by(rule earlyLateOutput)
  have "Q \<longmapsto>\<^sub>ea<b> \<prec>\<^sub>e Q'" by fact
  moreover obtain x::name  where "x \<sharp> Q" by(generate_fresh "name") auto
  ultimately obtain Q'' x where "Q \<longmapsto>\<^sub>la<x> \<prec> Q''" and "Q' = Q''[x::=b]"
    by(blast dest: earlyLateInput)
  with QTrans show ?case
    by(blast intro: Late_Semantics.Comm2)
next
  case(Close1 P a x P' Q Q')
  have  "P \<longmapsto>\<^sub>ea<x> \<prec>\<^sub>e P'" and "x \<sharp> P" by fact+
  then obtain P'' where "P \<longmapsto>\<^sub>la<x> \<prec> P''" and "P' = P''[x::=x]"
    by(blast dest: earlyLateInput)

  moreover have "Q \<longmapsto>\<^sub>ea<\<nu>x> \<prec>\<^sub>e Q'" by fact
  hence "Q \<longmapsto>\<^sub>la<\<nu>x> \<prec>\<^sub>l Q'" by(rule earlyLateBoundOutput)
  moreover have "x \<sharp> P" by fact
  ultimately show ?case
    by(blast intro: Late_Semantics.Close1)
next
  case(Close2 P a x P' Q Q')
  have  "P \<longmapsto>\<^sub>ea<\<nu>x> \<prec>\<^sub>e P'" by fact
  hence PTrans: "P \<longmapsto>\<^sub>la<\<nu>x> \<prec>\<^sub>l P'" by(rule earlyLateBoundOutput)

  have "Q \<longmapsto>\<^sub>ea<x> \<prec>\<^sub>e Q'" and "x \<sharp> Q" by fact+
  then obtain Q'' y where "Q \<longmapsto>\<^sub>la<x> \<prec> Q''" and "Q' = Q''[x::=x]"
    by(blast dest: earlyLateInput)
  moreover have "x \<sharp> Q" by fact
  ultimately show ?case using PTrans
    by(blast intro: Late_Semantics.Close2)
next
  case(Res P P' x)
  have  "P \<longmapsto>\<^sub>l\<tau> \<prec>\<^sub>l P'" by fact
  thus ?case by(force intro: Late_Semantics.ResF)
next
  case(Bang P P')
  have  "P \<parallel> !P \<longmapsto>\<^sub>l\<tau> \<prec>\<^sub>l P'" by fact
  thus ?case by(force intro: Late_Semantics.Bang)
qed

lemma tauEq:
  fixes P  :: pi
  and   P' :: pi

  shows "P \<longmapsto>\<^sub>e(Early_Semantics.FreeR Early_Semantics.TauR P') = P \<longmapsto>\<tau> \<prec>\<^sub>l P'"
by(auto intro: earlyLateTau lateEarlyTau)

(****************** Simulation ******************)

abbreviation simLate_judge ("_ \<leadsto>\<^sub>l[_] _" [80, 80, 80] 80) where "P \<leadsto>\<^sub>l[Rel] Q \<equiv> Strong_Late_Sim.simulation P Rel Q"
abbreviation simEarly_judge ("_ \<leadsto>\<^sub>e[_] _" [80, 80, 80] 80) where "P \<leadsto>\<^sub>e[Rel] Q \<equiv> Strong_Early_Sim.strongSimEarly P Rel Q"

lemma lateEarlySim:
  fixes P   :: pi
  and   Q   :: pi
  and   Rel :: "(pi \<times> pi) set"

  assumes PSimQ: "P \<leadsto>\<^sub>l[Rel] Q"

  shows "P \<leadsto>\<^sub>e[Rel] Q"
proof(induct rule: Strong_Early_Sim.simCases)
  case(Bound a x Q')
  have "Q \<longmapsto>\<^sub>ea<\<nu>x> \<prec>\<^sub>e Q'" by fact
  hence "Q \<longmapsto>\<^sub>la<\<nu>x> \<prec>\<^sub>l Q'" by(rule earlyLateBoundOutput)
  moreover have "x \<sharp> P" by fact
  ultimately obtain P' where PTrans: "P \<longmapsto>\<^sub>la<\<nu>x> \<prec>\<^sub>l P'" and P'RelQ': "(P', Q') \<in> Rel" using PSimQ
    by(force dest: Strong_Late_Sim.simE simp add: derivative_def)
  from PTrans have "P \<longmapsto>\<^sub>ea<\<nu>x> \<prec>\<^sub>e P'" by(rule lateEarlyBoundOutput)
  with P'RelQ' show ?case by blast
next
  case(Free \<alpha> Q')
  have "Q \<longmapsto>\<^sub>e Early_Semantics.residual.FreeR \<alpha> Q'" by fact
  thus ?case
  proof(nominal_induct \<alpha> rule: freeRes.strong_induct)
    case(InputR a u)
    obtain x::name where "x \<sharp> Q" and "x \<sharp> P" by(generate_fresh "name") auto
    with \<open>Q \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e Q'\<close> obtain Q'' where QTrans: "Q \<longmapsto>\<^sub>la<x> \<prec>\<^sub>l Q''" and Q'eqQ'': "Q' = Q''[x::=u]"
      by(blast dest: earlyLateInput)
    from PSimQ QTrans \<open>x \<sharp> P\<close>  obtain P' where PTrans: "P \<longmapsto>\<^sub>la<x> \<prec> P'"
                                          and P'RelQ': "(P'[x::=u], Q''[x::=u]) \<in> Rel"
      by(force dest: Strong_Late_Sim.simE simp add: derivative_def)
    from PTrans have "P \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e P'[x::=u]" by(rule lateEarlyInput)
    with P'RelQ' Q'eqQ'' show "\<exists>P'. P \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e P' \<and> (P', Q') \<in> Rel" by blast
  next
    case(OutputR a b)
    from \<open>Q \<longmapsto>\<^sub>ea[b] \<prec>\<^sub>e Q'\<close> have "Q \<longmapsto>\<^sub>la[b] \<prec>\<^sub>l Q'" by(rule earlyLateOutput)
    with PSimQ obtain P' where PTrans: "P \<longmapsto>\<^sub>la[b] \<prec>\<^sub>l P'" and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: Strong_Late_Sim.simE)
    from PTrans have "P \<longmapsto>\<^sub>ea[b] \<prec>\<^sub>e P'" by(rule lateEarlyOutput)
    with P'RelQ' show "\<exists>P'. P \<longmapsto>\<^sub>ea[b] \<prec>\<^sub>e P' \<and> (P', Q') \<in> Rel"  by blast
  next
    case TauR
    from \<open>Q \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e Q'\<close> have "Q \<longmapsto>\<^sub>l\<tau> \<prec>\<^sub>l Q'" by(rule earlyLateTau)
    with PSimQ obtain P' where PTrans: "P \<longmapsto>\<^sub>l\<tau> \<prec>\<^sub>l P'" and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: Strong_Late_Sim.simE)
    from PTrans have "P \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e P'" by(rule lateEarlyTau)
    with P'RelQ' show "\<exists>P'. P \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e P' \<and> (P', Q') \<in> Rel"  by blast
  qed
qed

(*************** Bisimulation ***************)

abbreviation bisimLate_judge ("_ \<sim>\<^sub>l _" [80, 80] 80) where "P \<sim>\<^sub>l Q \<equiv> (P, Q) \<in> Strong_Late_Bisim.bisim"
abbreviation bisimEarly_judge ("_ \<sim>\<^sub>e _" [80, 80] 80) where "P \<sim>\<^sub>e Q \<equiv> (P, Q) \<in> Strong_Early_Bisim.bisim"

lemma lateEarlyBisim:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<sim>\<^sub>l Q"

  shows "P \<sim>\<^sub>e Q"
using assms
by(coinduct rule: Strong_Early_Bisim.weak_coinduct)
  (auto dest: Strong_Late_Bisim.bisimE Strong_Late_Bisim.symmetric intro: lateEarlySim)

(*************** Congruence ***************)

abbreviation congLate_judge ("_ \<sim>\<^sup>s\<^sub>l _" [80, 80] 80) where "P \<sim>\<^sup>s\<^sub>l Q \<equiv> (P, Q) \<in> (substClosed Strong_Late_Bisim.bisim)"
abbreviation congEarly_judge ("_ \<sim>\<^sup>s\<^sub>e _" [80, 80] 80) where "P \<sim>\<^sup>s\<^sub>e Q \<equiv> (P, Q) \<in> (substClosed Strong_Early_Bisim.bisim)"

lemma lateEarlyCong:
  fixes P :: pi
  and   Q :: pi

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

  shows "P \<sim>\<^sup>s\<^sub>e Q"
using assms
by(auto simp add: substClosed_def intro: lateEarlyBisim)

lemma earlyCongStructCong:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<equiv>\<^sub>s Q"

  shows "P \<sim>\<^sup>s\<^sub>e Q"
using assms lateEarlyCong bisimSubstStructCong
by blast

lemma earlyBisimStructCong:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<equiv>\<^sub>s Q"

  shows "P \<sim>\<^sub>e Q"
using assms lateEarlyBisim structCongBisim
by blast

end


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

theory MonadSep
imports
  Sep_Algebra_L4v
  "Lib.LemmaBucket"
begin

locale sep_lifted =
  fixes lft :: "'a \<Rightarrow> 's :: sep_algebra"
begin

abbreviation
  lift :: "('s \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" ("<_>")
where
  "<P> s \<equiv> P (lft s)"

lemma hoare_gen_lifted_asm:
  "(P \<Longrightarrow> \<lbrace>\<lambda>s. P' (lft s)\<rbrace> f \<lbrace>Q\<rbrace>) \<Longrightarrow> \<lbrace>\<lambda>s. (P' and K P) (lft s)\<rbrace> f \<lbrace>Q\<rbrace>"
  by (auto intro: hoare_assume_pre)

lemma mapM_x_sep_inv':
  includes no_pre
  assumes f:
   "\<And>R x. x \<in> S \<Longrightarrow>
     \<lbrace>\<lambda>s.<P x \<and>* I \<and>* R> s \<and> I' s\<rbrace>
      f x
     \<lbrace>\<lambda>_ s.<Q x \<and>* I \<and>* R> s \<and> I' s\<rbrace>"
  shows
   "set xs \<subseteq> S \<Longrightarrow>
     \<lbrace>\<lambda>s.<\<And>* map P xs \<and>* I \<and>* R> s \<and> I' s\<rbrace>
      mapM_x f xs
     \<lbrace>\<lambda>_ s.<\<And>* map Q xs \<and>* I \<and>* R> s \<and> I' s\<rbrace>"
proof (induct xs arbitrary: R)
  case Nil
  thus ?case by (simp add: mapM_x_Nil)
next
  case (Cons x xs)
  thus ?case
    apply (simp add: sep_conj_assoc mapM_x_Cons)
    apply (wp)
     apply (insert Cons.hyps [where R1="Q x ** R"])[1]
     apply (simp add: sep_conj_ac)
    apply (insert f [where R1="R ** \<And>* map P xs" and x1=x ])[1]
    apply (simp add: sep_conj_ac)
    done
qed

lemmas mapM_x_sep_inv = mapM_x_sep_inv' [OF _ subset_refl]
lemmas mapM_x_sep = mapM_x_sep_inv [where I' = \<top>, simplified]
lemmas mapM_x_sep' = mapM_x_sep [where I=\<box>, simplified]

lemma mapM_x_set_sep_inv:
  "\<lbrakk>distinct xs; set xs = X; (\<And>R x. x \<in> X \<Longrightarrow> \<lbrace><P x \<and>* I \<and>* R> and I'\<rbrace> f x \<lbrace>\<lambda>_. <Q x \<and>* I \<and>* R> and I'\<rbrace>)\<rbrakk> \<Longrightarrow>
  \<lbrace><(\<And>* x \<in> X. P x) \<and>* I \<and>* R> and I'\<rbrace> mapM_x f xs \<lbrace>\<lambda>_. <(\<And>* x \<in> X. Q x) \<and>* I \<and>* R> and I'\<rbrace>"
  apply (clarsimp simp: pred_conj_def)
  apply (drule mapM_x_sep_inv [where R=R])
  apply (subst (asm) sep_list_conj_sep_map_set_conj, assumption)+
  apply assumption
  done

lemmas mapM_x_set_sep' = mapM_x_set_sep_inv [where I' = \<top>, simplified]

lemma mapM_x_set_sep:
  "\<lbrakk>distinct xs; \<And>R x. x \<in> set xs \<Longrightarrow> \<lbrace><P x \<and>* I \<and>* R>\<rbrace> f x \<lbrace>\<lambda>_. <Q x \<and>* I \<and>* R>\<rbrace>\<rbrakk>
 \<Longrightarrow> \<lbrace><(\<And>* x \<in> set xs. P x) \<and>* I \<and>* R>\<rbrace> mapM_x f xs \<lbrace>\<lambda>_. <(\<And>* x \<in> set xs. Q x) \<and>* I \<and>* R>\<rbrace>"
  by (erule mapM_x_set_sep', simp+)

(* NOTE: unused *)
lemma foldM_Cons:
  "foldM f (x # xs) acc =
    do acc' \<leftarrow> foldM f xs acc;
       f x acc'
    od"
  by (clarsimp simp: foldM_def)

lemma foldM_sep_inv':
  includes no_pre
  assumes f:
   "\<And>R x acc. x \<in> S \<Longrightarrow>
     \<lbrace>\<lambda>s. <P x \<and>* I \<and>* R> s \<and> I' s\<rbrace>
      f x acc
     \<lbrace>\<lambda>acc' s. <Q x \<and>* I \<and>* R> s \<and> I' s\<rbrace>"
  shows
   "set xs \<subseteq> S \<Longrightarrow>
     \<lbrace>\<lambda>s. <\<And>* map P xs \<and>* I \<and>* R> s \<and> I' s\<rbrace>
      foldM f xs acc
     \<lbrace>\<lambda>acc' s. <\<And>* map Q xs \<and>* I \<and>* R> s \<and> I' s\<rbrace>"
proof (induct xs arbitrary: R acc)
  case Nil
  thus ?case
    by (simp add: foldM_def)
next
  case (Cons x xs)
  thus ?case
    apply (simp add: sep_conj_assoc foldM_Cons)
    apply wp
     apply (insert f[where R1="R ** \<And>* map Q xs" and x1=x])[1]
     apply (fastforce simp: sep_conj_ac)
    apply (insert Cons.hyps [where R1="P x ** R"])[1]
    apply (clarsimp simp: sep_conj_ac)
    done
qed

lemmas foldM_sep_inv = foldM_sep_inv' [OF _ subset_refl]
lemmas foldM_sep = foldM_sep_inv [where I' = \<top>, simplified]
lemmas foldM_sep' = foldM_sep [where I=\<box>, simplified]

lemma foldM_set_sep_inv:
  "\<lbrakk>distinct xs;
    set xs = X;
    \<And>R x acc. x \<in> X \<Longrightarrow> \<lbrace><P x \<and>* I \<and>* R> and I'\<rbrace> f x acc \<lbrace>\<lambda>_. <Q x \<and>* I \<and>* R> and I'\<rbrace>\<rbrakk> \<Longrightarrow>
  \<lbrace><(\<And>* x \<in> X. P x) \<and>* I \<and>* R> and I'\<rbrace>
   foldM f xs acc
  \<lbrace>\<lambda>_. <(\<And>* x \<in> X. Q x) \<and>* I \<and>* R> and I'\<rbrace>"
  apply (clarsimp simp: pred_conj_def)
  apply (drule foldM_sep_inv [where R=R])
  apply (subst (asm) sep_list_conj_sep_map_set_conj, assumption)+
  apply assumption
  done

lemmas foldM_set_sep' = foldM_set_sep_inv [where I' = \<top>, simplified]

lemma foldM_set_sep:
  "\<lbrakk>distinct xs;
    \<And>R x acc. x \<in> set xs \<Longrightarrow> \<lbrace><P x \<and>* I \<and>* R>\<rbrace> f x acc \<lbrace>\<lambda>_. <Q x \<and>* I \<and>* R>\<rbrace>\<rbrakk>
   \<Longrightarrow> \<lbrace><(\<And>* x \<in> set xs. P x) \<and>* I \<and>* R>\<rbrace> foldM f xs acc \<lbrace>\<lambda>_. <(\<And>* x \<in> set xs. Q x) \<and>* I \<and>* R>\<rbrace>"
  by (erule foldM_set_sep', simp+)

lemma sep_list_conj_map_singleton_wp:
  "\<lbrakk>x \<in> set xs; \<And>R. \<lbrace><P \<and>* I x \<and>* R>\<rbrace> f \<lbrace>\<lambda>_. <Q \<and>* I x \<and>* R>\<rbrace>\<rbrakk>
  \<Longrightarrow> \<lbrace><P \<and>* \<And>* map I xs \<and>* R>\<rbrace> f \<lbrace>\<lambda>_. <Q \<and>* \<And>* map I xs \<and>* R>\<rbrace>"
  apply (rule hoare_chain [where P="<P \<and>* I x \<and>* \<And>* map I (remove1 x xs) \<and>* R>" and
                                 Q="\<lambda>_. <Q \<and>* I x \<and>* \<And>* map I (remove1 x xs) \<and>* R>"])
    apply fastforce
   apply (subst (asm) sep_list_conj_map_remove1, assumption)
   apply (sep_select_asm 3)
   apply (sep_solve)
  apply (subst sep_list_conj_map_remove1, sep_solve+)
  done

lemma sep_set_conj_map_singleton_wp:
  "\<lbrakk>finite xs; x \<in> xs; \<And>R. \<lbrace><P \<and>* I x \<and>* R>\<rbrace> f \<lbrace>\<lambda>_. <Q \<and>* I x \<and>* R>\<rbrace>\<rbrakk>
  \<Longrightarrow> \<lbrace><P \<and>* (\<And>* x\<in>xs. I x) \<and>* R>\<rbrace> f \<lbrace>\<lambda>_. <Q \<and>* (\<And>* x\<in>xs. I x) \<and>* R>\<rbrace>"
  apply (rule hoare_chain [where P="<P \<and>* I x \<and>* (\<And>* x\<in>xs - {x}. I x) \<and>* R>" and
                                 Q="\<lambda>_. <Q \<and>* I x \<and>* (\<And>* x\<in>xs - {x}. I x) \<and>* R>"], assumption)
   apply (subst (asm) sep.prod.remove, assumption+)
   apply sep_solve
  apply (subst sep.prod.remove, assumption+)
  apply sep_solve
  done

lemma sep_list_conj_submap_wp:
  "\<lbrakk>set xs \<subseteq> set ys; distinct xs; distinct ys;
   \<And>R. \<lbrace><P \<and>* \<And>* map I xs \<and>* R>\<rbrace> f \<lbrace>\<lambda>_. <Q \<and>* \<And>* map I xs \<and>* R>\<rbrace>\<rbrakk>
  \<Longrightarrow> \<lbrace><P \<and>* \<And>* map I ys \<and>* R>\<rbrace> f \<lbrace>\<lambda>_. <Q \<and>* \<And>* map I ys \<and>* R>\<rbrace>"
  apply (subst sep_list_con_map_filter [where t="\<lambda>x. x \<in> set xs" and xs=ys, THEN sym])
  apply (subst sep_list_con_map_filter [where t="\<lambda>x. x \<in> set xs" and xs=ys, THEN sym])
  apply (subgoal_tac "set [x\<leftarrow>ys . x \<in> set xs] = set xs")
   apply (subst sep_list_conj_eq [where xs="[x\<leftarrow>ys . x \<in> set xs]" and ys=xs], clarsimp+)
   apply (subst sep_list_conj_eq [where xs="[x\<leftarrow>ys . x \<in> set xs]" and ys=xs], clarsimp+)
   apply (clarsimp simp: sep_conj_assoc)
  apply auto
  done

(* This just saves some rearranging later. *)
lemma sep_list_conj_submap_wp':
  "\<lbrakk>set xs \<subseteq> set ys; distinct xs; distinct ys;
   \<And>R. \<lbrace><P \<and>* \<And>* map I xs \<and>* S \<and>* R>\<rbrace> f \<lbrace>\<lambda>_. <Q \<and>* \<And>* map I xs \<and>* S \<and>* R>\<rbrace>\<rbrakk>
  \<Longrightarrow> \<lbrace><P \<and>* \<And>* map I ys \<and>* S \<and>* R>\<rbrace> f \<lbrace>\<lambda>_. <Q \<and>* \<And>* map I ys \<and>* S \<and>* R>\<rbrace>"
  apply (cut_tac sep_list_conj_submap_wp [where P="P \<and>* S" and Q="Q \<and>* S" and
       I=I and R=R and ys=ys and xs=xs and f=f])
  apply (fastforce simp: sep_conj_ac)+
  done

lemma sep_set_conj_subset_wp:
  "\<lbrakk>xs \<subseteq> ys; finite xs; finite ys;
   \<And>R. \<lbrace><P \<and>* (\<And>* x \<in> xs. I x) \<and>* R>\<rbrace> f \<lbrace>\<lambda>_. <Q \<and>* (\<And>* x \<in> xs. I x) \<and>* R>\<rbrace>\<rbrakk>
  \<Longrightarrow> \<lbrace><P \<and>* (\<And>* x \<in> ys. I x) \<and>* R>\<rbrace> f \<lbrace>\<lambda>_. <Q \<and>* (\<And>* x \<in> ys. I x) \<and>* R>\<rbrace>"
  apply (subst sep_map_set_conj_restrict [where t="\<lambda>x. x \<in> xs" and xs=ys], assumption)
  apply (subst sep_map_set_conj_restrict [where t="\<lambda>x. x \<in> xs" and xs=ys], assumption)
  apply (subgoal_tac "{x \<in> ys. x \<in> xs} = xs")
   apply (clarsimp simp: sep_conj_assoc)
  apply auto
  done

(* This just saves some rearranging later. *)
lemma sep_set_conj_subset_wp':
  "\<lbrakk>xs \<subseteq> ys; finite xs; finite ys;
   \<And>R. \<lbrace><P \<and>* (\<And>* x \<in> xs. I x) \<and>* S \<and>* R>\<rbrace> f \<lbrace>\<lambda>_. <Q \<and>* (\<And>* x \<in> xs. I x) \<and>* S \<and>* R>\<rbrace>\<rbrakk>
  \<Longrightarrow> \<lbrace><P \<and>* (\<And>* x \<in> ys. I x) \<and>* S \<and>* R>\<rbrace> f \<lbrace>\<lambda>_. <Q \<and>* (\<And>* x \<in> ys. I x) \<and>* S \<and>* R>\<rbrace>"
  apply (cut_tac sep_set_conj_subset_wp [where P="P \<and>* S" and Q="Q \<and>* S" and
       I=I and R=R and ys=ys and xs=xs and f=f])
  apply (fastforce simp: sep_conj_ac)+
  done

end

end


(*  Title:      Containers/Map_To_Mapping.thy
    Author:     Andreas Lochbihler, ETH Zurich *)

theory Map_To_Mapping imports
  Mapping_Impl
begin

section \<open>Infrastructure for operation identification\<close>

text \<open>
  To convert theorems from @{typ "'a \<Rightarrow> 'b option"} to @{typ "('a, 'b) mapping"} using lifting / transfer,
  we first introduce constants for the empty map and map lookup, then apply lifting / transfer,
  and finally eliminate the non-converted constants again.
\<close>

text \<open>Dynamic theorem list of rewrite rules that are applied before Transfer.transferred\<close>
ML \<open>
structure Containers_Pre = Named_Thms
(
  val name = @{binding containers_pre}
  val description = "Preprocessing rewrite rules in operation identification for Containers"
)
\<close>
setup \<open>Containers_Pre.setup\<close>

text \<open>Dynamic theorem list of rewrite rules that are applied after Transfer.transferred\<close>
ML \<open>
structure Containers_Post = Named_Thms
(
  val name = @{binding containers_post}
  val description = "Postprocessing rewrite rules in operation identification for Containers"
)
\<close>
setup \<open>Containers_Post.setup\<close>

context includes lifting_syntax
begin

definition map_empty :: "'a \<Rightarrow> 'b option"
where [code_unfold]: "map_empty = Map.empty"

declare map_empty_def[containers_post, symmetric, containers_pre]

declare Mapping.empty.transfer[transfer_rule del]

lemma map_empty_transfer [transfer_rule]:
  "(pcr_mapping A B) map_empty Mapping.empty"
unfolding map_empty_def by(rule Mapping.empty.transfer)

definition map_apply :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a \<Rightarrow> 'b option"
where [code_unfold]: "map_apply = (\<lambda>m. m)"

lemma eq_map_apply: "m x \<equiv> map_apply m x"
by(simp add: map_apply_def)

declare eq_map_apply[symmetric, abs_def, containers_post]

text \<open>We cannot use @{thm [source] eq_map_apply} as a fold rule for operator identification,
  because it would loop. We use a simproc instead.\<close>
ML \<open>
val map_apply_simproc =
  Simplifier.make_simproc @{context} "map_apply"
   {lhss = [@{term "f x :: 'a option"}],
    proc = fn _ => fn ctxt => fn ct =>
      (case Thm.term_of ct of
        Const (@{const_name map_apply}, _) $ _ $ _ => NONE
      | f $ x =>
          let
            val cTr =
              Thm.typ_of_cterm ct
              |> dest_Type
              |> snd |> hd
              |> Thm.ctyp_of ctxt;
            val cTx = Thm.ctyp_of ctxt (fastype_of x);
            val cts = map (SOME o Thm.cterm_of ctxt) [f, x];
          in
            SOME (Thm.instantiate' [SOME cTr, SOME cTx] cts @{thm eq_map_apply})
          end
      | _ => NONE)}
\<close>

lemma map_apply_parametric [transfer_rule]:
  "((A ===> B) ===> A ===> B) map_apply map_apply"
unfolding map_apply_def by(transfer_prover)

lemma map_apply_transfer [transfer_rule]:
  "(pcr_mapping A B ===> A ===> rel_option B) map_apply Mapping.lookup"
by(auto simp add: pcr_mapping_def cr_mapping_def Mapping.lookup_def map_apply_def dest: rel_funD)

definition map_update :: "'a \<Rightarrow> 'b option \<Rightarrow> ('a \<Rightarrow> 'b option) \<Rightarrow> ('a \<Rightarrow> 'b option)"
where "map_update x y f = f(x := y)"

lemma map_update_parametric [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A"
  shows "(A ===> rel_option B ===> (A ===> rel_option B) ===> (A ===> rel_option B)) map_update map_update"
unfolding map_update_def[abs_def] by transfer_prover

context begin
local_setup \<open>Local_Theory.map_background_naming (Name_Space.mandatory_path "Mapping")\<close>

lift_definition update' :: "'a \<Rightarrow> 'b option \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping"
is map_update parametric map_update_parametric .

lemma update'_code [simp, code, code_unfold]:
  "update' x None = Mapping.delete x"
  "update' x (Some y) = Mapping.update x y"
by(transfer, simp add: map_update_def fun_eq_iff)+

end

declare map_update_def[abs_def, containers_post] map_update_def[symmetric, containers_pre]

definition map_is_empty :: "('a \<Rightarrow> 'b option) \<Rightarrow> bool"
where "map_is_empty m \<longleftrightarrow> m = Map.empty"

lemma map_is_empty_folds:
  "m = map_empty \<longleftrightarrow> map_is_empty m"
  "map_empty = m \<longleftrightarrow> map_is_empty m"
by(auto simp add: map_is_empty_def map_empty_def)

declare map_is_empty_folds[containers_pre]
  map_is_empty_def[abs_def, containers_post]

lemma map_is_empty_transfer [transfer_rule]:
  assumes "bi_total A"
  shows "(pcr_mapping A B ===> (=)) map_is_empty Mapping.is_empty"
unfolding map_is_empty_def[abs_def] Mapping.is_empty_def[abs_def] dom_eq_empty_conv[symmetric]
by(rule rel_funI)+(auto simp del: dom_eq_empty_conv dest: rel_setD2 rel_setD1 Mapping.keys.transfer[THEN rel_funD, OF assms])

end

ML \<open>
signature CONTAINERS = sig
  val identify : Context.generic -> thm -> thm;
  val identify_attribute : attribute;
end

structure Containers: CONTAINERS =
struct

fun identify context thm =
  let
    val ctxt' = Context.proof_of context
    val ss = put_simpset HOL_basic_ss ctxt'
    val ctxt1 = ss addsimps Containers_Pre.get ctxt' addsimprocs [map_apply_simproc]
    val ctxt2 = ss addsimps Containers_Post.get ctxt'

    (* Hack to recover Transfer.transferred function from attribute *)
    fun transfer_transferred thm = Transfer.transferred_attribute [] (context, thm) |> snd |> the
  in
    thm
    |> full_simplify ctxt1
    |> transfer_transferred
    |> full_simplify ctxt2
  end

val identify_attribute = Thm.rule_attribute [] identify

end
\<close>

attribute_setup "containers_identify" =
  \<open>Scan.succeed Containers.identify_attribute\<close>
  "Transfer theorems for operator identification in Containers"

hide_const (open) map_apply map_empty map_is_empty map_update
hide_fact (open) map_apply_def map_empty_def eq_map_apply

end


(*
Copyright 2009-2014 Christian Sternagel, René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)

section \<open>Converting Values to Readable Strings\<close>

theory Old_Show
imports Main
keywords "standard_shows_list" :: thy_decl
begin

text \<open>
  A type class similar to Haskell's \texttt{Show} class, allowing for constant-time concatenation of
  @{type string}s using function composition.
\<close>

type_synonym
  "shows" = "string \<Rightarrow> string"

text \<open>
  Convert a string to a show-function that simply prepends the string unchanged.
\<close>
definition shows_string :: "string \<Rightarrow> shows"
where
  "shows_string = (@)"

class "show" =
  fixes shows_prec :: "nat \<Rightarrow> 'a \<Rightarrow> shows"
    and shows_list :: "'a list \<Rightarrow> shows"
  assumes assoc [simp]:
    "shows_prec d x r @ s = shows_prec d x (r @ s)"
    "shows_list xs r @ s = shows_list xs (r @ s)"
begin

abbreviation "shows" :: "'a \<Rightarrow> shows"
where
  "shows x \<equiv> shows_prec 0 x"

abbreviation "show" :: "'a \<Rightarrow> string"
where
  "show x \<equiv> shows x ''''"

end

abbreviation shows_cons :: "string \<Rightarrow> shows \<Rightarrow> shows" (infixr "+#+" 10)
where
  "s +#+ p \<equiv> shows_string s \<circ> p"

abbreviation (input) shows_append :: "shows \<Rightarrow> shows \<Rightarrow> shows" (infixr "+@+" 10)
where
  "s +@+ p \<equiv> s \<circ> p"

definition shows_between :: "shows \<Rightarrow> shows \<Rightarrow> shows \<Rightarrow> shows"
where
  "shows_between l p r = (l +@+ p +@+ r)"

fun shows_sep :: "('a \<Rightarrow> shows) \<Rightarrow> shows \<Rightarrow> 'a list \<Rightarrow> shows"
where
  "shows_sep s sep [] = shows_string ''''" |
  "shows_sep s sep [x] = s x" |
  "shows_sep s sep (x#xs) = (s x +@+ sep +@+ shows_sep s sep xs)"

lemma shows_sep_assoc [simp]:
  assumes "\<And>r s. \<forall>x\<in>set xs. elt x r @ s = elt x (r @ s)"
    and "\<And>r s. sep r @ s = sep (r @ s)"
  shows "shows_sep elt sep xs r @ s = shows_sep elt sep xs (r @ s)"
using assms
proof (induct xs)
  case (Cons x xs) then show ?case by (cases xs) (simp_all)
qed (simp add: shows_string_def)

lemma shows_string_assoc [simp]:
  "shows_string x r @ s = shows_string x (r @ s)"
  by (simp add: shows_string_def)

lemma shows_between_assoc [simp]:
  assumes "\<And>s t. l s @ t = l (s @ t)"
    and "\<And>s t. m s @ t = m (s @ t)"
    and "\<And>s t. r s @ t = r (s @ t)"
  shows "shows_between l m r s @ t = shows_between l m r (s @ t)"
  using assms by (simp add: shows_between_def)

definition
  shows_list_gen :: "('a \<Rightarrow> shows) \<Rightarrow> string \<Rightarrow> string \<Rightarrow> string \<Rightarrow> string \<Rightarrow> 'a list \<Rightarrow> shows"
where
  "shows_list_gen elt e l s r xs = (
    if xs = [] then shows_string e
    else shows_between (shows_string l) (shows_sep elt (shows_string s) xs) (shows_string r))"

lemma shows_list_gen_assoc [simp]:
  assumes "\<And>r s. \<forall>x\<in>set xs. elt x r @ s = elt x (r @ s)"
  shows "shows_list_gen elt e l sep r xs s @ t = shows_list_gen elt e l sep r xs (s @ t)"
  using assms by (cases xs) (simp_all add: shows_list_gen_def)

definition shows_list_aux :: "('a \<Rightarrow> shows) \<Rightarrow> 'a list \<Rightarrow> shows"
where
  "shows_list_aux s xs = shows_list_gen s ''[]'' ''['' '', '' '']'' xs"

lemma assoc_elt:
  "\<forall>x\<in>set xs. shows (x::'a::show) r @ s = shows x (r @ s)"
  by simp

lemma shows_list_aux_assoc:
  assumes "\<And>r s. \<forall>x\<in>set xs. elt x r @ s = elt x (r @ s)"
  shows "shows_list_aux elt xs r @ s = shows_list_aux elt xs (r @ s)"
  using assms by (simp add: shows_list_aux_def)

ML \<open>
(* FIXME export proper ML interfaces: define_shows_list, define_shows_list_cmd *)
let
  fun define_shows_list assoc_thm_ref lthy =
    let
      val assoc_thm = singleton (Attrib.eval_thms lthy) assoc_thm_ref
      fun get_base_type thm =
        let
           val lhs = thm |> Thm.prop_of |> HOLogic.dest_Trueprop |> HOLogic.dest_eq |> fst
           fun get_ty (Const (@{const_name append}, _) $
             (Const (@{const_name shows_prec}, _) $ _ $ x $ _) $ _) = dest_Var x |> snd
             | get_ty t = raise TERM ("Expecting associativity lemma for 'shows_prec'", [t])
        in get_ty lhs end
      val base_ty = get_base_type assoc_thm

      val list_ty = Type (@{type_name "list"}, [base_ty])
      val shows_ty = @{typ "shows"}
      val shows = Abs ("x", base_ty, Const (@{const_name "shows_prec"},
        @{typ nat} --> base_ty --> shows_ty) $ @{term "0 :: nat"} $ Bound 0)
      val shows_list_aux = Const (@{const_name shows_list_aux},
        (base_ty --> shows_ty) --> list_ty --> shows_ty)
      val shows_list = Const (@{const_name shows_list}, list_ty --> shows_ty)
      val rhs = shows_list_aux $ shows
      val shows_list_eq = Logic.mk_equals (shows_list, rhs)

      val ((c, _), rhs) = Syntax.check_term lthy shows_list_eq |> Logic.dest_equals |>> dest_Free;
      val ((_, (_, def_thm')), lthy') =
        Local_Theory.define
          ((Binding.name c, NoSyn), ((Binding.name (c ^ "_def"), @{attributes [code]}), rhs))
          lthy
      val def_thm =
        Proof_Context.theory_of lthy'
        |> Proof_Context.init_global
        |> Proof_Context.export lthy'
        |> (fn x => singleton x def_thm')

      val lthy'' = Class.prove_instantiation_instance (fn ctxt =>
        Class.intro_classes_tac ctxt []
        THEN resolve_tac ctxt [assoc_thm] 1
        THEN unfold_tac ctxt [def_thm]
        THEN resolve_tac ctxt @{thms shows_list_aux_assoc} 1
        THEN resolve_tac ctxt @{thms ballI} 1
        THEN resolve_tac ctxt [assoc_thm] 1
        ) lthy'
    in lthy'' end
in
  Outer_Syntax.local_theory @{command_keyword standard_shows_list}
    "use standard way to extend shows to shows_list, requires associativity lemma as parameter"
    (*standard way: "shows_list = shows_list_aux shows"*)
    (Parse.thm >> define_shows_list)
end
\<close>

instantiation char :: "show"
begin

definition "shows_prec d (c::char) = (#) c"

definition "shows_list (cs::string) = shows_string cs"

instance
  by (intro_classes,unfold shows_prec_char_def shows_list_char_def shows_string_def, simp) auto

end

instantiation list :: ("show") "show"
begin

definition "shows_prec d (l::'a::show list) = shows_list l"

lemma assoc_list:
  "shows_prec d (x::'a::show list) r @ s = shows_prec d x (r @ s)"
  by (simp add: shows_prec_list_def)

standard_shows_list assoc_list

end

definition "shows_nl = shows ''\<newline>''"

definition "shows_space = shows (CHR '' '')"

definition shows_paren :: "shows \<Rightarrow> shows"
where
  "shows_paren p = (shows (CHR ''('') +@+ p +@+ shows (CHR '')''))"

lemmas show_defs =
  shows_prec_char_def shows_nl_def shows_space_def
  shows_string_def shows_between_def shows_paren_def

definition shows_lines :: "'a::show list \<Rightarrow> shows"
where
  "shows_lines = shows_sep shows shows_nl"

definition shows_many :: "'a::show list \<Rightarrow> shows"
where
  "shows_many = shows_sep shows id"

definition shows_words :: "'a::show list \<Rightarrow> shows"
where
  "shows_words = shows_sep shows shows_space"

fun shows_map :: "('a \<Rightarrow> shows) \<Rightarrow> 'a list \<Rightarrow> shows"
where
  "shows_map s [] = id" |
  "shows_map s (x # xs) = (s x +@+ shows_map s xs)"

lemma shows_nl_assoc [simp]:
  "shows_nl r @ s = shows_nl (r @ s)"
  by (simp add: show_defs)

lemma shows_id_assoc [simp]:
  "id r @ s = id (r @ s)" by simp

lemma shows_space_assoc [simp]:
  "shows_space r @ s = shows_space (r @ s)"
  by (simp add: show_defs)

lemma shows_lines_assoc [simp]:
  "shows_lines xs r @ s = shows_lines xs (r @ s)"
  by (simp add: shows_lines_def)

lemma shows_many_assoc [simp]:
  "shows_many xs r @ s = shows_many xs (r @ s)"
  by (simp add: shows_many_def)

lemma shows_words_assoc [simp]:
  "shows_words xs r @ s = shows_words xs (r @ s)"
  by (simp add: shows_words_def)

lemma shows_map_assoc [simp]:
  assumes "\<And>r s.\<forall>x\<in>set xs. elt x r @ s = elt x (r @ s)"
  shows "shows_map elt xs r @ s = shows_map elt xs (r @ s)"
  using assms by (induct xs) auto

fun shows_concat :: "shows list \<Rightarrow> shows"
where
  "shows_concat [] = id" |
  "shows_concat (s # ss) = (s +@+ shows_concat ss)"

lemma shows_map_cong [fundef_cong]:
  assumes "xs = ys" and "\<And>x. x \<in> set ys \<Longrightarrow> f x = g x"
  shows "shows_map f xs = shows_map g ys"
  using assms by (induct xs arbitrary: ys) auto

lemma shows_sep_cong [fundef_cong]:
  assumes "xs = ys" and "\<And>x. x \<in> set ys \<Longrightarrow> f x = g x"
  shows "shows_sep f sep xs = shows_sep g sep ys"
  unfolding assms(1) using assms(2)
proof (induct ys)
  case (Cons y ys)
  thus ?case by (cases ys) auto
qed auto

lemma shows_list_gen_cong [fundef_cong]:
  assumes "xs = ys" and "\<And>x. x \<in> set ys \<Longrightarrow> f x = g x"
  shows "shows_list_gen f e l sep r xs = shows_list_gen g e l sep r ys"
  using shows_sep_cong [of xs ys f g] assms by (cases xs) (auto simp: shows_list_gen_def)

definition shows_quote :: "shows \<Rightarrow> shows"
where
  "shows_quote s = shows_between (shows (CHR 0x27)) s (shows (CHR 0x27))"

text \<open>
  Don't use Haskell's existing "Show" class for code-generation, since it is not compatible to the
  formalized class.
\<close>
code_reserved Haskell "Show"

end