(*  Title:      CCL/CCL.thy
    Author:     Martin Coen
    Copyright   1993  University of Cambridge
*)

section \<open>Classical Computational Logic for Untyped Lambda Calculus
  with reduction to weak head-normal form\<close>

theory CCL
imports Gfp
begin

text \<open>
  Based on FOL extended with set collection, a primitive higher-order
  logic.  HOL is too strong - descriptions prevent a type of programs
  being defined which contains only executable terms.
\<close>

class prog = "term"
default_sort prog

instance "fun" :: (prog, prog) prog ..

typedecl i
instance i :: prog ..

consts
  (*** Evaluation Judgement ***)
  Eval      ::       "[i,i]\<Rightarrow>prop"          (infixl "\<longlongrightarrow>" 20)

  (*** Bisimulations for pre-order and equality ***)
  po          ::       "['a,'a]\<Rightarrow>o"           (infixl "[=" 50)

  (*** Term Formers ***)
  true        ::       "i"
  false       ::       "i"
  pair        ::       "[i,i]\<Rightarrow>i"             ("(1<_,/_>)")
  lambda      ::       "(i\<Rightarrow>i)\<Rightarrow>i"            (binder "lam " 55)
  "case"      ::       "[i,i,i,[i,i]\<Rightarrow>i,(i\<Rightarrow>i)\<Rightarrow>i]\<Rightarrow>i"
  "apply"     ::       "[i,i]\<Rightarrow>i"             (infixl "`" 56)
  bot         ::       "i"

  (******* EVALUATION SEMANTICS *******)

  (**  This is the evaluation semantics from which the axioms below were derived.  **)
  (**  It is included here just as an evaluator for FUN and has no influence on    **)
  (**  inference in the theory CCL.                                                **)

axiomatization where
  trueV:       "true \<longlongrightarrow> true" and
  falseV:      "false \<longlongrightarrow> false" and
  pairV:       "<a,b> \<longlongrightarrow> <a,b>" and
  lamV:        "\<And>b. lam x. b(x) \<longlongrightarrow> lam x. b(x)" and

  caseVtrue:   "\<lbrakk>t \<longlongrightarrow> true; d \<longlongrightarrow> c\<rbrakk> \<Longrightarrow> case(t,d,e,f,g) \<longlongrightarrow> c" and
  caseVfalse:  "\<lbrakk>t \<longlongrightarrow> false; e \<longlongrightarrow> c\<rbrakk> \<Longrightarrow> case(t,d,e,f,g) \<longlongrightarrow> c" and
  caseVpair:   "\<lbrakk>t \<longlongrightarrow> <a,b>; f(a,b) \<longlongrightarrow> c\<rbrakk> \<Longrightarrow> case(t,d,e,f,g) \<longlongrightarrow> c" and
  caseVlam:    "\<And>b. \<lbrakk>t \<longlongrightarrow> lam x. b(x); g(b) \<longlongrightarrow> c\<rbrakk> \<Longrightarrow> case(t,d,e,f,g) \<longlongrightarrow> c"

  (*** Properties of evaluation: note that "t \<longlongrightarrow> c" impies that c is canonical ***)

axiomatization where
  canonical:  "\<lbrakk>t \<longlongrightarrow> c; c==true \<Longrightarrow> u\<longlongrightarrow>v;
                          c==false \<Longrightarrow> u\<longlongrightarrow>v;
                    \<And>a b. c==<a,b> \<Longrightarrow> u\<longlongrightarrow>v;
                      \<And>f. c==lam x. f(x) \<Longrightarrow> u\<longlongrightarrow>v\<rbrakk> \<Longrightarrow>
             u\<longlongrightarrow>v"

  (* Should be derivable - but probably a bitch! *)
axiomatization where
  substitute: "\<lbrakk>a==a'; t(a)\<longlongrightarrow>c(a)\<rbrakk> \<Longrightarrow> t(a')\<longlongrightarrow>c(a')"

  (************** LOGIC ***************)

  (*** Definitions used in the following rules ***)

axiomatization where
  bot_def:         "bot == (lam x. x`x)`(lam x. x`x)" and
  apply_def:     "f ` t == case(f, bot, bot, \<lambda>x y. bot, \<lambda>u. u(t))"

definition "fix" :: "(i\<Rightarrow>i)\<Rightarrow>i"
  where "fix(f) == (lam x. f(x`x))`(lam x. f(x`x))"

  (*  The pre-order ([=) is defined as a simulation, and behavioural equivalence (=) *)
  (*  as a bisimulation.  They can both be expressed as (bi)simulations up to        *)
  (*  behavioural equivalence (ie the relations PO and EQ defined below).            *)

definition SIM :: "[i,i,i set]\<Rightarrow>o"
  where
  "SIM(t,t',R) ==  (t=true \<and> t'=true) | (t=false \<and> t'=false) |
                  (\<exists>a a' b b'. t=<a,b> \<and> t'=<a',b'> \<and> <a,a'> : R \<and> <b,b'> : R) |
                  (\<exists>f f'. t=lam x. f(x) \<and> t'=lam x. f'(x) \<and> (ALL x.<f(x),f'(x)> : R))"

definition POgen :: "i set \<Rightarrow> i set"
  where "POgen(R) == {p. \<exists>t t'. p=<t,t'> \<and> (t = bot | SIM(t,t',R))}"

definition EQgen :: "i set \<Rightarrow> i set"
  where "EQgen(R) == {p. \<exists>t t'. p=<t,t'> \<and> (t = bot \<and> t' = bot | SIM(t,t',R))}"

definition PO :: "i set"
  where "PO == gfp(POgen)"

definition EQ :: "i set"
  where "EQ == gfp(EQgen)"

  (*** Rules ***)

  (** Partial Order **)

axiomatization where
  po_refl:        "a [= a" and
  po_trans:       "\<lbrakk>a [= b;  b [= c\<rbrakk> \<Longrightarrow> a [= c" and
  po_cong:        "a [= b \<Longrightarrow> f(a) [= f(b)" and

  (* Extend definition of [= to program fragments of higher type *)
  po_abstractn:   "(\<And>x. f(x) [= g(x)) \<Longrightarrow> (\<lambda>x. f(x)) [= (\<lambda>x. g(x))"

  (** Equality - equivalence axioms inherited from FOL.thy   **)
  (**          - congruence of "=" is axiomatised implicitly **)

axiomatization where
  eq_iff:         "t = t' \<longleftrightarrow> t [= t' \<and> t' [= t"

  (** Properties of canonical values given by greatest fixed point definitions **)

axiomatization where
  PO_iff:         "t [= t' \<longleftrightarrow> <t,t'> : PO" and
  EQ_iff:         "t =  t' \<longleftrightarrow> <t,t'> : EQ"

  (** Behaviour of non-canonical terms (ie case) given by the following beta-rules **)

axiomatization where
  caseBtrue:            "case(true,d,e,f,g) = d" and
  caseBfalse:          "case(false,d,e,f,g) = e" and
  caseBpair:           "case(<a,b>,d,e,f,g) = f(a,b)" and
  caseBlam:       "\<And>b. case(lam x. b(x),d,e,f,g) = g(b)" and
  caseBbot:              "case(bot,d,e,f,g) = bot"           (* strictness *)

  (** The theory is non-trivial **)
axiomatization where
  distinctness:   "\<not> lam x. b(x) = bot"

  (*** Definitions of Termination and Divergence ***)

definition Dvg :: "i \<Rightarrow> o"
  where "Dvg(t) == t = bot"

definition Trm :: "i \<Rightarrow> o"
  where "Trm(t) == \<not> Dvg(t)"

text \<open>
Would be interesting to build a similar theory for a typed programming language:
    ie.     true :: bool,      fix :: ('a\<Rightarrow>'a)\<Rightarrow>'a  etc......

This is starting to look like LCF.
What are the advantages of this approach?
        - less axiomatic
        - wfd induction / coinduction and fixed point induction available
\<close>

lemmas ccl_data_defs = apply_def fix_def

declare po_refl [simp]

subsection \<open>Congruence Rules\<close>

(*similar to AP_THM in Gordon's HOL*)
lemma fun_cong: "(f::'a\<Rightarrow>'b) = g \<Longrightarrow> f(x)=g(x)"
  by simp

(*similar to AP_TERM in Gordon's HOL and FOL's subst_context*)
lemma arg_cong: "x=y \<Longrightarrow> f(x)=f(y)"
  by simp

lemma abstractn: "(\<And>x. f(x) = g(x)) \<Longrightarrow> f = g"
  apply (simp add: eq_iff)
  apply (blast intro: po_abstractn)
  done

lemmas caseBs = caseBtrue caseBfalse caseBpair caseBlam caseBbot

subsection \<open>Termination and Divergence\<close>

lemma Trm_iff: "Trm(t) \<longleftrightarrow> \<not> t = bot"
  by (simp add: Trm_def Dvg_def)

lemma Dvg_iff: "Dvg(t) \<longleftrightarrow> t = bot"
  by (simp add: Trm_def Dvg_def)

subsection \<open>Constructors are injective\<close>

lemma eq_lemma: "\<lbrakk>x=a; y=b; x=y\<rbrakk> \<Longrightarrow> a=b"
  by simp

ML \<open>
  fun inj_rl_tac ctxt rews i =
    let
      fun mk_inj_lemmas r = [@{thm arg_cong}] RL [r RS (r RS @{thm eq_lemma})]
      val inj_lemmas = maps mk_inj_lemmas rews
    in
      CHANGED (REPEAT (assume_tac ctxt i ORELSE
        resolve_tac ctxt @{thms iffI allI conjI} i ORELSE
        eresolve_tac ctxt inj_lemmas i ORELSE
        asm_simp_tac (ctxt addsimps rews) i))
    end;
\<close>

method_setup inj_rl = \<open>
  Attrib.thms >> (fn rews => fn ctxt => SIMPLE_METHOD' (inj_rl_tac ctxt rews))
\<close>

lemma ccl_injs:
  "<a,b> = <a',b'> \<longleftrightarrow> (a=a' \<and> b=b')"
  "\<And>b b'. (lam x. b(x) = lam x. b'(x)) \<longleftrightarrow> ((ALL z. b(z)=b'(z)))"
  by (inj_rl caseBs)

lemma pair_inject: "<a,b> = <a',b'> \<Longrightarrow> (a = a' \<Longrightarrow> b = b' \<Longrightarrow> R) \<Longrightarrow> R"
  by (simp add: ccl_injs)

subsection \<open>Constructors are distinct\<close>

lemma lem: "t=t' \<Longrightarrow> case(t,b,c,d,e) = case(t',b,c,d,e)"
  by simp

ML \<open>
local
  fun pairs_of _ _ [] = []
    | pairs_of f x (y::ys) = (f x y) :: (f y x) :: (pairs_of f x ys)

  fun mk_combs _ [] = []
    | mk_combs ff (x::xs) = (pairs_of ff x xs) @ mk_combs ff xs

  (* Doesn't handle binder types correctly *)
  fun saturate thy sy name =
       let fun arg_str 0 _ s = s
         | arg_str 1 a s = "(" ^ a ^ "a" ^ s ^ ")"
         | arg_str n a s = arg_str (n-1) a ("," ^ a ^ (chr((ord "a")+n-1)) ^ s)
           val T = Sign.the_const_type thy (Sign.intern_const thy sy);
           val arity = length (binder_types T)
       in sy ^ (arg_str arity name "") end

  fun mk_thm_str thy a b = "\<not> " ^ (saturate thy a "a") ^ " = " ^ (saturate thy b "b")

  val lemma = @{thm lem};
  val eq_lemma = @{thm eq_lemma};
  val distinctness = @{thm distinctness};
  fun mk_lemma (ra,rb) =
    [lemma] RL [ra RS (rb RS eq_lemma)] RL
    [distinctness RS @{thm notE}, @{thm sym} RS (distinctness RS @{thm notE})]
in
  fun mk_lemmas rls = maps mk_lemma (mk_combs pair rls)
  fun mk_dstnct_rls thy xs = mk_combs (mk_thm_str thy) xs
end
\<close>

ML \<open>
val caseB_lemmas = mk_lemmas @{thms caseBs}

val ccl_dstncts =
  let
    fun mk_raw_dstnct_thm rls s =
      Goal.prove_global \<^theory> [] [] (Syntax.read_prop_global \<^theory> s)
        (fn {context = ctxt, ...} => resolve_tac ctxt @{thms notI} 1 THEN eresolve_tac ctxt rls 1)
  in map (mk_raw_dstnct_thm caseB_lemmas)
    (mk_dstnct_rls \<^theory> ["bot","true","false","pair","lambda"]) end

fun mk_dstnct_thms ctxt defs inj_rls xs =
  let
    val thy = Proof_Context.theory_of ctxt;
    fun mk_dstnct_thm rls s =
      Goal.prove_global thy [] [] (Syntax.read_prop ctxt s)
        (fn _ =>
          rewrite_goals_tac ctxt defs THEN
          simp_tac (ctxt addsimps (rls @ inj_rls)) 1)
  in map (mk_dstnct_thm ccl_dstncts) (mk_dstnct_rls thy xs) end

fun mkall_dstnct_thms ctxt defs i_rls xss = maps (mk_dstnct_thms ctxt defs i_rls) xss

(*** Rewriting and Proving ***)

fun XH_to_I rl = rl RS @{thm iffD2}
fun XH_to_D rl = rl RS @{thm iffD1}
val XH_to_E = make_elim o XH_to_D
val XH_to_Is = map XH_to_I
val XH_to_Ds = map XH_to_D
val XH_to_Es = map XH_to_E;

ML_Thms.bind_thms ("ccl_rews", @{thms caseBs} @ @{thms ccl_injs} @ ccl_dstncts);
ML_Thms.bind_thms ("ccl_dstnctsEs", ccl_dstncts RL [@{thm notE}]);
ML_Thms.bind_thms ("ccl_injDs", XH_to_Ds @{thms ccl_injs});
\<close>

lemmas [simp] = ccl_rews
  and [elim!] = pair_inject ccl_dstnctsEs
  and [dest!] = ccl_injDs

subsection \<open>Facts from gfp Definition of \<open>[=\<close> and \<open>=\<close>\<close>

lemma XHlemma1: "\<lbrakk>A=B; a:B \<longleftrightarrow> P\<rbrakk> \<Longrightarrow> a:A \<longleftrightarrow> P"
  by simp

lemma XHlemma2: "(P(t,t') \<longleftrightarrow> Q) \<Longrightarrow> (<t,t'> : {p. \<exists>t t'. p=<t,t'> \<and>  P(t,t')} \<longleftrightarrow> Q)"
  by blast

subsection \<open>Pre-Order\<close>

lemma POgen_mono: "mono(\<lambda>X. POgen(X))"
  apply (unfold POgen_def SIM_def)
  apply (rule monoI)
  apply blast
  done

lemma POgenXH:
  "<t,t'> : POgen(R) \<longleftrightarrow> t= bot | (t=true \<and> t'=true)  | (t=false \<and> t'=false) |
           (EX a a' b b'. t=<a,b> \<and> t'=<a',b'>  \<and> <a,a'> : R \<and> <b,b'> : R) |
           (EX f f'. t=lam x. f(x) \<and> t'=lam x. f'(x) \<and> (ALL x. <f(x),f'(x)> : R))"
  apply (unfold POgen_def SIM_def)
  apply (rule iff_refl [THEN XHlemma2])
  done

lemma poXH:
  "t [= t' \<longleftrightarrow> t=bot | (t=true \<and> t'=true) | (t=false \<and> t'=false) |
                 (EX a a' b b'. t=<a,b> \<and> t'=<a',b'>  \<and> a [= a' \<and> b [= b') |
                 (EX f f'. t=lam x. f(x) \<and> t'=lam x. f'(x) \<and> (ALL x. f(x) [= f'(x)))"
  apply (simp add: PO_iff del: ex_simps)
  apply (rule POgen_mono
    [THEN PO_def [THEN def_gfp_Tarski], THEN XHlemma1, unfolded POgen_def SIM_def])
  apply (rule iff_refl [THEN XHlemma2])
  done

lemma po_bot: "bot [= b"
  apply (rule poXH [THEN iffD2])
  apply simp
  done

lemma bot_poleast: "a [= bot \<Longrightarrow> a=bot"
  apply (drule poXH [THEN iffD1])
  apply simp
  done

lemma po_pair: "<a,b> [= <a',b'> \<longleftrightarrow>  a [= a' \<and> b [= b'"
  apply (rule poXH [THEN iff_trans])
  apply simp
  done

lemma po_lam: "lam x. f(x) [= lam x. f'(x) \<longleftrightarrow> (ALL x. f(x) [= f'(x))"
  apply (rule poXH [THEN iff_trans])
  apply fastforce
  done

lemmas ccl_porews = po_bot po_pair po_lam

lemma case_pocong:
  assumes 1: "t [= t'"
    and 2: "a [= a'"
    and 3: "b [= b'"
    and 4: "\<And>x y. c(x,y) [= c'(x,y)"
    and 5: "\<And>u. d(u) [= d'(u)"
  shows "case(t,a,b,c,d) [= case(t',a',b',c',d')"
  apply (rule 1 [THEN po_cong, THEN po_trans])
  apply (rule 2 [THEN po_cong, THEN po_trans])
  apply (rule 3 [THEN po_cong, THEN po_trans])
  apply (rule 4 [THEN po_abstractn, THEN po_abstractn, THEN po_cong, THEN po_trans])
  apply (rule_tac f1 = "\<lambda>d. case (t',a',b',c',d)" in
    5 [THEN po_abstractn, THEN po_cong, THEN po_trans])
  apply (rule po_refl)
  done

lemma apply_pocong: "\<lbrakk>f [= f'; a [= a'\<rbrakk> \<Longrightarrow> f ` a [= f' ` a'"
  unfolding ccl_data_defs
  apply (rule case_pocong, (rule po_refl | assumption)+)
  apply (erule po_cong)
  done

lemma npo_lam_bot: "\<not> lam x. b(x) [= bot"
  apply (rule notI)
  apply (drule bot_poleast)
  apply (erule distinctness [THEN notE])
  done

lemma po_lemma: "\<lbrakk>x=a; y=b; x[=y\<rbrakk> \<Longrightarrow> a[=b"
  by simp

lemma npo_pair_lam: "\<not> <a,b> [= lam x. f(x)"
  apply (rule notI)
  apply (rule npo_lam_bot [THEN notE])
  apply (erule case_pocong [THEN caseBlam [THEN caseBpair [THEN po_lemma]]])
  apply (rule po_refl npo_lam_bot)+
  done

lemma npo_lam_pair: "\<not> lam x. f(x) [= <a,b>"
  apply (rule notI)
  apply (rule npo_lam_bot [THEN notE])
  apply (erule case_pocong [THEN caseBpair [THEN caseBlam [THEN po_lemma]]])
  apply (rule po_refl npo_lam_bot)+
  done

lemma npo_rls1:
  "\<not> true [= false"
  "\<not> false [= true"
  "\<not> true [= <a,b>"
  "\<not> <a,b> [= true"
  "\<not> true [= lam x. f(x)"
  "\<not> lam x. f(x) [= true"
  "\<not> false [= <a,b>"
  "\<not> <a,b> [= false"
  "\<not> false [= lam x. f(x)"
  "\<not> lam x. f(x) [= false"
  by (rule notI, drule case_pocong, erule_tac [5] rev_mp, simp_all,
    (rule po_refl npo_lam_bot)+)+

lemmas npo_rls = npo_pair_lam npo_lam_pair npo_rls1

subsection \<open>Coinduction for \<open>[=\<close>\<close>

lemma po_coinduct: "\<lbrakk><t,u> : R; R <= POgen(R)\<rbrakk> \<Longrightarrow> t [= u"
  apply (rule PO_def [THEN def_coinduct, THEN PO_iff [THEN iffD2]])
   apply assumption+
  done

subsection \<open>Equality\<close>

lemma EQgen_mono: "mono(\<lambda>X. EQgen(X))"
  apply (unfold EQgen_def SIM_def)
  apply (rule monoI)
  apply blast
  done

lemma EQgenXH:
  "<t,t'> : EQgen(R) \<longleftrightarrow> (t=bot \<and> t'=bot)  | (t=true \<and> t'=true)  |
                                             (t=false \<and> t'=false) |
                 (EX a a' b b'. t=<a,b> \<and> t'=<a',b'>  \<and> <a,a'> : R \<and> <b,b'> : R) |
                 (EX f f'. t=lam x. f(x) \<and> t'=lam x. f'(x) \<and> (ALL x.<f(x),f'(x)> : R))"
  apply (unfold EQgen_def SIM_def)
  apply (rule iff_refl [THEN XHlemma2])
  done

lemma eqXH:
  "t=t' \<longleftrightarrow> (t=bot \<and> t'=bot)  | (t=true \<and> t'=true)  | (t=false \<and> t'=false) |
                     (EX a a' b b'. t=<a,b> \<and> t'=<a',b'>  \<and> a=a' \<and> b=b') |
                     (EX f f'. t=lam x. f(x) \<and> t'=lam x. f'(x) \<and> (ALL x. f(x)=f'(x)))"
  apply (subgoal_tac "<t,t'> : EQ \<longleftrightarrow>
    (t=bot \<and> t'=bot) | (t=true \<and> t'=true) | (t=false \<and> t'=false) |
    (EX a a' b b'. t=<a,b> \<and> t'=<a',b'> \<and> <a,a'> : EQ \<and> <b,b'> : EQ) |
    (EX f f'. t=lam x. f (x) \<and> t'=lam x. f' (x) \<and> (ALL x. <f (x) ,f' (x) > : EQ))")
  apply (erule rev_mp)
  apply (simp add: EQ_iff [THEN iff_sym])
  apply (rule EQgen_mono [THEN EQ_def [THEN def_gfp_Tarski], THEN XHlemma1,
    unfolded EQgen_def SIM_def])
  apply (rule iff_refl [THEN XHlemma2])
  done

lemma eq_coinduct: "\<lbrakk><t,u> : R; R <= EQgen(R)\<rbrakk> \<Longrightarrow> t = u"
  apply (rule EQ_def [THEN def_coinduct, THEN EQ_iff [THEN iffD2]])
   apply assumption+
  done

lemma eq_coinduct3:
  "\<lbrakk><t,u> : R;  R <= EQgen(lfp(\<lambda>x. EQgen(x) Un R Un EQ))\<rbrakk> \<Longrightarrow> t = u"
  apply (rule EQ_def [THEN def_coinduct3, THEN EQ_iff [THEN iffD2]])
  apply (rule EQgen_mono | assumption)+
  done

method_setup eq_coinduct3 = \<open>
  Scan.lift Parse.embedded_inner_syntax >> (fn s => fn ctxt =>
    SIMPLE_METHOD'
      (Rule_Insts.res_inst_tac ctxt [((("R", 0), Position.none), s)] [] @{thm eq_coinduct3}))
\<close>

subsection \<open>Untyped Case Analysis and Other Facts\<close>

lemma cond_eta: "(EX f. t=lam x. f(x)) \<Longrightarrow> t = lam x.(t ` x)"
  by (auto simp: apply_def)

lemma exhaustion: "(t=bot) | (t=true) | (t=false) | (EX a b. t=<a,b>) | (EX f. t=lam x. f(x))"
  apply (cut_tac refl [THEN eqXH [THEN iffD1]])
  apply blast
  done

lemma term_case:
  "\<lbrakk>P(bot); P(true); P(false); \<And>x y. P(<x,y>); \<And>b. P(lam x. b(x))\<rbrakk> \<Longrightarrow> P(t)"
  using exhaustion [of t] by blast

end


theory Chaining
  imports ChainedEnvironment "../09HeapMemory/HeapMemory"
begin

abbreviation chain_structured :: "ceclosure heap \<Rightarrow> (ptr \<times> ptr) heap \<Rightarrow> bool" where
  "chain_structured h env \<equiv> heap_all (\<lambda>p (v, p'). p' \<le> p \<and> hcontains h v) env"

primrec chained_stack_pointer :: "(ptr \<times> ptr) heap \<Rightarrow> ptr \<Rightarrow> bool" where
  "chained_stack_pointer env 0 = True"
| "chained_stack_pointer env (Suc p) = hcontains env p"

fun chained_frame :: "(ptr \<times> ptr) heap \<Rightarrow> (ptr \<times> nat) \<Rightarrow> bool" where
  "chained_frame env (p, pc) = chained_stack_pointer env p"

abbreviation chained_stack :: "(ptr \<times> ptr) heap \<Rightarrow> (ptr \<times> nat) list \<Rightarrow> bool" where
  "chained_stack env sfs \<equiv> list_all (chained_frame env) sfs"

abbreviation chained_vals :: "ceclosure heap \<Rightarrow> ptr list \<Rightarrow> bool" where
  "chained_vals h vs \<equiv> list_all (hcontains h) vs"

primrec chained_closure :: "(ptr \<times> ptr) heap \<Rightarrow> ceclosure \<Rightarrow> bool" where
  "chained_closure env (CEConst n) = True"
| "chained_closure env (CELam p pc) = chained_frame env (p, pc)"

abbreviation chained_closures :: "(ptr \<times> ptr) heap \<Rightarrow> ceclosure heap \<Rightarrow> bool" where
  "chained_closures env h \<equiv> heap_all (\<lambda>p. chained_closure env) h"

primrec chained_state :: "chained_state \<Rightarrow> bool" where
  "chained_state (CES h env vs sfs) = (
    chain_structured h env \<and> chained_closures env h \<and> chained_vals h vs \<and> chained_stack env sfs)"

fun unstack_list :: "(ptr \<times> ptr) heap \<Rightarrow> ptr \<Rightarrow> ptr list" where
  "unstack_list env 0 = []"
| "unstack_list env (Suc p) = (case hlookup env p of
      (v, p') \<Rightarrow> v # (if p' \<le> p then unstack_list env p' else undefined))"

primrec unchain_closure :: "(ptr \<times> ptr) heap \<Rightarrow> ceclosure \<Rightarrow> hclosure" where
  "unchain_closure env (CEConst k) = HConst k"
| "unchain_closure env (CELam p pc) = HLam (unstack_list env p) pc"

definition unchain_heap :: "ceclosure heap \<Rightarrow> (ptr \<times> ptr) heap \<Rightarrow> hclosure heap" where
  "unchain_heap h env = hmap (unchain_closure env) h"

primrec unchain_frame :: "(ptr \<times> ptr) heap \<Rightarrow> (ptr \<times> nat) \<Rightarrow> (ptr list \<times> nat)" where
  "unchain_frame env (p, pc) = (unstack_list env p, pc)"

definition unchain_stack :: "(ptr \<times> ptr) heap \<Rightarrow> (ptr \<times> nat) list \<Rightarrow> (ptr list \<times> nat) list" where
  "unchain_stack env sfs = map (unchain_frame env) sfs"

primrec unchain_state :: "chained_state \<Rightarrow> heap_state" where
  "unchain_state (CES h env vs sfs) = HS (unchain_heap h env) vs (unchain_stack env sfs)"

lemma [elim]: "hcontains env p \<Longrightarrow> p' \<le> p \<Longrightarrow> chained_stack_pointer env p'"
proof (induction p')
  case (Suc p')
  thus ?case by auto
qed simp_all

lemma [elim]: "chained_stack_pointer env p \<Longrightarrow> p' \<le> p \<Longrightarrow> chained_stack_pointer env p'"
proof (induction p')
  case (Suc p')
  thus ?case by (cases p) auto
qed simp_all

lemma [simp]: "chain_structured h env \<Longrightarrow> chained_stack_pointer env p \<Longrightarrow>
  halloc env a = (env', b) \<Longrightarrow> unstack_list env' p = unstack_list env p"
proof (induction env p rule: unstack_list.induct)
  case (2 env p)
  obtain v p' where V: "hlookup env p = (v, p')" by (cases "hlookup env p")
  from 2 have H: "hcontains env p" by auto
  with 2 V have P: "p' \<le> p" using heap_lookup_all by fast
  with 2 have "chained_stack_pointer env p'" by auto
  with 2 V P have U: "unstack_list env' p' = unstack_list env p'" by simp
  from 2 V H have "hlookup env' p = (v, p')" by simp
  with V P U show ?case by simp
qed simp_all

lemma unfold_unstack_list [simp]: "chain_structured h env \<Longrightarrow> chained_stack_pointer env p \<Longrightarrow>
  halloc env (v, p) = (env', p') \<Longrightarrow> unstack_list env' (Suc p') = v # unstack_list env p"
proof -
  assume A: "chain_structured h env"
  assume B: "chained_stack_pointer env p"
  assume C: "halloc env (v, p) = (env', p')"
  moreover with A B have "unstack_list env' p = unstack_list env p" by simp
  moreover have "p \<le> p'"
  proof (cases p)
    case (Suc pp)
    moreover with B C have "pp < p'" by simp
    ultimately show ?thesis by simp
  qed simp_all
  ultimately show ?thesis by simp
qed

lemma [simp]: "chain_structured h env \<Longrightarrow> chained_stack_pointer env p \<Longrightarrow>
  lookup (unstack_list env p) x = chain_lookup env p x"
proof (induction env p x rule: chain_lookup.induct)
  case (3 env p x)
  obtain v p' where V: "hlookup env p = (v, p')" by (cases "hlookup env p")
  from 3 have "hcontains env p" by auto
  with 3 V have P: "p' \<le> p" using heap_lookup_all by fast
  with 3 have "chained_stack_pointer env p'" by auto
  with 3(1, 2) V P show ?case by fastforce
qed (simp_all split: prod.splits)

lemma [simp]: "halloc h (CEConst k) = (h', p) \<Longrightarrow>
  halloc (unchain_heap h env) (HConst k) = (unchain_heap h' env, p)"
proof -
  assume "halloc h (CEConst k) = (h', p)"
  hence "halloc (hmap (unchain_closure env) h) (unchain_closure env (CEConst k)) =
    (hmap (unchain_closure env) h', p)" by (metis halloc_map)
  thus ?thesis by (simp add: unchain_heap_def)
qed

lemma [simp]: "halloc h (CELam p pc) = (h', v) \<Longrightarrow>
  halloc (unchain_heap h env) (HLam (unstack_list env p) pc) = (unchain_heap h' env, v)"
proof -
  assume "halloc h (CELam p pc) = (h', v)"
  hence "halloc (hmap (unchain_closure env) h) (unchain_closure env (CELam p pc)) =
    (hmap (unchain_closure env) h', v)" by (metis halloc_map)
  thus ?thesis by (simp add: unchain_heap_def)
qed

lemma [simp]: "hlookup h x = CEConst k \<Longrightarrow> hcontains h x \<Longrightarrow>
    hlookup (unchain_heap h env) x = HConst k"
  by (simp add: unchain_heap_def)

lemma [simp]: "hlookup h x = CELam p pc \<Longrightarrow> hcontains h x \<Longrightarrow>
    hlookup (unchain_heap h env) x = HLam (unstack_list env p) pc"
  by (simp add: unchain_heap_def)

lemma unchain_state_reverse [dest]: "HS h vs sfs = unchain_state \<Sigma> \<Longrightarrow>
  \<exists>h\<^sub>c\<^sub>e env sfs\<^sub>c\<^sub>e. \<Sigma> = CES h\<^sub>c\<^sub>e env vs sfs\<^sub>c\<^sub>e \<and> h = unchain_heap h\<^sub>c\<^sub>e env \<and>
    sfs = unchain_stack env sfs\<^sub>c\<^sub>e"
  by (induction \<Sigma>) simp_all

lemma [dest]: "HLam env\<^sub>h pc = unchain_closure env\<^sub>c\<^sub>e x \<Longrightarrow>
    \<exists>p. x = CELam p pc \<and> env\<^sub>h = unstack_list env\<^sub>c\<^sub>e p"
  by (induction x) simp_all

lemma [elim]: "hcontains env p \<Longrightarrow> halloc env v = (env', q) \<Longrightarrow>
    unstack_list env' p = unstack_list env p"
proof (induction env p rule: unstack_list.induct)
  case (2 env p)
  obtain vv p' where V: "hlookup env p = (vv, p')" by (cases "hlookup env p")
  from 2(2) have "hcontains env p" by fast
  with 2(3) V have V': "hlookup env' p = (vv, p')" by simp
  from 2(2) V have "p' \<le> p \<Longrightarrow> hcontains env p'" by auto
  with 2 V have "p' \<le> p \<Longrightarrow> unstack_list env' p' = unstack_list env p'" by metis
  with V V' show ?case by simp
qed simp_all

lemma [elim]: "chain_structured h env \<Longrightarrow> chained_closures env h \<Longrightarrow> halloc env v = (env', p) \<Longrightarrow>
  unchain_heap h env' = unchain_heap h env"
proof (unfold unchain_heap_def)
  assume S: "chain_structured h env" and C: "chained_closures env h"
    and A: "halloc env v = (env', p)"
  have "\<And>x. hcontains h x \<Longrightarrow> unchain_closure env' (hlookup h x) =
    unchain_closure env (hlookup h x)"
  proof -
    fix x
    assume X: "hcontains h x"
    show "unchain_closure env' (hlookup h x) = unchain_closure env (hlookup h x)"
    proof (cases "hlookup h x")
      case (CELam pp pc)
      with C X have "chained_closure env (CELam pp pc)" by (metis heap_lookup_all)
      with S A CELam show ?thesis by auto
    qed simp_all
  qed
  thus "hmap (unchain_closure env') h = hmap (unchain_closure env) h" by (metis hmap_eq)
qed

lemma [elim]: "chained_stack_pointer env a \<Longrightarrow> halloc env v = (env', p) \<Longrightarrow>
  unstack_list env' a = unstack_list env a"
proof (induction a)
  case (Suc p)
  moreover obtain v' p' where "hlookup env p = (v', p')" by (cases "hlookup env p")
  moreover from Suc have "p' \<le> p \<Longrightarrow> hcontains env p'" by auto
  ultimately show ?case by auto
qed simp_all

lemma [elim]: "chained_frame env a \<Longrightarrow> halloc env v = (env', p) \<Longrightarrow>
    unchain_frame env' a = unchain_frame env a"
  by (induction a) auto

lemma [elim]: "chained_stack env sfs \<Longrightarrow> halloc env v = (env', p) \<Longrightarrow>
    unchain_stack env' sfs = unchain_stack env sfs"
  by (induction sfs) (auto simp add: unchain_stack_def)

theorem completece [simp]: "cd \<tturnstile> unchain_state \<Sigma>\<^sub>c\<^sub>e \<leadsto>\<^sub>h \<Sigma>\<^sub>h \<Longrightarrow> chained_state \<Sigma>\<^sub>c\<^sub>e \<Longrightarrow>
  \<exists>\<Sigma>\<^sub>c\<^sub>e'. (cd \<tturnstile> \<Sigma>\<^sub>c\<^sub>e \<leadsto>\<^sub>c\<^sub>e \<Sigma>\<^sub>c\<^sub>e') \<and> \<Sigma>\<^sub>h = unchain_state \<Sigma>\<^sub>c\<^sub>e'"
proof (induction "unchain_state \<Sigma>\<^sub>c\<^sub>e" \<Sigma>\<^sub>h arbitrary: \<Sigma>\<^sub>c\<^sub>e rule: evalh.induct)
  case (evh_lookup cd pc x env v h vs sfs)
  then obtain h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e' where S: "\<Sigma>\<^sub>c\<^sub>e = CES h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e vs sfs\<^sub>c\<^sub>e' \<and> h = unchain_heap h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e \<and>
    (env, Suc pc) # sfs = unchain_stack env\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e'" by fastforce
  then obtain sf\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e where SF: "sfs\<^sub>c\<^sub>e' = sf\<^sub>c\<^sub>e # sfs\<^sub>c\<^sub>e \<and> (env, Suc pc) = unchain_frame env\<^sub>c\<^sub>e sf\<^sub>c\<^sub>e \<and>
    sfs = unchain_stack env\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e" by (auto simp add: unchain_stack_def)
  then obtain p where P: "sf\<^sub>c\<^sub>e = (p, Suc pc) \<and> env = unstack_list env\<^sub>c\<^sub>e p" by (cases sf\<^sub>c\<^sub>e) simp_all
  with evh_lookup S SF have C: "chain_structured h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e" by simp
  with evh_lookup S SF P have X: "HS h (v # vs) ((env, pc) # sfs) =
    unchain_state (CES h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e (v # vs) ((p, pc) # sfs\<^sub>c\<^sub>e))" by (simp add: unchain_stack_def)
  from evh_lookup S SF P have "chained_frame env\<^sub>c\<^sub>e (p, Suc pc)" by simp
  with C have "lookup (unstack_list env\<^sub>c\<^sub>e p) x = chain_lookup env\<^sub>c\<^sub>e p x" by simp
  with evh_lookup P C have "cd \<tturnstile> CES h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e vs ((p, Suc pc) # sfs\<^sub>c\<^sub>e) \<leadsto>\<^sub>c\<^sub>e
    CES h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e (v # vs) ((p, pc) # sfs\<^sub>c\<^sub>e)" by simp
  with S SF P X show ?case by blast
next
  case (evh_pushcon cd pc k h h' v vs env sfs)
  then obtain h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e' where S: "\<Sigma>\<^sub>c\<^sub>e = CES h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e vs sfs\<^sub>c\<^sub>e' \<and> h = unchain_heap h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e \<and>
    (env, Suc pc) # sfs = unchain_stack env\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e'" by fastforce
  then obtain sf\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e where SF: "sfs\<^sub>c\<^sub>e' = sf\<^sub>c\<^sub>e # sfs\<^sub>c\<^sub>e \<and> (env, Suc pc) = unchain_frame env\<^sub>c\<^sub>e sf\<^sub>c\<^sub>e \<and>
    sfs = unchain_stack env\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e" by (auto simp add: unchain_stack_def)
  then obtain p where P: "sf\<^sub>c\<^sub>e = (p, Suc pc) \<and> env = unstack_list env\<^sub>c\<^sub>e p" by (cases sf\<^sub>c\<^sub>e) simp_all
  from evh_pushcon S have "halloc (hmap (unchain_closure env\<^sub>c\<^sub>e) h\<^sub>c\<^sub>e)
    (unchain_closure env\<^sub>c\<^sub>e (CEConst k)) = (h', v)" by (simp add: unchain_heap_def)
  then obtain h\<^sub>c\<^sub>e' where H: "halloc h\<^sub>c\<^sub>e (CEConst k) = (h\<^sub>c\<^sub>e', v) \<and>
    h' = hmap (unchain_closure env\<^sub>c\<^sub>e) h\<^sub>c\<^sub>e'" by (metis halloc_map_inv)
  hence "h' = unchain_heap h\<^sub>c\<^sub>e' env\<^sub>c\<^sub>e" by (simp add: unchain_heap_def)
  with SF P have X: "HS h' (v # vs) ((env, pc) # sfs) =
    unchain_state (CES h\<^sub>c\<^sub>e' env\<^sub>c\<^sub>e (v # vs) ((p, pc) # sfs\<^sub>c\<^sub>e))" by (simp add: unchain_stack_def)
  from evh_pushcon H have "cd \<tturnstile> CES h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e vs ((p, Suc pc) # sfs\<^sub>c\<^sub>e) \<leadsto>\<^sub>c\<^sub>e
    CES h\<^sub>c\<^sub>e' env\<^sub>c\<^sub>e (v # vs) ((p, pc) # sfs\<^sub>c\<^sub>e)" by simp
  with S SF P X show ?case by blast
next
  case (evh_pushlam cd pc pc' h env h' v vs sfs)
  then obtain h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e' where S: "\<Sigma>\<^sub>c\<^sub>e = CES h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e vs sfs\<^sub>c\<^sub>e' \<and> h = unchain_heap h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e \<and>
    (env, Suc pc) # sfs = unchain_stack env\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e'" by fastforce
  then obtain sf\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e where SF: "sfs\<^sub>c\<^sub>e' = sf\<^sub>c\<^sub>e # sfs\<^sub>c\<^sub>e \<and> (env, Suc pc) = unchain_frame env\<^sub>c\<^sub>e sf\<^sub>c\<^sub>e \<and>
    sfs = unchain_stack env\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e" by (auto simp add: unchain_stack_def)
  then obtain p where P: "sf\<^sub>c\<^sub>e = (p, Suc pc) \<and> env = unstack_list env\<^sub>c\<^sub>e p" by (cases sf\<^sub>c\<^sub>e) simp_all
  with evh_pushlam S have "halloc (hmap (unchain_closure env\<^sub>c\<^sub>e) h\<^sub>c\<^sub>e)
    (unchain_closure env\<^sub>c\<^sub>e (CELam p pc')) = (h', v)" by (simp add: unchain_heap_def)
  then obtain h\<^sub>c\<^sub>e' where H: "halloc h\<^sub>c\<^sub>e (CELam p pc') = (h\<^sub>c\<^sub>e', v) \<and>
    h' = hmap (unchain_closure env\<^sub>c\<^sub>e) h\<^sub>c\<^sub>e'" by (metis halloc_map_inv)
  hence "h' = unchain_heap h\<^sub>c\<^sub>e' env\<^sub>c\<^sub>e" by (simp add: unchain_heap_def)
  with SF P have X: "HS h' (v # vs) ((env, pc) # sfs) =
    unchain_state (CES h\<^sub>c\<^sub>e' env\<^sub>c\<^sub>e (v # vs) ((p, pc) # sfs\<^sub>c\<^sub>e))" by (simp add: unchain_stack_def)
  from evh_pushlam H have "cd \<tturnstile> CES h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e vs ((p, Suc pc) # sfs\<^sub>c\<^sub>e) \<leadsto>\<^sub>c\<^sub>e
    CES h\<^sub>c\<^sub>e' env\<^sub>c\<^sub>e (v # vs) ((p, pc) # sfs\<^sub>c\<^sub>e)" by simp
  with S SF P X show ?case by blast
next
  case (evh_apply cd pc h v2 env' pc' v1 vs env sfs)
  then obtain h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e' where S: "\<Sigma>\<^sub>c\<^sub>e = CES h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e (v1 # v2 # vs) sfs\<^sub>c\<^sub>e' \<and>
    h = unchain_heap h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e \<and> (env, Suc pc) # sfs = unchain_stack env\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e'" by fastforce
  then obtain sf\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e where SF: "sfs\<^sub>c\<^sub>e' = sf\<^sub>c\<^sub>e # sfs\<^sub>c\<^sub>e \<and> (env, Suc pc) = unchain_frame env\<^sub>c\<^sub>e sf\<^sub>c\<^sub>e \<and>
    sfs = unchain_stack env\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e" by (auto simp add: unchain_stack_def)
  then obtain p where P: "sf\<^sub>c\<^sub>e = (p, Suc pc) \<and> env = unstack_list env\<^sub>c\<^sub>e p" by (cases sf\<^sub>c\<^sub>e) simp_all
  from evh_apply S have "HLam env' pc' = unchain_closure env\<^sub>c\<^sub>e (hlookup h\<^sub>c\<^sub>e v2)"
    by (simp add: unchain_heap_def)
  then obtain p' where P': "hlookup h\<^sub>c\<^sub>e v2 = CELam p' pc' \<and> env' = unstack_list env\<^sub>c\<^sub>e p'" by blast
  obtain env\<^sub>c\<^sub>e' p'' where H: "halloc env\<^sub>c\<^sub>e (v1, p') = (env\<^sub>c\<^sub>e', p'')"
    by (cases "halloc env\<^sub>c\<^sub>e (v1, p')") simp_all
  from evh_apply S SF P have C: "chain_structured h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e \<and> chained_closures env\<^sub>c\<^sub>e h\<^sub>c\<^sub>e \<and>
    hcontains h\<^sub>c\<^sub>e v1 \<and> hcontains h\<^sub>c\<^sub>e v2 \<and> chained_vals h\<^sub>c\<^sub>e vs \<and> chained_frame env\<^sub>c\<^sub>e (p, Suc pc) \<and>
      chained_stack env\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e" by simp
  with H have Y: "unchain_heap h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e' = unchain_heap h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e" by fast
  from H C have "unstack_list env\<^sub>c\<^sub>e' p = unstack_list env\<^sub>c\<^sub>e p" by fastforce
  with P have W: "env = unstack_list env\<^sub>c\<^sub>e' p" by metis
  from P' C have "chained_closure env\<^sub>c\<^sub>e (CELam p' pc')" by (metis heap_lookup_all)
  hence "chained_stack_pointer env\<^sub>c\<^sub>e p'" by auto
  with H C have "unstack_list env\<^sub>c\<^sub>e' (Suc p'') = v1 # unstack_list env\<^sub>c\<^sub>e p'"
    by (metis unfold_unstack_list)
  with H P' have Z: "v1 # env' = unstack_list env\<^sub>c\<^sub>e' (Suc p'')" by simp
  from H C have "unchain_stack env\<^sub>c\<^sub>e' sfs\<^sub>c\<^sub>e = unchain_stack env\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e" by fast
  with SF have "sfs = unchain_stack env\<^sub>c\<^sub>e' sfs\<^sub>c\<^sub>e" by simp
  with S Y Z W have X: "HS h vs ((v1 # env', pc') # (env, pc) # sfs) =
    unchain_state (CES h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e' vs ((Suc p'', pc') # (p, pc) # sfs\<^sub>c\<^sub>e))"
      by (simp add: unchain_stack_def)
  from evh_apply P' H have "cd \<tturnstile> CES h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e (v1 # v2 # vs) ((p, Suc pc) # sfs\<^sub>c\<^sub>e) \<leadsto>\<^sub>c\<^sub>e
      CES h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e' vs ((Suc p'', pc') # (p, pc) # sfs\<^sub>c\<^sub>e)" by simp
  with S SF P X show ?case by blast
next
  case (evh_return cd pc h vs env sfs)
  then obtain h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e' where S: "\<Sigma>\<^sub>c\<^sub>e = CES h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e vs sfs\<^sub>c\<^sub>e' \<and> h = unchain_heap h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e \<and>
    (env, Suc pc) # sfs = unchain_stack env\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e'" by fastforce
  then obtain sf\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e where SF: "sfs\<^sub>c\<^sub>e' = sf\<^sub>c\<^sub>e # sfs\<^sub>c\<^sub>e \<and> (env, Suc pc) = unchain_frame env\<^sub>c\<^sub>e sf\<^sub>c\<^sub>e \<and>
    sfs = unchain_stack env\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e" by (auto simp add: unchain_stack_def)
  then obtain p where P: "sf\<^sub>c\<^sub>e = (p, Suc pc) \<and> env = unstack_list env\<^sub>c\<^sub>e p" by (cases sf\<^sub>c\<^sub>e) simp_all
  from S SF have X: "HS h vs sfs = unchain_state (CES h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e vs sfs\<^sub>c\<^sub>e)" by simp
  from evh_return have "cd \<tturnstile> CES h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e vs ((p, Suc pc) # sfs\<^sub>c\<^sub>e) \<leadsto>\<^sub>c\<^sub>e CES h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e vs sfs\<^sub>c\<^sub>e" by simp
  with S SF P X show ?case by blast
next
  case (evh_jump cd pc h v2 env' pc' v1 vs env sfs)
  then obtain h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e' where S: "\<Sigma>\<^sub>c\<^sub>e = CES h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e (v1 # v2 # vs) sfs\<^sub>c\<^sub>e' \<and>
    h = unchain_heap h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e \<and> (env, Suc pc) # sfs = unchain_stack env\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e'" by fastforce
  then obtain sf\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e where SF: "sfs\<^sub>c\<^sub>e' = sf\<^sub>c\<^sub>e # sfs\<^sub>c\<^sub>e \<and> (env, Suc pc) = unchain_frame env\<^sub>c\<^sub>e sf\<^sub>c\<^sub>e \<and>
    sfs = unchain_stack env\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e" by (auto simp add: unchain_stack_def)
  then obtain p where P: "sf\<^sub>c\<^sub>e = (p, Suc pc) \<and> env = unstack_list env\<^sub>c\<^sub>e p" by (cases sf\<^sub>c\<^sub>e) simp_all
  from evh_jump S have "HLam env' pc' = unchain_closure env\<^sub>c\<^sub>e (hlookup h\<^sub>c\<^sub>e v2)"
    by (simp add: unchain_heap_def)
  then obtain p' where P': "hlookup h\<^sub>c\<^sub>e v2 = CELam p' pc' \<and> env' = unstack_list env\<^sub>c\<^sub>e p'" by blast
  obtain env\<^sub>c\<^sub>e' p'' where H: "halloc env\<^sub>c\<^sub>e (v1, p') = (env\<^sub>c\<^sub>e', p'')"
    by (cases "halloc env\<^sub>c\<^sub>e (v1, p')") simp_all
  from evh_jump S SF P have C: "chain_structured h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e \<and> chained_closures env\<^sub>c\<^sub>e h\<^sub>c\<^sub>e \<and>
    hcontains h\<^sub>c\<^sub>e v1 \<and> hcontains h\<^sub>c\<^sub>e v2 \<and> chained_vals h\<^sub>c\<^sub>e vs \<and> chained_stack_pointer env\<^sub>c\<^sub>e p \<and>
      chained_stack env\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e" by simp
  with H have Y: "unchain_heap h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e' = unchain_heap h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e" by fast
  from P' C have "chained_closure env\<^sub>c\<^sub>e (CELam p' pc')" by (metis heap_lookup_all)
  hence "chained_stack_pointer env\<^sub>c\<^sub>e p'" by simp
  with H C have "unstack_list env\<^sub>c\<^sub>e' (Suc p'') = v1 # unstack_list env\<^sub>c\<^sub>e p'"
    by (metis unfold_unstack_list)
  with H P' have Z: "v1 # env' = unstack_list env\<^sub>c\<^sub>e' (Suc p'')" by simp
  from H C have "unchain_stack env\<^sub>c\<^sub>e' sfs\<^sub>c\<^sub>e = unchain_stack env\<^sub>c\<^sub>e sfs\<^sub>c\<^sub>e" by fast
  with SF have "sfs = unchain_stack env\<^sub>c\<^sub>e' sfs\<^sub>c\<^sub>e" by simp
  with S Y Z have X: "HS h vs ((v1 # env', pc') # sfs) =
    unchain_state (CES h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e' vs ((Suc p'', pc') # sfs\<^sub>c\<^sub>e))" by (simp add: unchain_stack_def)
  from evh_jump P' H have "cd \<tturnstile> CES h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e (v1 # v2 # vs) ((p, Suc pc) # sfs\<^sub>c\<^sub>e) \<leadsto>\<^sub>c\<^sub>e
      CES h\<^sub>c\<^sub>e env\<^sub>c\<^sub>e' vs ((Suc p'', pc') # sfs\<^sub>c\<^sub>e)" by simp
  with S SF P X show ?case by blast
qed

theorem correctce [simp]: "cd \<tturnstile> \<Sigma>\<^sub>c\<^sub>e \<leadsto>\<^sub>c\<^sub>e \<Sigma>\<^sub>c\<^sub>e' \<Longrightarrow> chained_state \<Sigma>\<^sub>c\<^sub>e \<Longrightarrow>
  cd \<tturnstile> unchain_state \<Sigma>\<^sub>c\<^sub>e \<leadsto>\<^sub>h unchain_state \<Sigma>\<^sub>c\<^sub>e'"
proof (induction \<Sigma>\<^sub>c\<^sub>e \<Sigma>\<^sub>c\<^sub>e' rule: evalce.induct)
  case (evce_lookup cd pc x env p v h vs sfs)
  moreover hence "lookup (unstack_list env p) x = chain_lookup env p x" by auto
  ultimately show ?case by (simp add: unchain_stack_def)
next
  case (evce_apply cd pc h v2 p' pc' env v1 env' p'' vs p sfs)
  from evce_apply have "chained_closures env h \<and> hcontains h v2" by simp
  with evce_apply have "chained_closure env (CELam p' pc')" by (metis heap_lookup_all)
  with evce_apply have "chain_structured h env \<and> chained_stack_pointer env p' \<and>
    halloc env (v1, p') = (env', p'')" by auto
  hence X: "unstack_list env' (Suc p'') = v1 # unstack_list env p'" by (metis unfold_unstack_list)
  from evce_apply have A: "unchain_heap h env' = unchain_heap h env" by auto
  from evce_apply have B: "unstack_list env' p = unstack_list env p" by auto
  from evce_apply have "unchain_stack env' sfs = unchain_stack env sfs" by auto
  with evce_apply X A B have "cd \<tturnstile> HS (unchain_heap h env) (v1 # v2 # vs)
    ((unstack_list env p, Suc pc) # unchain_stack env sfs) \<leadsto>\<^sub>h
      HS (unchain_heap h env') vs
        ((unstack_list env' (Suc p''), pc') # (unstack_list env' p, pc) # unchain_stack env' sfs)"
    by simp
  thus ?case by (simp add: unchain_stack_def)
next
  case (evce_jump cd pc h v2 p' pc' env v1 env' p'' vs p sfs)
  from evce_jump have "chained_closures env h \<and> hcontains h v2" by simp
  with evce_jump have "chained_closure env (CELam p' pc')" by (metis heap_lookup_all)
  with evce_jump have "chain_structured h env \<and> chained_stack_pointer env p' \<and>
    halloc env (v1, p') = (env', p'')" by auto
  hence X: "unstack_list env' (Suc p'') = v1 # unstack_list env p'" by (metis unfold_unstack_list)
  from evce_jump have A: "unchain_heap h env' = unchain_heap h env" by auto
  from evce_jump have "unchain_stack env' sfs = unchain_stack env sfs" by auto
  with evce_jump X A have "cd \<tturnstile> HS (unchain_heap h env) (v1 # v2 # vs)
    ((unstack_list env p, Suc pc) # unchain_stack env sfs) \<leadsto>\<^sub>h
      HS (unchain_heap h env') vs
        ((unstack_list env' (Suc p''), pc') # unchain_stack env' sfs)" by simp
  thus ?case by (simp add: unchain_stack_def)
qed (simp_all add: unchain_stack_def)

lemma [simp]: "halloc env (v, p') = (env', p) \<Longrightarrow> p' < p \<Longrightarrow> hcontains h v \<Longrightarrow>
    chain_structured h env \<Longrightarrow> chain_structured h env'"
  by auto

lemma [simp]: "halloc env v = (env', p) \<Longrightarrow> chained_stack_pointer env a \<Longrightarrow>
    chained_stack_pointer env' a"
  by (cases a) simp_all

lemma [simp]: "halloc env (v, p') = (env', p) \<Longrightarrow> chained_frame env f \<Longrightarrow> chained_frame env' f"
  by (induction f) simp_all

lemma [simp]: "halloc env (v, p') = (env', p) \<Longrightarrow> chained_stack env sfs \<Longrightarrow>
    chained_stack env' sfs"
  by (induction sfs) simp_all

lemma [elim]: "chain_structured h env \<Longrightarrow> hcontains env p \<Longrightarrow> hlookup env p = (a, b) \<Longrightarrow>
    hcontains h a"
proof -
  assume "chain_structured h env" and "hcontains env p" and "hlookup env p = (a, b)"
  hence "(\<lambda>(v, p'). p' \<le> p \<and> hcontains h v) (a, b)" by (metis heap_lookup_all)
  thus ?thesis by simp
qed

lemma [elim]: "chain_structured h env \<Longrightarrow> hcontains env p \<Longrightarrow> chain_lookup env p x = Some v \<Longrightarrow>
  hcontains h v"
proof (induction env p x rule: chain_lookup.induct)
  case (2 env p)
  moreover obtain a b where "hlookup env p = (a, b)" by (cases "hlookup env p")
  ultimately show ?case by auto
next
  case (3 env p x)
  obtain a b where A: "hlookup env p = (a, b)" by (cases "hlookup env p")
  from 3 have "hcontains env p" by auto
  with 3 A have "b \<le> p \<and> hcontains h a" using heap_lookup_all by fast
  with 3 have "hcontains env b" by fastforce
  with 3 A show ?case by simp
qed simp_all

lemma [simp]: "halloc h v = (h', p) \<Longrightarrow> chain_structured h env \<Longrightarrow> chain_structured h' env"
proof -
  define pp where "pp = (\<lambda>(p::nat) (v, p'). p' \<le> p \<and> hcontains h v)"
  define qq where "qq = (\<lambda>(p::nat) (v, p'). p' \<le> p \<and> hcontains h' v)"
  assume "halloc h v = (h', p)"
  hence A: "\<And>x y. pp x y \<Longrightarrow> qq x y" by (auto simp add: pp_def qq_def split: prod.splits)
  assume "chain_structured h env"
  hence "heap_all pp env" by (simp add: pp_def)
  with A have "heap_all qq env" by (metis heap_all_impl)
  thus "chain_structured h' env" by (simp add: qq_def)
qed

lemma [simp]: "halloc h v = (h', p) \<Longrightarrow> chained_vals h vs \<Longrightarrow> chained_vals h' vs"
  by (induction vs) auto

lemma [simp]: "halloc env v = (env', p) \<Longrightarrow> chained_closure env c \<Longrightarrow> chained_closure env' c"
  by (induction c) simp_all

lemma [simp]: "halloc env v = (env', p) \<Longrightarrow> chained_closures env h \<Longrightarrow> chained_closures env' h"
proof -
  assume "halloc env v = (env', p)"
  hence "\<And>y. chained_closure env y \<Longrightarrow> chained_closure env' y" by simp_all
  moreover assume "chained_closures env h"
  ultimately show "chained_closures env' h" by (metis heap_all_impl)
qed

lemma [simp]: "hlookup h v2 = CELam p' pc' \<Longrightarrow> chained_closures env h \<Longrightarrow> hcontains h v2 \<Longrightarrow>
  hcontains h v1 \<Longrightarrow> halloc env (v1, p') = (env', p'') \<Longrightarrow> chain_structured h env \<Longrightarrow>
    chain_structured h env'"
proof -
  assume "chained_closures env h" and "hlookup h v2 = CELam p' pc'" and "hcontains h v2"
  hence X: "chained_stack_pointer env p'" using heap_lookup_all by fastforce
  moreover assume A: "halloc env (v1, p') = (env', p'')" and "chain_structured h env"
    and "hcontains h v1"
  moreover have "p' \<le> p''"
  proof (cases p')
    case (Suc pp)
    moreover with X A have "pp < p''" by simp
    ultimately show ?thesis by simp
  qed simp_all
  ultimately show ?thesis by auto
qed

lemma [elim]: "chain_lookup env (Suc p) x = Some v \<Longrightarrow> chain_structured h env \<Longrightarrow>
  hcontains env p \<Longrightarrow> hcontains h v"
proof (induction env "Suc p" x arbitrary: p rule: chain_lookup.induct)
  case (2 env p)
  then obtain b where "hlookup env p = (v, b)" by (cases "hlookup env p") simp_all
  with 2 have "b \<le> p \<and> hcontains h v" using heap_lookup_all by fast
  with 2 show ?case by simp
next
  case (3 env p x)
  moreover then obtain a b where A: "hlookup env p = (a, b)" by (cases "hlookup env p")
  moreover with 3 have "b \<le> p \<and> hcontains h a" using heap_lookup_all by fast
  ultimately show ?case by auto
qed

lemma [simp]: "cd \<tturnstile> \<Sigma>\<^sub>c\<^sub>e \<leadsto>\<^sub>c\<^sub>e \<Sigma>\<^sub>c\<^sub>e' \<Longrightarrow> chained_state \<Sigma>\<^sub>c\<^sub>e \<Longrightarrow> chained_state \<Sigma>\<^sub>c\<^sub>e'"
proof (induction \<Sigma>\<^sub>c\<^sub>e \<Sigma>\<^sub>c\<^sub>e' rule: evalce.induct)
  case (evce_lookup cd pc x env p v h vs sfs)
  thus ?case by (cases p) auto
qed auto

lemma [simp]: "iter (\<tturnstile> cd \<leadsto>\<^sub>c\<^sub>e) \<Sigma>\<^sub>c\<^sub>e \<Sigma>\<^sub>c\<^sub>e' \<Longrightarrow> chained_state \<Sigma>\<^sub>c\<^sub>e \<Longrightarrow>
  iter (\<tturnstile> cd \<leadsto>\<^sub>h) (unchain_state \<Sigma>\<^sub>c\<^sub>e) (unchain_state \<Sigma>\<^sub>c\<^sub>e')"
proof (induction \<Sigma>\<^sub>c\<^sub>e \<Sigma>\<^sub>c\<^sub>e' rule: iter.induct)
  case (iter_step \<Sigma>\<^sub>c\<^sub>e \<Sigma>\<^sub>c\<^sub>e' \<Sigma>\<^sub>c\<^sub>e'')
  hence "iter (\<tturnstile> cd \<leadsto>\<^sub>h) (unchain_state \<Sigma>\<^sub>c\<^sub>e') (unchain_state \<Sigma>\<^sub>c\<^sub>e'')" by simp
  moreover from iter_step have "cd \<tturnstile> unchain_state \<Sigma>\<^sub>c\<^sub>e \<leadsto>\<^sub>h unchain_state \<Sigma>\<^sub>c\<^sub>e'" by simp
  ultimately show ?case by simp
qed simp_all

lemma [simp]: "iter (\<tturnstile> cd \<leadsto>\<^sub>h) (unchain_state \<Sigma>\<^sub>c\<^sub>e) \<Sigma>\<^sub>h \<Longrightarrow> chained_state \<Sigma>\<^sub>c\<^sub>e \<Longrightarrow>
  \<exists>\<Sigma>\<^sub>c\<^sub>e'. iter (\<tturnstile> cd \<leadsto>\<^sub>c\<^sub>e) \<Sigma>\<^sub>c\<^sub>e \<Sigma>\<^sub>c\<^sub>e' \<and> \<Sigma>\<^sub>h = unchain_state \<Sigma>\<^sub>c\<^sub>e'"
proof (induction "unchain_state \<Sigma>\<^sub>c\<^sub>e" \<Sigma>\<^sub>h arbitrary: \<Sigma>\<^sub>c\<^sub>e rule: iter.induct)
  case (iter_step \<Sigma>\<^sub>h' \<Sigma>\<^sub>h'')
  then obtain \<Sigma>\<^sub>c\<^sub>e' where "(cd \<tturnstile> \<Sigma>\<^sub>c\<^sub>e \<leadsto>\<^sub>c\<^sub>e \<Sigma>\<^sub>c\<^sub>e') \<and> \<Sigma>\<^sub>h' = unchain_state \<Sigma>\<^sub>c\<^sub>e'" by fastforce
  moreover with iter_step obtain \<Sigma>\<^sub>c\<^sub>e'' where "iter (\<tturnstile> cd \<leadsto>\<^sub>c\<^sub>e) \<Sigma>\<^sub>c\<^sub>e' \<Sigma>\<^sub>c\<^sub>e'' \<and>
    \<Sigma>\<^sub>h'' = unchain_state \<Sigma>\<^sub>c\<^sub>e''" by fastforce
  ultimately have "iter (\<tturnstile> cd \<leadsto>\<^sub>c\<^sub>e) \<Sigma>\<^sub>c\<^sub>e \<Sigma>\<^sub>c\<^sub>e'' \<and> \<Sigma>\<^sub>h'' = unchain_state \<Sigma>\<^sub>c\<^sub>e''" by fastforce
  then show ?case by fastforce
qed force+

lemma preserve_chained [simp]: "iter (\<tturnstile> cd \<leadsto>\<^sub>c\<^sub>e) \<Sigma>\<^sub>c\<^sub>e \<Sigma>\<^sub>c\<^sub>e' \<Longrightarrow> chained_state \<Sigma>\<^sub>c\<^sub>e \<Longrightarrow>
    chained_state \<Sigma>\<^sub>c\<^sub>e'"
  by (induction \<Sigma>\<^sub>c\<^sub>e \<Sigma>\<^sub>c\<^sub>e' rule: iter.induct) simp_all

end


(* Title:   Compose.thy
   Author:  Akama Hitoshi
*)

section \<open>Composition of two SSTs\<close>

theory Compose
  imports Main Compose_SST_SST Convert_Monoid_SST
          "../Type/Compose_SST_SST_Type" "../Bounded_Copy/Bounded_Copy_SST_SST" "../Type/Compose_SST_SST_Type" "../Bounded_Copy/Bounded_Copy_Convert"
    "HOL-Library.Cardinality"
begin

(* This is type of the state of composed SST.
 * bc_shuffle means M_{x2, \<emptyset>} which is e2-bounded-copy.
 * e2 is type-level natural number
 *)
type_synonym ('e2, 'q1, 'q2, 'x1, 'x2) composed_state = "('q1 \<times> ('q2 \<times> 'x1 \<Rightarrow> 'q2)) \<times> ('q2 \<times> 'x1 \<Rightarrow> ('e2, 'x2) bc_shuffle)"

(* This is type of the variable of compose SST.
 * `e2 'option` is type level natural number means `e2 + 1`
 *)
type_synonym ('e2, 'q2, 'x1, 'x2) composed_var = "('q2 \<times> 'x1) \<times> ('x2 \<times> 'e2 option)"

abbreviation compose ::
  "'e2::enum boundedness
\<Rightarrow> ('q1::enum, 'x1::enum, 'a, 'b) SST
\<Rightarrow> ('q2::enum, 'x2::enum, 'b, 'c) SST
\<Rightarrow> (('e2, 'q1, 'q2, 'x1, 'x2) composed_state, ('e2, 'q2, 'x1, 'x2) composed_var, 'a, 'c) SST" where
  "compose B sst1 sst2 \<equiv> convert_MSST B (compose_SST_SST sst1 sst2)"

theorem SST_can_compose:
  assumes "boundedness B k"
  assumes "bounded_copy_SST k sst2"
  assumes "trim sst2" (* without loss of generality, we can assume sst2 is trim *)
  shows "SST.run (compose B sst1 sst2) w = Option.bind (SST.run sst1 w) (SST.run sst2)"
proof -
  let ?gm = "compose_\<gamma> sst1 sst2"
  let ?comp = "compose_SST_SST sst1 sst2"
  have "bctype k ?comp ?gm" by (simp add: compose_typable assms)
  then show ?thesis unfolding compose_def using assms
    by (simp add: MSST_can_convert can_compose_SST_SST)
qed

theorem composed_SST_bounded:
  fixes sst1 :: "('q1::enum, 'x1::enum, 'a, 'b) SST"
  fixes sst2 :: "('q2::enum, 'x2::enum, 'b, 'c) SST"
  fixes B1 :: "'e1::enum boundedness"
  fixes B2 :: "'e2::enum boundedness"
  assumes "boundedness B1 k"
  assumes "boundedness B2 l"
  assumes "bounded_copy_SST k sst1"
  assumes "bounded_copy_SST l sst2"
  assumes "trim sst2"
  shows "bounded_copy_SST (card (UNIV::'q2 set) * k * l) (compose B2 sst1 sst2)"
proof -
  let ?msst = "compose_SST_SST sst1 sst2"
  let ?gamma = "compose_\<gamma> sst1 sst2"
  let ?Bq2_k = "Boundedness :: ('q2 \<times> 'e1) boundedness"
  let ?q2_k = "card (UNIV::'q2 set) * k"
  have bound: "boundedness ?Bq2_k ?q2_k"
    using assms(1)
    unfolding boundedness_def by (simp add: card_UNIV_length_enum[symmetric] UNIV_Times_UNIV[symmetric] del: UNIV_Times_UNIV)
  have bc_msst: "bounded_copy_SST ?q2_k ?msst"
    by (simp add: compose_SST_SST_bounded assms(3))
  have bc_type: "bctype l ?msst ?gamma"
    by (simp add: compose_typable assms(4-5))
  show ?thesis
    by (rule convert_MSST_bounded[OF bc_msst bound assms(2) bc_type])
qed

theorem composed_SST_state:
  fixes sst1 :: "('q1::enum, 'x1::enum, 'a, 'b) SST"
  fixes sst2 :: "('q2::enum, 'x2::enum, 'b, 'c) SST"
  fixes B2 :: "'e2::enum boundedness"
  shows "CARD(('e2, 'q1, 'q2, 'x1, 'x2) composed_state)
      = CARD('q1) * CARD('q2) ^ (CARD('q2) * CARD('x1))
      * CARD(('e2, 'x2) bc_shuffle) ^ (CARD('q2) * CARD('x1))"
  by (simp del: UNIV_Times_UNIV add: finite_UNIV_card_ge_0 card_fun)

theorem composed_SST_var:
  fixes sst1 :: "('q1::enum, 'x1::enum, 'a, 'b) SST"
  fixes sst2 :: "('q2::enum, 'x2::enum, 'b, 'c) SST"
  fixes B2 :: "'e2::enum boundedness"
  shows "CARD(('e2, 'q2, 'x1, 'x2) composed_var)
      = CARD('q2) * CARD('x1) * CARD('x2) * (CARD('e2) + 1)"
  by (simp add: distrib_left)

subsection \<open>Examples\<close>

definition revrev where
  "revrev = compose_SST_SST rev rev"

definition revreset where
  "revreset = compose_SST_SST rev reset"

value "SST.run rev [1, 2, 3]"

definition rev :: "(Enum.finite_1, Enum.finite_1, Enum.finite_2, Enum.finite_2) SST" where
  "rev = (|
    initial = 0,
    delta = \<lambda>(q, a). 0,
    eta = \<lambda>(q, a) x. [Inr a, Inl 0],
    final = \<lambda>q. Some [Inl 0] |)"

definition revhoge :: "(Enum.finite_2, Enum.finite_2, Enum.finite_2, Enum.finite_2) SST" where
  "revhoge = (|
    initial = 0,
    delta = \<lambda>(q, a). a,
    eta = \<lambda>(q, a) x. (if x = 0 then [Inl 0, Inr a] else [Inr a, Inl 1]),
    final = \<lambda>q. (if q = 0 then Some [Inl 0] else Some [Inl 1]) |)"

definition
  "revrevhoge = compose_SST_SST rev revhoge"

definition
  "revhogebound = (Boundedness :: Enum.finite_1 boundedness)"

definition
  "revrevhogeconv = convert_MSST revhogebound revrevhoge"

end


theory CFGExit imports CFG begin

subsection {* Adds an exit node to the abstract CFG *}

locale CFGExit = CFG sourcenode targetnode kind valid_edge Entry
  for sourcenode :: "'edge \<Rightarrow> 'node" and targetnode :: "'edge \<Rightarrow> 'node"
  and kind :: "'edge \<Rightarrow> 'state edge_kind" and valid_edge :: "'edge \<Rightarrow> bool"
  and Entry :: "'node" ("'('_Entry'_')") +
  fixes Exit::"'node"  ("'('_Exit'_')")
  assumes Exit_source [dest]: "\<lbrakk>valid_edge a; sourcenode a = (_Exit_)\<rbrakk> \<Longrightarrow> False"
  and Entry_Exit_edge: "\<exists>a. valid_edge a \<and> sourcenode a = (_Entry_) \<and>
    targetnode a = (_Exit_) \<and> kind a = (\<lambda>s. False)\<^sub>\<surd>"

begin

lemma Entry_noteq_Exit [dest]:
  assumes eq:"(_Entry_) = (_Exit_)" shows "False"
proof -
  from Entry_Exit_edge obtain a where "sourcenode a = (_Entry_)"
    and "valid_edge a" by blast
  with eq show False by simp(erule Exit_source)
qed

lemma Exit_noteq_Entry [dest]:"(_Exit_) = (_Entry_) \<Longrightarrow> False"
  by(rule Entry_noteq_Exit[OF sym],simp)

lemma [simp]: "valid_node (_Exit_)"
proof -
  from Entry_Exit_edge obtain a where "targetnode a = (_Exit_)"
    and "valid_edge a" by blast
  thus ?thesis by(fastforce simp:valid_node_def)
qed

definition inner_node :: "'node \<Rightarrow> bool"
  where inner_node_def:
  "inner_node n \<equiv> valid_node n \<and> n \<noteq> (_Entry_) \<and> n \<noteq> (_Exit_)"

lemma inner_is_valid:
  "inner_node n \<Longrightarrow> valid_node n"
by(simp add:inner_node_def valid_node_def)

lemma [dest]:
  "inner_node (_Entry_) \<Longrightarrow> False"
by(simp add:inner_node_def)

lemma [dest]:
  "inner_node (_Exit_) \<Longrightarrow> False"
by(simp add:inner_node_def)

lemma [simp]:"\<lbrakk>valid_edge a; targetnode a \<noteq> (_Exit_)\<rbrakk>
  \<Longrightarrow> inner_node (targetnode a)"
  by(simp add:inner_node_def,rule ccontr,simp,erule Entry_target)

lemma [simp]:"\<lbrakk>valid_edge a; sourcenode a \<noteq> (_Entry_)\<rbrakk>
  \<Longrightarrow> inner_node (sourcenode a)"
  by(simp add:inner_node_def,rule ccontr,simp,erule Exit_source)

lemma valid_node_cases [consumes 1, case_names "Entry" "Exit" "inner"]:
  "\<lbrakk>valid_node n; n = (_Entry_) \<Longrightarrow> Q; n = (_Exit_) \<Longrightarrow> Q;
    inner_node n \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
apply(auto simp:valid_node_def)
 apply(case_tac "sourcenode a = (_Entry_)") apply auto
apply(case_tac "targetnode a = (_Exit_)") apply auto
done

lemma path_Exit_source [dest]:
  assumes "(_Exit_) -as\<rightarrow>* n'" shows "n' = (_Exit_)" and "as = []"
  using `(_Exit_) -as\<rightarrow>* n'`
proof(induct n\<equiv>"(_Exit_)" as n' rule:path.induct)
  case (Cons_path n'' as n' a)
  from `sourcenode a = (_Exit_)` `valid_edge a` have False
    by -(rule Exit_source,simp_all)
  { case 1 with `False` show ?case ..
  next
    case 2 with `False` show ?case ..
  }
qed simp_all

lemma Exit_no_sourcenode[dest]:
  assumes isin:"(_Exit_) \<in> set (sourcenodes as)" and path:"n -as\<rightarrow>* n'"
  shows False
proof -
  from isin obtain ns' ns'' where "sourcenodes as = ns'@(_Exit_)#ns''"
    by(auto dest:split_list simp:sourcenodes_def)
  then obtain as' as'' a where "as = as'@a#as''"
    and source:"sourcenode a = (_Exit_)"
    by(fastforce elim:map_append_append_maps simp:sourcenodes_def)
  with path have "valid_edge a" by(fastforce dest:path_split)
  with source show ?thesis by -(erule Exit_source)
qed

end

end


theory SmallStepCorrectness
imports SmallStepEvaluate "../01BigStep/BigStepEvaluate" "../../Utilities/Iterate"
begin

theorem completeness: "e \<Down> v \<Longrightarrow> [],[] \<turnstile> e : t \<Longrightarrow> iter (op \<leadsto>) e v"
  proof (induction e v rule: reduce.induct)
  case (red_app e\<^sub>1 t e\<^sub>1' e\<^sub>2 v)
    hence "iter (op \<leadsto>) (App (Abs t e\<^sub>1') e\<^sub>2) v" by argl (metis ev_app2 iter.iter_step)
    moreover from red_app have "iter (op \<leadsto>) (App e\<^sub>1 e\<^sub>2) (App (Abs t e\<^sub>1') e\<^sub>2)" by simp
    ultimately show ?case by auto
  next case (red_app_let e\<^sub>1 e\<^sub>1\<^sub>1 e\<^sub>1\<^sub>2 e\<^sub>2 v)
    hence "is_value e\<^sub>1\<^sub>2" by simp
    with red_app_let have "iter (op \<leadsto>) (App (Let e\<^sub>1\<^sub>1 e\<^sub>1\<^sub>2) e\<^sub>2) v" by argl (metis ev_app_let iter.iter_step)
    moreover from red_app_let have "iter (op \<leadsto>) (App e\<^sub>1 e\<^sub>2) (App (Let e\<^sub>1\<^sub>1 e\<^sub>1\<^sub>2) e\<^sub>2)" by simp
    ultimately show ?case by auto
  next case red_let_0
    thus ?case by simp
  next case red_let_S
    thus ?case by simp
  next case red_proj
    thus ?case by simp
  next case red_proj_let
    thus ?case by simp
  next case red_case
    thus ?case by simp
  next case red_case_let
    thus ?case by simp
  next case red_unfold
    thus ?case by simp
  next case red_unfold_let
    thus ?case by simp
  next case red_tyapp
    thus ?case by simp
  next case red_tyapp_let
    thus ?case by simp
  next case red_tylet
    thus ?case by simp
  qed simp_all

theorem soundness: "iter (op \<leadsto>) e v \<Longrightarrow> is_value v \<Longrightarrow> e \<Down> v"
  by simp

end


section \<open>Implementations of the Wp-Method\<close>

theory Wp_Method_Implementations
imports Intermediate_Frameworks Pair_Framework "../Distinguishability" Test_Suite_Representations "../OFSM_Tables_Refined" "HOL-Library.List_Lexorder"
begin

subsection \<open>Distinguishing Sets\<close>

fun add_distinguishing_set_or_state_identifier :: "nat \<Rightarrow> ('a :: linorder, 'b :: linorder, 'c :: linorder) fsm \<Rightarrow> (('b \<times> 'c) list \<times> 'a) \<times> ('b \<times> 'c) list \<times> 'a \<Rightarrow> ('b \<times> 'c) prefix_tree \<Rightarrow> ('b\<times>'c) prefix_tree" where
  "add_distinguishing_set_or_state_identifier k M ((io1,q1),(io2,q2)) t = (if length io1 = k \<or> length io2 = k
    then insert empty (get_distinguishing_sequence_from_ofsm_tables M q1 q2)
    else distinguishing_set M)"

lemma add_distinguishing_set_or_state_identifier_distinguishes :
  assumes "observable M"
  and     "minimal M"
  and     "\<alpha> \<in> L M"
  and     "\<beta> \<in> L M"
  and     "after_initial M \<alpha> \<noteq> after_initial M \<beta>"
shows "\<exists> io \<in> set (add_distinguishing_set_or_state_identifier k M ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t) \<union> (set (after t \<alpha>) \<inter> set (after t \<beta>)) . distinguishes M (after_initial M \<alpha>) (after_initial M \<beta>) io"
proof (cases "length \<alpha> = k \<or> length \<beta> = k")
  case False
  then show ?thesis
    using distinguishing_set_distinguishes[OF assms(1,2) after_is_state[OF assms(1,3)] after_is_state[OF assms(1,4)] assms(5)]
    by auto
next
  case True
  then have "set ((add_distinguishing_set_or_state_identifier k) M ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t) = set (insert empty (get_distinguishing_sequence_from_ofsm_tables M (after_initial M \<alpha>) (after_initial M \<beta>)))"
    by auto
  then have "get_distinguishing_sequence_from_ofsm_tables M (after_initial M \<alpha>) (after_initial M \<beta>) \<in> set ((add_distinguishing_set_or_state_identifier k) M ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t) \<union> (set (after t \<alpha>) \<inter> set (after t \<beta>))"
    unfolding insert_set by auto
  then show ?thesis
    by (meson after_is_state assms(1) assms(2) assms(3) assms(4) assms(5) get_distinguishing_sequence_from_ofsm_tables_distinguishes)
qed

lemma add_distinguishing_set_or_state_identifier_finite :
  "finite_tree ((add_distinguishing_set_or_state_identifier k) M ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t)"
proof (cases "length \<alpha> = k \<or> length \<beta> = k")
  case False
  then show ?thesis
    unfolding add_distinguishing_set.simps distinguishing_set.simps Let_def
    using from_list_finite_tree
    by simp
next
  case True
  then have "((add_distinguishing_set_or_state_identifier k) M ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t) = (insert empty (get_distinguishing_sequence_from_ofsm_tables M (after_initial M \<alpha>) (after_initial M \<beta>)))"
    by auto
  then show ?thesis
    using insert_finite_tree[OF empty_finite_tree] by metis
qed

fun distinguishing_set_or_state_identifier :: "nat \<Rightarrow> ('a :: linorder, 'b :: linorder, 'c :: linorder) fsm \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> ('b\<times>'c) prefix_tree" where
  "distinguishing_set_or_state_identifier l M k q = (if k = l
    then get_HSI M q
    else distinguishing_set M)"

lemma get_HSI_subset :
  assumes "observable M"
  and     "minimal M"
  and     "q \<in> states M"
shows "set (get_HSI M q) \<subseteq> set (distinguishing_set M)"
proof
  fix io assume "io \<in> set (get_HSI M q)"

  show "io \<in> set (distinguishing_set M)"
  proof (cases "io = []")
    case True
    then show ?thesis by auto
  next
    case False

    then obtain io' where *:"io@io' \<in> list.set (map (get_distinguishing_sequence_from_ofsm_tables M q) (filter ((\<noteq>) q) (states_as_list M)))"
      using \<open>io \<in> set (get_HSI M q)\<close>
      unfolding get_HSI.simps from_list_set
      by blast
    obtain q' where "q \<noteq> q'" and "q' \<in> states M" and "io@io' = get_distinguishing_sequence_from_ofsm_tables M q q'"
      using states_as_list_set[of M] filter_map_elem[OF *]
      by blast

    have "(q,q') \<in> list.set (filter (\<lambda> (x,y) . x \<noteq> y) (list_ordered_pairs (states_as_list M)))
            \<or> (q',q) \<in> list.set (filter (\<lambda> (x,y) . x \<noteq> y) (list_ordered_pairs (states_as_list M)))"
      using list_ordered_pairs_set_containment[of q "states_as_list M" q'] \<open>q \<in> states M\<close> \<open>q' \<in> states M\<close> \<open>q \<noteq> q'\<close>
      unfolding states_as_list_set
      by force
    moreover define pairs where pairs: "pairs = filter (\<lambda> (x,y) . x \<noteq> y) (list_ordered_pairs (states_as_list M))"
    ultimately have "(q,q') \<in> list.set pairs \<or> (q',q) \<in> list.set pairs"
      by auto
    then have "get_distinguishing_sequence_from_ofsm_tables M q q' \<in> list.set (map (case_prod (get_distinguishing_sequence_from_ofsm_tables M)) pairs)"
      using get_distinguishing_sequence_from_ofsm_tables_sym[OF assms \<open>q' \<in> states M\<close> \<open>q \<noteq> q'\<close>, symmetric]
      by (metis case_prod_conv map_set)
    then have "io@io' \<in> set (distinguishing_set M)"
      unfolding \<open>io@io' = get_distinguishing_sequence_from_ofsm_tables M q q'\<close> distinguishing_set.simps Let_def pairs
      using from_list_set_elem
      by blast
    then show ?thesis
      using set_prefix by metis
  qed
qed

lemma distinguishing_set_or_state_identifier_distinguishes :
  assumes "observable M"
  and     "minimal M"
  and     "q1 \<in> states M" and "q2 \<in> states M" and "q1 \<noteq> q2"
shows "\<exists> io . \<forall> k1 k2 . io \<in> set (distinguishing_set_or_state_identifier l M k1 q1) \<inter> set (distinguishing_set_or_state_identifier l M k2 q2) \<and> distinguishes M q1 q2 io"
  using get_HSI_distinguishes[OF assms]
  using distinguishing_set_distinguishes[OF assms]
  using get_HSI_subset[OF assms(1,2,3)]
  using get_HSI_subset[OF assms(1,2,4)]
  unfolding distinguishing_set_or_state_identifier.simps
  by auto

lemma distinguishing_set_or_state_identifier_finite :
  "finite_tree (distinguishing_set_or_state_identifier l M k q)"
  using get_HSI_finite[of M q]
  using distinguishing_set_finite[of M]
  unfolding distinguishing_set_or_state_identifier.simps
  by (cases "k = l"; force)

subsection \<open>Using the H-Framework\<close>

definition wp_method_via_h_framework :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> ('b\<times>'c) prefix_tree" where
  "wp_method_via_h_framework M m = h_framework_static_with_empty_graph M (distinguishing_set_or_state_identifier (Suc (m - size_r M)) M) m"

definition wp_method_via_h_framework_lists :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> (('b\<times>'c) \<times> bool) list list" where
  "wp_method_via_h_framework_lists M m = sorted_list_of_maximal_sequences_in_tree (test_suite_from_io_tree M (initial M) (wp_method_via_h_framework M m))"

lemma wp_method_via_h_framework_completeness_and_finiteness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('e,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> ((L M1 \<inter> set (wp_method_via_h_framework M1 m)) = (L M2 \<inter> set (wp_method_via_h_framework M1 m)))"
and "finite_tree (wp_method_via_h_framework M1 m)"
  using h_framework_static_with_empty_graph_completeness_and_finiteness[OF assms, where dist_fun="distinguishing_set_or_state_identifier (Suc (m - size_r M1)) M1"]
  using distinguishing_set_or_state_identifier_distinguishes[OF assms(1,3)]
  using distinguishing_set_or_state_identifier_finite
  unfolding wp_method_via_h_framework_def
  by blast+

lemma wp_method_via_h_framework_lists_completeness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('d,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> list_all (passes_test_case M2 (initial M2)) (wp_method_via_h_framework_lists M1 m)"
  using h_framework_static_with_empty_graph_lists_completeness[OF assms, where dist_fun="distinguishing_set_or_state_identifier (Suc (m - size_r M1)) M1", OF _ distinguishing_set_or_state_identifier_finite]
  using distinguishing_set_or_state_identifier_distinguishes[OF assms(1,3)]
  unfolding wp_method_via_h_framework_lists_def h_framework_static_with_empty_graph_lists_def wp_method_via_h_framework_def
  by blast

subsection \<open>Using the SPY-Framework\<close>

definition wp_method_via_spy_framework :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> ('b\<times>'c) prefix_tree" where
  "wp_method_via_spy_framework M m = spy_framework_static_with_empty_graph M (distinguishing_set_or_state_identifier (Suc (m - size_r M)) M) m"

lemma wp_method_via_spy_framework_completeness_and_finiteness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('d,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> ((L M1 \<inter> set (wp_method_via_spy_framework M1 m)) = (L M2 \<inter> set (wp_method_via_spy_framework M1 m)))"
and "finite_tree (wp_method_via_spy_framework M1 m)"
  unfolding wp_method_via_spy_framework_def
  using spy_framework_static_with_empty_graph_completeness_and_finiteness[OF assms, of "distinguishing_set_or_state_identifier (Suc (m - size_r M1)) M1"]
  using distinguishing_set_or_state_identifier_distinguishes[OF assms(1,3)]
  using distinguishing_set_or_state_identifier_finite
  by metis+

definition wp_method_via_spy_framework_lists :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> (('b\<times>'c) \<times> bool) list list" where
  "wp_method_via_spy_framework_lists M m = sorted_list_of_maximal_sequences_in_tree (test_suite_from_io_tree M (initial M) (wp_method_via_spy_framework M m))"

lemma wp_method_via_spy_framework_lists_completeness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('d,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> list_all (passes_test_case M2 (initial M2)) (wp_method_via_spy_framework_lists M1 m)"
  unfolding wp_method_via_spy_framework_lists_def
            wp_method_via_spy_framework_completeness_and_finiteness(1)[OF assms]
            passes_test_cases_from_io_tree[OF assms(1,2) fsm_initial fsm_initial wp_method_via_spy_framework_completeness_and_finiteness(2)[OF assms]]
  by blast

subsection \<open>Code Generation\<close>

lemma wp_method_via_spy_framework_code[code] :
  "wp_method_via_spy_framework M m = (let
      tables = (compute_ofsm_tables M (size M - 1));
      distMap = mapping_of (map (\<lambda> (q1,q2) . ((q1,q2), get_distinguishing_sequence_from_ofsm_tables_with_provided_tables tables M q1 q2))
                        (filter (\<lambda> qq . fst qq \<noteq> snd qq) (List.product (states_as_list M) (states_as_list M))));
      distHelper = (\<lambda> q1 q2 . if q1 \<in> states M \<and> q2 \<in> states M \<and> q1 \<noteq> q2 then the (Mapping.lookup distMap (q1,q2)) else get_distinguishing_sequence_from_ofsm_tables M q1 q2);
      pairs = filter (\<lambda> (x,y) . x \<noteq> y) (list_ordered_pairs (states_as_list M));
      distSet = from_list (map (case_prod distHelper) pairs);
      hsiMap = mapping_of (map (\<lambda> q . (q,from_list (map (\<lambda>q' . distHelper q q') (filter ((\<noteq>) q) (states_as_list M))))) (states_as_list M));
      l = (Suc (m - size_r M));
      distFun = (\<lambda> k q . if k = l
                      then (if q \<in> states M then the (Mapping.lookup hsiMap q) else get_HSI M q)
                      else distSet)
    in spy_framework_static_with_empty_graph M distFun m)"
(is "?f1 = ?f2")
proof -
  define hsiMap' where "hsiMap' = mapping_of (map (\<lambda> q . (q,from_list (map (\<lambda>q' . get_distinguishing_sequence_from_ofsm_tables M q q') (filter ((\<noteq>) q) (states_as_list M))))) (states_as_list M))"
  define distFun' where "distFun' = (\<lambda> k q . if k = (Suc (m - size_r M))
                      then (if q \<in> states M then the (Mapping.lookup hsiMap' q) else get_HSI M q)
                      else distinguishing_set M)"
  have *: "?f2 = spy_framework_static_with_empty_graph M distFun' m"
    unfolding distFun'_def hsiMap'_def distinguishing_set.simps Let_def
    apply (subst (3 4 ) get_distinguishing_sequence_from_ofsm_tables_precomputed[of M])
    unfolding Let_def
    by presburger

  define hsiMap where "hsiMap = map_of (map (\<lambda> q . (q,from_list (map (\<lambda>q' . get_distinguishing_sequence_from_ofsm_tables M q q') (filter ((\<noteq>) q) (states_as_list M))))) (states_as_list M))"
  define distFun where "distFun = (\<lambda> k q . if k = (Suc (m - size_r M))
                      then (if q \<in> states M then the (hsiMap q) else get_HSI M q)
                      else distinguishing_set M)"

  have "distinct (map fst (map (\<lambda> q . (q,from_list (map (\<lambda>q' . get_distinguishing_sequence_from_ofsm_tables M q q') (filter ((\<noteq>) q) (states_as_list M))))) (states_as_list M)))"
    using states_as_list_distinct
    by (metis map_pair_fst)
  then have "Mapping.lookup hsiMap' = hsiMap"
    unfolding hsiMap_def hsiMap'_def
    using mapping_of_map_of
    by blast
  then have "distFun' = distFun"
    unfolding distFun_def distFun'_def by meson

  have **:"distFun' = (distinguishing_set_or_state_identifier (Suc (m - size_r M)) M)"
  proof
    fix k show "distFun' k = (distinguishing_set_or_state_identifier (Suc (m - size_r M)) M) k"
    proof (cases "k = (Suc (m - size_r M))")
      case False
      then show ?thesis
        unfolding distFun_def distinguishing_set_or_state_identifier.simps \<open>distFun' = distFun\<close> by auto
    next
      case True
      then have "distFun k = (\<lambda> q . (if q \<in> states M then the (hsiMap q) else get_HSI M q))"
            and "(distinguishing_set_or_state_identifier (Suc (m - size_r M)) M) k = (\<lambda> q . get_HSI M q)"
        unfolding distFun_def distinguishing_set_or_state_identifier.simps by auto
      moreover have "(\<lambda> q . (if q \<in> states M then the (hsiMap q) else get_HSI M q)) = (\<lambda> q . get_HSI M q)"
      proof
        fix q show "(if q \<in> states M then the (hsiMap q) else get_HSI M q) = get_HSI M q"
        proof (cases "q \<in> states M")
          case True
          then have "q \<in> list.set (states_as_list M)"
            using states_as_list_set by blast
          then show ?thesis
            unfolding distFun_def hsiMap_def map_of_map_pair_entry get_HSI.simps
            using True
            by fastforce
        next
          case False
          then show ?thesis using distFun_def by auto
        qed
      qed
      ultimately show ?thesis unfolding \<open>distFun' = distFun\<close> by simp
    qed
  qed

  show ?thesis
    unfolding * ** wp_method_via_spy_framework_def by simp
qed

lemma wp_method_via_h_framework_code[code] :
  "wp_method_via_h_framework M m = (let
      tables = (compute_ofsm_tables M (size M - 1));
      distMap = mapping_of (map (\<lambda> (q1,q2) . ((q1,q2), get_distinguishing_sequence_from_ofsm_tables_with_provided_tables tables M q1 q2))
                        (filter (\<lambda> qq . fst qq \<noteq> snd qq) (List.product (states_as_list M) (states_as_list M))));
      distHelper = (\<lambda> q1 q2 . if q1 \<in> states M \<and> q2 \<in> states M \<and> q1 \<noteq> q2 then the (Mapping.lookup distMap (q1,q2)) else get_distinguishing_sequence_from_ofsm_tables M q1 q2);
      pairs = filter (\<lambda> (x,y) . x \<noteq> y) (list_ordered_pairs (states_as_list M));
      distSet = from_list (map (case_prod distHelper) pairs);
      hsiMap = mapping_of (map (\<lambda> q . (q,from_list (map (\<lambda>q' . distHelper q q') (filter ((\<noteq>) q) (states_as_list M))))) (states_as_list M));
      l = (Suc (m - size_r M));
      distFun = (\<lambda> k q . if k = l
                      then (if q \<in> states M then the (Mapping.lookup hsiMap q) else get_HSI M q)
                      else distSet)
    in h_framework_static_with_empty_graph M distFun m)"
(is "?f1 = ?f2")
proof -
  define hsiMap' where "hsiMap' = mapping_of (map (\<lambda> q . (q,from_list (map (\<lambda>q' . get_distinguishing_sequence_from_ofsm_tables M q q') (filter ((\<noteq>) q) (states_as_list M))))) (states_as_list M))"
  define distFun' where "distFun' = (\<lambda> k q . if k = (Suc (m - size_r M))
                      then (if q \<in> states M then the (Mapping.lookup hsiMap' q) else get_HSI M q)
                      else distinguishing_set M)"
  have *: "?f2 = h_framework_static_with_empty_graph M distFun' m"
    unfolding distFun'_def hsiMap'_def distinguishing_set.simps Let_def
    apply (subst (3 4 ) get_distinguishing_sequence_from_ofsm_tables_precomputed[of M])
    unfolding Let_def
    by presburger

  define hsiMap where "hsiMap = map_of (map (\<lambda> q . (q,from_list (map (\<lambda>q' . get_distinguishing_sequence_from_ofsm_tables M q q') (filter ((\<noteq>) q) (states_as_list M))))) (states_as_list M))"
  define distFun where "distFun = (\<lambda> k q . if k = (Suc (m - size_r M))
                      then (if q \<in> states M then the (hsiMap q) else get_HSI M q)
                      else distinguishing_set M)"

  have "distinct (map fst (map (\<lambda> q . (q,from_list (map (\<lambda>q' . get_distinguishing_sequence_from_ofsm_tables M q q') (filter ((\<noteq>) q) (states_as_list M))))) (states_as_list M)))"
    using states_as_list_distinct
    by (metis map_pair_fst)
  then have "Mapping.lookup hsiMap' = hsiMap"
    unfolding hsiMap_def hsiMap'_def
    using mapping_of_map_of
    by blast
  then have "distFun' = distFun"
    unfolding distFun_def distFun'_def by meson

  have **:"distFun' = (distinguishing_set_or_state_identifier (Suc (m - size_r M)) M)"
  proof
    fix k show "distFun' k = (distinguishing_set_or_state_identifier (Suc (m - size_r M)) M) k"
    proof (cases "k = (Suc (m - size_r M))")
      case False
      then show ?thesis
        unfolding distFun_def distinguishing_set_or_state_identifier.simps \<open>distFun' = distFun\<close> by auto
    next
      case True
      then have "distFun k = (\<lambda> q . (if q \<in> states M then the (hsiMap q) else get_HSI M q))"
            and "(distinguishing_set_or_state_identifier (Suc (m - size_r M)) M) k = (\<lambda> q . get_HSI M q)"
        unfolding distFun_def distinguishing_set_or_state_identifier.simps by auto
      moreover have "(\<lambda> q . (if q \<in> states M then the (hsiMap q) else get_HSI M q)) = (\<lambda> q . get_HSI M q)"
      proof
        fix q show "(if q \<in> states M then the (hsiMap q) else get_HSI M q) = get_HSI M q"
        proof (cases "q \<in> states M")
          case True
          then have "q \<in> list.set (states_as_list M)"
            using states_as_list_set by blast
          then show ?thesis
            unfolding distFun_def hsiMap_def map_of_map_pair_entry get_HSI.simps
            using True
            by fastforce
        next
          case False
          then show ?thesis using distFun_def by auto
        qed
      qed
      ultimately show ?thesis unfolding \<open>distFun' = distFun\<close> by simp
    qed
  qed

  show ?thesis
    unfolding * ** wp_method_via_h_framework_def by simp
qed

end


section \<open>Constructing Paths and Runs in Transition Systems\<close>

theory Transition_System_Construction
imports
  "../Basic/Sequence_LTL"
  "Transition_System"
begin

  context transition_system
  begin

    lemma invariant_run:
      assumes "P p" "\<And> p. P p \<Longrightarrow> \<exists> a. enabled a p \<and> P (execute a p) \<and> Q p a"
      obtains r
      where "run r p" "pred_stream P (p ## trace r p)" "stream_all2 Q (p ## trace r p) r"
    proof -
      obtain f where 1: "P p" "\<And> p. P p \<Longrightarrow> enabled (f p) p \<and> P (execute (f p) p) \<and> Q p (f p)"
        using assms by metis
      note 2 = that[of "smap f (siterate (\<lambda> p. execute (f p) p) p)"]
      show ?thesis using 1 by (intro 2; coinduction arbitrary: p) (auto)
    qed

    lemma invariant_run_index:
      assumes "P n p" "\<And> n p. P n p \<Longrightarrow> \<exists> a. enabled a p \<and> P (Suc n) (execute a p) \<and> Q n p a"
      obtains r
      where
        "run r p"
        "\<And> i. P (n + i) (target (stake i r) p)"
        "\<And> i. Q (n + i) (target (stake i r) p) (r !! i)"
    proof -
      define s where "s \<equiv> (n, p)"
      have 1: "case_prod P s" using assms(1) unfolding s_def by auto
      obtain f where 2:
        "\<And> n p. P n p \<Longrightarrow> enabled (f n p) p"
        "\<And> n p. P n p \<Longrightarrow> P (Suc n) (execute (f n p) p)"
        "\<And> n p. P n p \<Longrightarrow> Q n p (f n p)"
        using assms(2) by metis
      define g where "g \<equiv> \<lambda> (n, p). (Suc n, execute (f n p) p)"

      let ?r = "smap (case_prod f) (siterate g s)"

      have 3: "run ?r (snd s)" using 1 2(1, 2) unfolding g_def by (coinduction arbitrary: s) (auto)
      have 4: "case_prod P (compow k g s)" for k using 1 2(2) unfolding g_def by (induct k) (auto)
      have 5: "case_prod Q (compow k g s) (?r !! k)" for k using 2(3) 4 by (simp add: case_prod_beta)

      have 6: "compow k g (n, p) = (n + k, target (stake k ?r) p)" for k
        unfolding s_def g_def by (induct k) (auto simp add: stake_Suc simp del: stake.simps(2))

      show ?thesis using that 3 4 5 unfolding s_def 6 by simp
    qed

    lemma recurring_condition:
      assumes "P p" "\<And> p. P p \<Longrightarrow> \<exists> r. r \<noteq> [] \<and> path r p \<and> P (target r p)"
      obtains r
      where "run r p" "infs P (p ## trace r p)"
    proof -
      obtain f where 1:
        "P p"
        "\<And> p. P p \<Longrightarrow> f p \<noteq> []"
        "\<And> p. P p \<Longrightarrow> path (f p) p"
        "\<And> p. P p \<Longrightarrow> P (target (f p) p)"
        using assms by metis
      define g where "g p \<equiv> target (f p) p" for p
      define h where "h p \<equiv> states (f p) p" for p

      have 2: "P (g p)" if "P p" for p using 1(4) that unfolding g_def by simp
      have 3: "h p \<noteq> []" if "P p" for p using 1(2) that unfolding h_def by simp

      let ?r = "\<lambda> p. flat (smap f (siterate g p))"
      let ?t = "\<lambda> p. flat (smap h (siterate g p))"

      have 4: "?t p = h p @- ?t (g p)" if "P p" for p
        using 1(2) that by (simp add: flat_unfold g_def h_def)
      have 5: "trace (?r p) p = h p @- trace (?r (g p)) (g p)" if "P p" for p
        using 1(2) that by (simp add: flat_unfold g_def h_def)
      have 6: "?t p = trace (?r p) p"
        using 1(1) 2 3 4 5 by (coinduction arbitrary: p rule: stream_eq_coinduct_shift) (blast)

      have 7: "run (?r p) p"
        using 1 unfolding g_def by (coinduction arbitrary: p rule: run_flat_coinduct) (auto)

      have 8: "g p = last (h p)" if "P p" for p by (metis 3 that g_def h_def last.simps scan_last)
      have 9: "Bex (set (h p)) P" if "P p" for p using 2 3 8 that by force
      have 10: "infs P (?t p)"
        using 1 9 unfolding g_def by (coinduction arbitrary: p rule: infs_flat_coinduct) (auto)
      have 11: "infs P (p ## ?t p)" using 10 by simp

      show ?thesis using that 7 11 unfolding 6 by this
    qed

    lemma koenig:
      assumes "infinite (reachable p)"
      assumes "\<And> q. q \<in> reachable p \<Longrightarrow> finite (successors q)"
      obtains r
      where "run r p"
    proof (rule invariant_run[where ?P = "\<lambda> q. q \<in> reachable p \<and> infinite (reachable q)"])
      show "p \<in> reachable p \<and> infinite (reachable p)" using assms(1) by auto
    next
      fix q
      assume 1: "q \<in> reachable p \<and> infinite (reachable q)"
      have 2: "finite (successors q)" using assms(2) 1 by auto
      have 3: "infinite (insert q (\<Union>(reachable ` (successors q))))" using reachable_step 1 by metis
      obtain s where 4: "s \<in> successors q" "infinite (reachable s)" using 2 3 by auto
      show "\<exists> a. enabled a q \<and> (execute a q \<in> reachable p \<and> infinite (reachable (execute a q))) \<and> True"
        using 1 4 by auto
    qed

  end

end


(*  Title:      HOL/Typedef.thy
    Author:     Markus Wenzel, TU Munich
*)

section {* HOL type definitions *}

theory Typedef
imports Set
keywords "typedef" :: thy_goal and "morphisms"
begin

locale type_definition =
  fixes Rep and Abs and A
  assumes Rep: "Rep x \<in> A"
    and Rep_inverse: "Abs (Rep x) = x"
    and Abs_inverse: "y \<in> A ==> Rep (Abs y) = y"
  -- {* This will be axiomatized for each typedef! *}
begin

lemma Rep_inject:
  "(Rep x = Rep y) = (x = y)"
proof
  assume "Rep x = Rep y"
  then have "Abs (Rep x) = Abs (Rep y)" by (simp only:)
  moreover have "Abs (Rep x) = x" by (rule Rep_inverse)
  moreover have "Abs (Rep y) = y" by (rule Rep_inverse)
  ultimately show "x = y" by simp
next
  assume "x = y"
  thus "Rep x = Rep y" by (simp only:)
qed

lemma Abs_inject:
  assumes x: "x \<in> A" and y: "y \<in> A"
  shows "(Abs x = Abs y) = (x = y)"
proof
  assume "Abs x = Abs y"
  then have "Rep (Abs x) = Rep (Abs y)" by (simp only:)
  moreover from x have "Rep (Abs x) = x" by (rule Abs_inverse)
  moreover from y have "Rep (Abs y) = y" by (rule Abs_inverse)
  ultimately show "x = y" by simp
next
  assume "x = y"
  thus "Abs x = Abs y" by (simp only:)
qed

lemma Rep_cases [cases set]:
  assumes y: "y \<in> A"
    and hyp: "!!x. y = Rep x ==> P"
  shows P
proof (rule hyp)
  from y have "Rep (Abs y) = y" by (rule Abs_inverse)
  thus "y = Rep (Abs y)" ..
qed

lemma Abs_cases [cases type]:
  assumes r: "!!y. x = Abs y ==> y \<in> A ==> P"
  shows P
proof (rule r)
  have "Abs (Rep x) = x" by (rule Rep_inverse)
  thus "x = Abs (Rep x)" ..
  show "Rep x \<in> A" by (rule Rep)
qed

lemma Rep_induct [induct set]:
  assumes y: "y \<in> A"
    and hyp: "!!x. P (Rep x)"
  shows "P y"
proof -
  have "P (Rep (Abs y))" by (rule hyp)
  moreover from y have "Rep (Abs y) = y" by (rule Abs_inverse)
  ultimately show "P y" by simp
qed

lemma Abs_induct [induct type]:
  assumes r: "!!y. y \<in> A ==> P (Abs y)"
  shows "P x"
proof -
  have "Rep x \<in> A" by (rule Rep)
  then have "P (Abs (Rep x))" by (rule r)
  moreover have "Abs (Rep x) = x" by (rule Rep_inverse)
  ultimately show "P x" by simp
qed

lemma Rep_range: "range Rep = A"
proof
  show "range Rep <= A" using Rep by (auto simp add: image_def)
  show "A <= range Rep"
  proof
    fix x assume "x : A"
    hence "x = Rep (Abs x)" by (rule Abs_inverse [symmetric])
    thus "x : range Rep" by (rule range_eqI)
  qed
qed

lemma Abs_image: "Abs ` A = UNIV"
proof
  show "Abs ` A <= UNIV" by (rule subset_UNIV)
next
  show "UNIV <= Abs ` A"
  proof
    fix x
    have "x = Abs (Rep x)" by (rule Rep_inverse [symmetric])
    moreover have "Rep x : A" by (rule Rep)
    ultimately show "x : Abs ` A" by (rule image_eqI)
  qed
qed

end

ML_file "Tools/typedef.ML"

end


section \<open> Linking Reactive Relations \<close>

theory utp_rea_links
  imports "utp_rea_prog"
begin

subsection \<open> Observation Lenses \<close>

text \<open> The following lens describes the variables of the state space that are relevant for a
  reactive relation. Usually, these are @{const tr}, @{const st}, and other semantic variables
  under @{term "\<Sigma>\<^sub>S"}" The goal is to use this lens to abstract an @{const RR} equivalent
  heterogeneous relation. The parameter @{term X} is used to represent the variables used to
  encode additional semantic information use as refusals. \<close>

definition rea_obs ::
  "('r \<Longrightarrow> ('s, 't::trace, '\<alpha>) rsp)
   \<Rightarrow> ('s \<times> 'r) \<times> ('s \<times> 't \<times> 'r) \<Longrightarrow> ('s, 't, '\<alpha>) rsp \<times> ('s, 't, '\<alpha>) rsp" where
[lens_defs]: "rea_obs X = {$st, $X}\<^sub>\<alpha> +\<^sub>L {$st\<acute>, $tr\<acute>, $X\<acute>}\<^sub>\<alpha>"

text \<open> The next constant describes the variables that are unrestricted in a reactive relation,
  typically @{const ok} and @{const wait}. \<close>

definition rea_frees ::
  "(bool \<times> bool \<times> 't::trace) \<times> (bool \<times> bool) \<Longrightarrow> ('t, '\<alpha>) rp \<times> ('t, '\<alpha>) rp" where
[lens_defs]: "rea_frees = {$ok, $wait, $tr}\<^sub>\<alpha> +\<^sub>L {$ok\<acute>, $wait\<acute>}\<^sub>\<alpha>"

text \<open> We can show that both @{const rea_obs} and @{const rea_frees} are very well-behaved lenses. \<close>

lemma rea_obs_vwb [simp]:
  "\<lbrakk> vwb_lens X; st \<bowtie> X ; tr \<bowtie> X \<rbrakk> \<Longrightarrow> vwb_lens (rea_obs X)"
  by (simp add: rea_obs_def)

lemma rea_frees_vwb [simp]: "vwb_lens rea_frees"
  by (simp add: rea_frees_def)

lemma rea_obs_unrests [simp]:
  assumes "tr \<bowtie> X"
  shows "($tr)\<^sub>v \<bowtie> rea_obs X" "rea_obs X \<bowtie> ($tr)\<^sub>v"
  using assms by (simp_all add: rea_obs_def lens_indep_sym)

lemma rea_obs_cong:
  assumes "vwb_lens X" "st \<bowtie> X" "tr \<bowtie> X" "X \<approx>\<^sub>L Y"
  shows "rea_obs X \<approx>\<^sub>L rea_obs Y"
unfolding rea_obs_def proof (rule lens_plus_cong, simp_all add: assms)
  show "($st)\<^sub>v +\<^sub>L ($X)\<^sub>v \<approx>\<^sub>L ($st)\<^sub>v +\<^sub>L ($Y)\<^sub>v"
    by (rule lens_plus_cong, simp_all add: assms lens_equiv_refl in_var_def lens_comp_cong_1)
  show "($st\<acute>)\<^sub>v +\<^sub>L ($tr\<acute>)\<^sub>v +\<^sub>L ($X\<acute>)\<^sub>v \<approx>\<^sub>L ($st\<acute>)\<^sub>v +\<^sub>L ($tr\<acute>)\<^sub>v +\<^sub>L ($Y\<acute>)\<^sub>v"
    by (rule lens_plus_cong, simp_all add: assms out_var_def lens_equiv_refl lens_comp_cong_1 lens_plus_eq_right)
qed

lemma rea_obs_unrest_indep_all [simp]: "rea_obs \<Sigma>\<^sub>S \<bowtie> rea_frees"
  by (simp add: rea_obs_def rea_frees_def)

text \<open> The reactive observation variables and unrestricted variables are independent of each other. \<close>

lemma rea_obs_unrest_indep:
  assumes "X \<approx>\<^sub>L \<Sigma>\<^sub>S"
  shows "rea_obs X \<bowtie> rea_frees"
proof -
  from assms have "vwb_lens X"
    by (metis lens_equiv_def rsp_vars.more\<^sub>L_vwb_lens sublens_pres_vwb)
  moreover have "st \<bowtie> X" "tr \<bowtie> X"
    by (metis assms lens_equiv_def rp_vars.indeps rsp_vars.indeps sublens_pres_indep')+
  ultimately have "rea_obs X \<approx>\<^sub>L rea_obs \<Sigma>\<^sub>S"
    by (metis assms rea_obs_cong)
  thus ?thesis
    by (metis lens_equiv_def rea_obs_unrest_indep_all sublens_pres_indep)
qed

lemma rea_obs_plus_unrest_vwb [simp]:
  "vwb_lens (rea_obs \<Sigma>\<^sub>S +\<^sub>L rea_frees)"
  by (rule plus_vwb_lens, simp_all)

text \<open> The summation of the observation variables and unrestricted variables is bijective,
  meaning their combination covers the entire state space. \<close>

lemma rea_obs_plus_unrest_bij [simp]:
  "bij_lens (rea_obs \<Sigma>\<^sub>S +\<^sub>L rea_frees)"
  by (rule bij_lens.intro, auto simp add: bij_lens_axioms_def, simp add: lens_defs)

subsection \<open> Abstracting Reactive Relations \<close>

text \<open> We define a function that converts a reactive relation into a heterogeneous relation of
  type @{typ "('s \<times> '\<beta>, 's \<times> 't \<times> '\<beta>) urel"}, where @{typ 's} is the state space, @{typ "'t"}
  is the trace type and @{typ "'\<beta>"} is additional semantic information. This is the minimal
  representation of a healthy reactive relation. \<close>

definition rea_to_urel ::
  "('\<beta> \<Longrightarrow> ('s, 't::trace, '\<alpha>) rsp) \<Rightarrow> ('s, 't, '\<alpha>) hrel_rsp \<Rightarrow> ('s \<times> '\<beta>, 's \<times> 't \<times> '\<beta>) urel" where
"rea_to_urel X P = P\<lbrakk>0/$tr\<rbrakk> \<restriction>\<^sub>e (rea_obs X)" \<comment> \<open> We substitute the empty trace for @{term "$tr"},
                                                and then restrict the alphabet to be only those
                                                variables in @{term "rea_obs X"}. \<close>

text \<open> We also define a function that translates in the opposite direction. \<close>

definition urel_to_rea ::
  "('\<beta> \<Longrightarrow> ('s, 't::trace, '\<alpha>) rsp) \<Rightarrow> ('s \<times> '\<beta>, 's \<times> 't \<times> '\<beta>) urel \<Rightarrow> ('s, 't, '\<alpha>) hrel_rsp" where
[upred_defs]: "urel_to_rea X P = R2(P \<oplus>\<^sub>p rea_obs X)"

text \<open> The latter function always constructs a healthy reactive relation. \<close>

lemma urel_to_rea_is_RR [closure]:
  assumes "X \<approx>\<^sub>L \<Sigma>\<^sub>S"
  shows "urel_to_rea X P is RR"
proof -
  have "X \<bowtie> ok" "X \<bowtie> wait" "X \<bowtie> st" "X \<bowtie> tr"
    using assms des_vars.indeps(2) lens_equiv_pres_indep rp_vars.indeps(2,6,4,11) rsp_vars.indeps(2,6) by blast+
  thus ?thesis
    by (rule_tac RR_intro, simp_all add: urel_to_rea_def R2_def rea_obs_def unrest, rel_auto+)
qed

text \<open> Moreover, we can always invert the second function. \<close>

lemma urel_to_rea_inverse:
  assumes "X \<approx>\<^sub>L \<Sigma>\<^sub>S"
  shows "rea_to_urel X (urel_to_rea X P) = P"
proof -
  have indeps: "X \<bowtie> ok" "X \<bowtie> wait" "X \<bowtie> st" "X \<bowtie> tr"
    using assms des_vars.indeps(2) lens_equiv_pres_indep rp_vars.indeps(2,6,4,11) rsp_vars.indeps(2,6) by blast+
  hence indeps': "st \<bowtie> X" "tr \<bowtie> X"
    by (metis lens_indep_sym)+
  have "vwb_lens X"
    using assms lens_equiv_def rsp_vars.more\<^sub>L_vwb_lens sublens_pres_vwb by blast
  thus ?thesis
    by (simp add: rea_to_urel_def urel_to_rea_def usubst alpha unrest R2_def R1_def R2s_def prod_mwb_lens indeps indeps', rel_auto)
qed

text \<open> We can invert the first function provided that we apply it to a healthy reactive relation. \<close>

lemma rea_to_urel_inverse:
  assumes "X \<approx>\<^sub>L \<Sigma>\<^sub>S" "P is RR"
  shows "urel_to_rea X (rea_to_urel X P) = P"
proof -
  have indeps: "X \<bowtie> ok" "X \<bowtie> wait" "X \<bowtie> st" "X \<bowtie> tr"
    using assms des_vars.indeps(2) lens_equiv_pres_indep rp_vars.indeps(2,6,4,11) rsp_vars.indeps(2,6) by blast+
  hence indeps': "st \<bowtie> X" "tr \<bowtie> X"
    by (metis lens_indep_sym)+
  have vwb_X: "vwb_lens X"
    using assms lens_equiv_def rsp_vars.more\<^sub>L_vwb_lens sublens_pres_vwb by blast
  hence "urel_to_rea X (rea_to_urel X (RR P)) = RR P"
    apply (simp add: rea_to_urel_def urel_to_rea_def usubst alpha unrest R2_def R1_def R2s_def prod_mwb_lens indeps indeps')
    apply (subst aext_arestr[of _ rea_frees])
    apply (simp_all add: assms indeps' rea_obs_unrest_indep)
    apply (metis (no_types, hide_lams) vwb_X assms(1) bij_lens_cong indeps'(1) indeps'(2) lens_plus_eq_left rea_obs_cong rea_obs_plus_unrest_bij rea_obs_unrest_indep)
     apply (rel_simp')
    apply (rel_simp')
    done
  thus ?thesis
    by (metis Healthy_if assms(2))
qed

end