(*  Title:      HOL/Proofs/Lambda/WeakNorm.thy
    Author:     Stefan Berghofer
    Copyright   2003 TU Muenchen
*)

section \<open>Weak normalization for simply-typed lambda calculus\<close>

theory WeakNorm
imports LambdaType NormalForm "HOL-Library.Realizers" "HOL-Library.Code_Target_Int"
begin

text \<open>
Formalization by Stefan Berghofer. Partly based on a paper proof by
Felix Joachimski and Ralph Matthes \<^cite>\<open>"Matthes-Joachimski-AML"\<close>.
\<close>

subsection \<open>Main theorems\<close>

lemma norm_list:
  assumes f_compat: "\<And>t t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<Longrightarrow> f t \<rightarrow>\<^sub>\<beta>\<^sup>* f t'"
  and f_NF: "\<And>t. NF t \<Longrightarrow> NF (f t)"
  and uNF: "NF u" and uT: "e \<turnstile> u : T"
  shows "\<And>Us. e\<langle>i:T\<rangle> \<tturnstile> as : Us \<Longrightarrow>
    listall (\<lambda>t. \<forall>e T' u i. e\<langle>i:T\<rangle> \<turnstile> t : T' \<longrightarrow>
      NF u \<longrightarrow> e \<turnstile> u : T \<longrightarrow> (\<exists>t'. t[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t')) as \<Longrightarrow>
    \<exists>as'. \<forall>j. Var j \<degree>\<degree> map (\<lambda>t. f (t[u/i])) as \<rightarrow>\<^sub>\<beta>\<^sup>*
      Var j \<degree>\<degree> map f as' \<and> NF (Var j \<degree>\<degree> map f as')"
  (is "\<And>Us. _ \<Longrightarrow> listall ?R as \<Longrightarrow> \<exists>as'. ?ex Us as as'")
proof (induct as rule: rev_induct)
  case (Nil Us)
  with Var_NF have "?ex Us [] []" by simp
  thus ?case ..
next
  case (snoc b bs Us)
  have "e\<langle>i:T\<rangle> \<tturnstile> bs  @ [b] : Us" by fact
  then obtain Vs W where Us: "Us = Vs @ [W]"
    and bs: "e\<langle>i:T\<rangle> \<tturnstile> bs : Vs" and bT: "e\<langle>i:T\<rangle> \<turnstile> b : W"
    by (rule types_snocE)
  from snoc have "listall ?R bs" by simp
  with bs have "\<exists>bs'. ?ex Vs bs bs'" by (rule snoc)
  then obtain bs' where bsred: "Var j \<degree>\<degree> map (\<lambda>t. f (t[u/i])) bs \<rightarrow>\<^sub>\<beta>\<^sup>* Var j \<degree>\<degree> map f bs'"
    and bsNF: "NF (Var j \<degree>\<degree> map f bs')" for j
    by iprover
  from snoc have "?R b" by simp
  with bT and uNF and uT have "\<exists>b'. b[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* b' \<and> NF b'"
    by iprover
  then obtain b' where bred: "b[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* b'" and bNF: "NF b'"
    by iprover
  from bsNF [of 0] have "listall NF (map f bs')"
    by (rule App_NF_D)
  moreover have "NF (f b')" using bNF by (rule f_NF)
  ultimately have "listall NF (map f (bs' @ [b']))"
    by simp
  hence "\<And>j. NF (Var j \<degree>\<degree> map f (bs' @ [b']))" by (rule NF.App)
  moreover from bred have "f (b[u/i]) \<rightarrow>\<^sub>\<beta>\<^sup>* f b'"
    by (rule f_compat)
  with bsred have
    "\<And>j. (Var j \<degree>\<degree> map (\<lambda>t. f (t[u/i])) bs) \<degree> f (b[u/i]) \<rightarrow>\<^sub>\<beta>\<^sup>*
     (Var j \<degree>\<degree> map f bs') \<degree> f b'" by (rule rtrancl_beta_App)
  ultimately have "?ex Us (bs @ [b]) (bs' @ [b'])" by simp
  thus ?case ..
qed

lemma subst_type_NF:
  "\<And>t e T u i. NF t \<Longrightarrow> e\<langle>i:U\<rangle> \<turnstile> t : T \<Longrightarrow> NF u \<Longrightarrow> e \<turnstile> u : U \<Longrightarrow> \<exists>t'. t[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'"
  (is "PROP ?P U" is "\<And>t e T u i. _ \<Longrightarrow> PROP ?Q t e T u i U")
proof (induct U)
  fix T t
  let ?R = "\<lambda>t. \<forall>e T' u i.
    e\<langle>i:T\<rangle> \<turnstile> t : T' \<longrightarrow> NF u \<longrightarrow> e \<turnstile> u : T \<longrightarrow> (\<exists>t'. t[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t')"
  assume MI1: "\<And>T1 T2. T = T1 \<Rightarrow> T2 \<Longrightarrow> PROP ?P T1"
  assume MI2: "\<And>T1 T2. T = T1 \<Rightarrow> T2 \<Longrightarrow> PROP ?P T2"
  assume "NF t"
  thus "\<And>e T' u i. PROP ?Q t e T' u i T"
  proof induct
    fix e T' u i assume uNF: "NF u" and uT: "e \<turnstile> u : T"
    {
      case (App ts x e1 T'1 u1 i1)
      assume "e\<langle>i:T\<rangle> \<turnstile> Var x \<degree>\<degree> ts : T'"
      then obtain Us
        where varT: "e\<langle>i:T\<rangle> \<turnstile> Var x : Us \<Rrightarrow> T'"
        and argsT: "e\<langle>i:T\<rangle> \<tturnstile> ts : Us"
        by (rule var_app_typesE)
      from nat_eq_dec show "\<exists>t'. (Var x \<degree>\<degree> ts)[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'"
      proof
        assume eq: "x = i"
        show ?thesis
        proof (cases ts)
          case Nil
          with eq have "(Var x \<degree>\<degree> [])[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* u" by simp
          with Nil and uNF show ?thesis by simp iprover
        next
          case (Cons a as)
          with argsT obtain T'' Ts where Us: "Us = T'' # Ts"
            by (cases Us) (rule FalseE, simp)
          from varT and Us have varT: "e\<langle>i:T\<rangle> \<turnstile> Var x : T'' \<Rightarrow> Ts \<Rrightarrow> T'"
            by simp
          from varT eq have T: "T = T'' \<Rightarrow> Ts \<Rrightarrow> T'" by cases auto
          with uT have uT': "e \<turnstile> u : T'' \<Rightarrow> Ts \<Rrightarrow> T'" by simp
          from argsT Us Cons have argsT': "e\<langle>i:T\<rangle> \<tturnstile> as : Ts" by simp
          from argsT Us Cons have argT: "e\<langle>i:T\<rangle> \<turnstile> a : T''" by simp
          from argT uT refl have aT: "e \<turnstile> a[u/i] : T''" by (rule subst_lemma)
          from App and Cons have "listall ?R as" by simp (iprover dest: listall_conj2)
          with lift_preserves_beta' lift_NF uNF uT argsT'
          have "\<exists>as'. \<forall>j. Var j \<degree>\<degree> map (\<lambda>t. lift (t[u/i]) 0) as \<rightarrow>\<^sub>\<beta>\<^sup>*
            Var j \<degree>\<degree> map (\<lambda>t. lift t 0) as' \<and>
            NF (Var j \<degree>\<degree> map (\<lambda>t. lift t 0) as')" by (rule norm_list)
          then obtain as' where
            asred: "Var 0 \<degree>\<degree> map (\<lambda>t. lift (t[u/i]) 0) as \<rightarrow>\<^sub>\<beta>\<^sup>*
              Var 0 \<degree>\<degree> map (\<lambda>t. lift t 0) as'"
            and asNF: "NF (Var 0 \<degree>\<degree> map (\<lambda>t. lift t 0) as')" by iprover
          from App and Cons have "?R a" by simp
          with argT and uNF and uT have "\<exists>a'. a[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* a' \<and> NF a'"
            by iprover
          then obtain a' where ared: "a[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* a'" and aNF: "NF a'" by iprover
          from uNF have "NF (lift u 0)" by (rule lift_NF)
          hence "\<exists>u'. lift u 0 \<degree> Var 0 \<rightarrow>\<^sub>\<beta>\<^sup>* u' \<and> NF u'" by (rule app_Var_NF)
          then obtain u' where ured: "lift u 0 \<degree> Var 0 \<rightarrow>\<^sub>\<beta>\<^sup>* u'" and u'NF: "NF u'"
            by iprover
          from T and u'NF have "\<exists>ua. u'[a'/0] \<rightarrow>\<^sub>\<beta>\<^sup>* ua \<and> NF ua"
          proof (rule MI1)
            have "e\<langle>0:T''\<rangle> \<turnstile> lift u 0 \<degree> Var 0 : Ts \<Rrightarrow> T'"
            proof (rule typing.App)
              from uT' show "e\<langle>0:T''\<rangle> \<turnstile> lift u 0 : T'' \<Rightarrow> Ts \<Rrightarrow> T'" by (rule lift_type)
              show "e\<langle>0:T''\<rangle> \<turnstile> Var 0 : T''" by (rule typing.Var) simp
            qed
            with ured show "e\<langle>0:T''\<rangle> \<turnstile> u' : Ts \<Rrightarrow> T'" by (rule subject_reduction')
            from ared aT show "e \<turnstile> a' : T''" by (rule subject_reduction')
            show "NF a'" by fact
          qed
          then obtain ua where uared: "u'[a'/0] \<rightarrow>\<^sub>\<beta>\<^sup>* ua" and uaNF: "NF ua"
            by iprover
          from ared have "(lift u 0 \<degree> Var 0)[a[u/i]/0] \<rightarrow>\<^sub>\<beta>\<^sup>* (lift u 0 \<degree> Var 0)[a'/0]"
            by (rule subst_preserves_beta2')
          also from ured have "(lift u 0 \<degree> Var 0)[a'/0] \<rightarrow>\<^sub>\<beta>\<^sup>* u'[a'/0]"
            by (rule subst_preserves_beta')
          also note uared
          finally have "(lift u 0 \<degree> Var 0)[a[u/i]/0] \<rightarrow>\<^sub>\<beta>\<^sup>* ua" .
          hence uared': "u \<degree> a[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* ua" by simp
          from T asNF _ uaNF have "\<exists>r. (Var 0 \<degree>\<degree> map (\<lambda>t. lift t 0) as')[ua/0] \<rightarrow>\<^sub>\<beta>\<^sup>* r \<and> NF r"
          proof (rule MI2)
            have "e\<langle>0:Ts \<Rrightarrow> T'\<rangle> \<turnstile> Var 0 \<degree>\<degree> map (\<lambda>t. lift (t[u/i]) 0) as : T'"
            proof (rule list_app_typeI)
              show "e\<langle>0:Ts \<Rrightarrow> T'\<rangle> \<turnstile> Var 0 : Ts \<Rrightarrow> T'" by (rule typing.Var) simp
              from uT argsT' have "e \<tturnstile> map (\<lambda>t. t[u/i]) as : Ts"
                by (rule substs_lemma)
              hence "e\<langle>0:Ts \<Rrightarrow> T'\<rangle> \<tturnstile> map (\<lambda>t. lift t 0) (map (\<lambda>t. t[u/i]) as) : Ts"
                by (rule lift_types)
              thus "e\<langle>0:Ts \<Rrightarrow> T'\<rangle> \<tturnstile> map (\<lambda>t. lift (t[u/i]) 0) as : Ts"
                by (simp_all add: o_def)
            qed
            with asred show "e\<langle>0:Ts \<Rrightarrow> T'\<rangle> \<turnstile> Var 0 \<degree>\<degree> map (\<lambda>t. lift t 0) as' : T'"
              by (rule subject_reduction')
            from argT uT refl have "e \<turnstile> a[u/i] : T''" by (rule subst_lemma)
            with uT' have "e \<turnstile> u \<degree> a[u/i] : Ts \<Rrightarrow> T'" by (rule typing.App)
            with uared' show "e \<turnstile> ua : Ts \<Rrightarrow> T'" by (rule subject_reduction')
          qed
          then obtain r where rred: "(Var 0 \<degree>\<degree> map (\<lambda>t. lift t 0) as')[ua/0] \<rightarrow>\<^sub>\<beta>\<^sup>* r"
            and rnf: "NF r" by iprover
          from asred have
            "(Var 0 \<degree>\<degree> map (\<lambda>t. lift (t[u/i]) 0) as)[u \<degree> a[u/i]/0] \<rightarrow>\<^sub>\<beta>\<^sup>*
            (Var 0 \<degree>\<degree> map (\<lambda>t. lift t 0) as')[u \<degree> a[u/i]/0]"
            by (rule subst_preserves_beta')
          also from uared' have "(Var 0 \<degree>\<degree> map (\<lambda>t. lift t 0) as')[u \<degree> a[u/i]/0] \<rightarrow>\<^sub>\<beta>\<^sup>*
            (Var 0 \<degree>\<degree> map (\<lambda>t. lift t 0) as')[ua/0]" by (rule subst_preserves_beta2')
          also note rred
          finally have "(Var 0 \<degree>\<degree> map (\<lambda>t. lift (t[u/i]) 0) as)[u \<degree> a[u/i]/0] \<rightarrow>\<^sub>\<beta>\<^sup>* r" .
          with rnf Cons eq show ?thesis
            by (simp add: o_def) iprover
        qed
      next
        assume neq: "x \<noteq> i"
        from App have "listall ?R ts" by (iprover dest: listall_conj2)
        with uNF uT argsT
        have "\<exists>ts'. \<forall>j. Var j \<degree>\<degree> map (\<lambda>t. t[u/i]) ts \<rightarrow>\<^sub>\<beta>\<^sup>* Var j \<degree>\<degree> ts' \<and>
          NF (Var j \<degree>\<degree> ts')" (is "\<exists>ts'. ?ex ts'")
          by (rule norm_list [of "\<lambda>t. t", simplified])
        then obtain ts' where NF: "?ex ts'" ..
        from nat_le_dec show ?thesis
        proof
          assume "i < x"
          with NF show ?thesis by simp iprover
        next
          assume "\<not> (i < x)"
          with NF neq show ?thesis by (simp add: subst_Var) iprover
        qed
      qed
    next
      case (Abs r e1 T'1 u1 i1)
      assume absT: "e\<langle>i:T\<rangle> \<turnstile> Abs r : T'"
      then obtain R S where "e\<langle>0:R\<rangle>\<langle>Suc i:T\<rangle>  \<turnstile> r : S" by (rule abs_typeE) simp
      moreover have "NF (lift u 0)" using \<open>NF u\<close> by (rule lift_NF)
      moreover have "e\<langle>0:R\<rangle> \<turnstile> lift u 0 : T" using uT by (rule lift_type)
      ultimately have "\<exists>t'. r[lift u 0/Suc i] \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'" by (rule Abs)
      thus "\<exists>t'. Abs r[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'"
        by simp (iprover intro: rtrancl_beta_Abs NF.Abs)
    }
  qed
qed

\<comment> \<open>A computationally relevant copy of @{term "e \<turnstile> t : T"}\<close>
inductive rtyping :: "(nat \<Rightarrow> type) \<Rightarrow> dB \<Rightarrow> type \<Rightarrow> bool"  ("_ \<turnstile>\<^sub>R _ : _" [50, 50, 50] 50)
  where
    Var: "e x = T \<Longrightarrow> e \<turnstile>\<^sub>R Var x : T"
  | Abs: "e\<langle>0:T\<rangle> \<turnstile>\<^sub>R t : U \<Longrightarrow> e \<turnstile>\<^sub>R Abs t : (T \<Rightarrow> U)"
  | App: "e \<turnstile>\<^sub>R s : T \<Rightarrow> U \<Longrightarrow> e \<turnstile>\<^sub>R t : T \<Longrightarrow> e \<turnstile>\<^sub>R (s \<degree> t) : U"

lemma rtyping_imp_typing: "e \<turnstile>\<^sub>R t : T \<Longrightarrow> e \<turnstile> t : T"
  apply (induct set: rtyping)
  apply (erule typing.Var)
  apply (erule typing.Abs)
  apply (erule typing.App)
  apply assumption
  done

theorem type_NF:
  assumes "e \<turnstile>\<^sub>R t : T"
  shows "\<exists>t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'" using assms
proof induct
  case Var
  show ?case by (iprover intro: Var_NF)
next
  case Abs
  thus ?case by (iprover intro: rtrancl_beta_Abs NF.Abs)
next
  case (App e s T U t)
  from App obtain s' t' where
    sred: "s \<rightarrow>\<^sub>\<beta>\<^sup>* s'" and "NF s'"
    and tred: "t \<rightarrow>\<^sub>\<beta>\<^sup>* t'" and tNF: "NF t'" by iprover
  have "\<exists>u. (Var 0 \<degree> lift t' 0)[s'/0] \<rightarrow>\<^sub>\<beta>\<^sup>* u \<and> NF u"
  proof (rule subst_type_NF)
    have "NF (lift t' 0)" using tNF by (rule lift_NF)
    hence "listall NF [lift t' 0]" by (rule listall_cons) (rule listall_nil)
    hence "NF (Var 0 \<degree>\<degree> [lift t' 0])" by (rule NF.App)
    thus "NF (Var 0 \<degree> lift t' 0)" by simp
    show "e\<langle>0:T \<Rightarrow> U\<rangle> \<turnstile> Var 0 \<degree> lift t' 0 : U"
    proof (rule typing.App)
      show "e\<langle>0:T \<Rightarrow> U\<rangle> \<turnstile> Var 0 : T \<Rightarrow> U"
        by (rule typing.Var) simp
      from tred have "e \<turnstile> t' : T"
        by (rule subject_reduction') (rule rtyping_imp_typing, rule App.hyps)
      thus "e\<langle>0:T \<Rightarrow> U\<rangle> \<turnstile> lift t' 0 : T"
        by (rule lift_type)
    qed
    from sred show "e \<turnstile> s' : T \<Rightarrow> U"
      by (rule subject_reduction') (rule rtyping_imp_typing, rule App.hyps)
    show "NF s'" by fact
  qed
  then obtain u where ured: "s' \<degree> t' \<rightarrow>\<^sub>\<beta>\<^sup>* u" and unf: "NF u" by simp iprover
  from sred tred have "s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<degree> t'" by (rule rtrancl_beta_App)
  hence "s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* u" using ured by (rule rtranclp_trans)
  with unf show ?case by iprover
qed

subsection \<open>Extracting the program\<close>

declare NF.induct [ind_realizer]
declare rtranclp.induct [ind_realizer irrelevant]
declare rtyping.induct [ind_realizer]
lemmas [extraction_expand] = conj_assoc listall_cons_eq subst_all equal_allI

extract type_NF

lemma rtranclR_rtrancl_eq: "rtranclpR r a b = r\<^sup>*\<^sup>* a b"
  apply (rule iffI)
  apply (erule rtranclpR.induct)
  apply (rule rtranclp.rtrancl_refl)
  apply (erule rtranclp.rtrancl_into_rtrancl)
  apply assumption
  apply (erule rtranclp.induct)
  apply (rule rtranclpR.rtrancl_refl)
  apply (erule rtranclpR.rtrancl_into_rtrancl)
  apply assumption
  done

lemma NFR_imp_NF: "NFR nf t \<Longrightarrow> NF t"
  apply (erule NFR.induct)
  apply (rule NF.intros)
  apply (simp add: listall_def)
  apply (erule NF.intros)
  done

text_raw \<open>
\begin{figure}
\renewcommand{\isastyle}{\scriptsize\it}%
@{thm [display,eta_contract=false,margin=100] subst_type_NF_def}
\renewcommand{\isastyle}{\small\it}%
\caption{Program extracted from \<open>subst_type_NF\<close>}
\label{fig:extr-subst-type-nf}
\end{figure}

\begin{figure}
\renewcommand{\isastyle}{\scriptsize\it}%
@{thm [display,margin=100] subst_Var_NF_def}
@{thm [display,margin=100] app_Var_NF_def}
@{thm [display,margin=100] lift_NF_def}
@{thm [display,eta_contract=false,margin=100] type_NF_def}
\renewcommand{\isastyle}{\small\it}%
\caption{Program extracted from lemmas and main theorem}
\label{fig:extr-type-nf}
\end{figure}
\<close>

text \<open>
The program corresponding to the proof of the central lemma, which
performs substitution and normalization, is shown in Figure
\ref{fig:extr-subst-type-nf}. The correctness
theorem corresponding to the program \<open>subst_type_NF\<close> is
@{thm [display,margin=100] subst_type_NF_correctness
  [simplified rtranclR_rtrancl_eq Collect_mem_eq, no_vars]}
where \<open>NFR\<close> is the realizability predicate corresponding to
the datatype \<open>NFT\<close>, which is inductively defined by the rules
\pagebreak
@{thm [display,margin=90] NFR.App [of ts nfs x] NFR.Abs [of nf t]}

The programs corresponding to the main theorem \<open>type_NF\<close>, as
well as to some lemmas, are shown in Figure \ref{fig:extr-type-nf}.
The correctness statement for the main function \<open>type_NF\<close> is
@{thm [display,margin=100] type_NF_correctness
  [simplified rtranclR_rtrancl_eq Collect_mem_eq, no_vars]}
where the realizability predicate \<open>rtypingR\<close> corresponding to the
computationally relevant version of the typing judgement is inductively
defined by the rules
@{thm [display,margin=100] rtypingR.Var [no_vars]
  rtypingR.Abs [of ty, no_vars] rtypingR.App [of ty e s T U ty' t]}
\<close>

subsection \<open>Generating executable code\<close>

instantiation NFT :: default
begin

definition "default = Dummy ()"

instance ..

end

instantiation dB :: default
begin

definition "default = dB.Var 0"

instance ..

end

instantiation prod :: (default, default) default
begin

definition "default = (default, default)"

instance ..

end

instantiation list :: (type) default
begin

definition "default = []"

instance ..

end

instantiation "fun" :: (type, default) default
begin

definition "default = (\<lambda>x. default)"

instance ..

end

definition int_of_nat :: "nat \<Rightarrow> int" where
  "int_of_nat = of_nat"

text \<open>
  The following functions convert between Isabelle's built-in {\tt term}
  datatype and the generated {\tt dB} datatype. This allows to
  generate example terms using Isabelle's parser and inspect
  normalized terms using Isabelle's pretty printer.
\<close>

ML \<open>
val nat_of_integer = @{code nat} o @{code int_of_integer};

fun dBtype_of_typ (Type ("fun", [T, U])) =
      @{code Fun} (dBtype_of_typ T, dBtype_of_typ U)
  | dBtype_of_typ (TFree (s, _)) = (case raw_explode s of
        ["'", a] => @{code Atom} (nat_of_integer (ord a - 97))
      | _ => error "dBtype_of_typ: variable name")
  | dBtype_of_typ _ = error "dBtype_of_typ: bad type";

fun dB_of_term (Bound i) = @{code dB.Var} (nat_of_integer i)
  | dB_of_term (t $ u) = @{code dB.App} (dB_of_term t, dB_of_term u)
  | dB_of_term (Abs (_, _, t)) = @{code dB.Abs} (dB_of_term t)
  | dB_of_term _ = error "dB_of_term: bad term";

fun term_of_dB Ts (Type ("fun", [T, U])) (@{code dB.Abs} dBt) =
      Abs ("x", T, term_of_dB (T :: Ts) U dBt)
  | term_of_dB Ts _ dBt = term_of_dB' Ts dBt
and term_of_dB' Ts (@{code dB.Var} n) = Bound (@{code integer_of_nat} n)
  | term_of_dB' Ts (@{code dB.App} (dBt, dBu)) =
      let val t = term_of_dB' Ts dBt
      in case fastype_of1 (Ts, t) of
          Type ("fun", [T, _]) => t $ term_of_dB Ts T dBu
        | _ => error "term_of_dB: function type expected"
      end
  | term_of_dB' _ _ = error "term_of_dB: term not in normal form";

fun typing_of_term Ts e (Bound i) =
      @{code Var} (e, nat_of_integer i, dBtype_of_typ (nth Ts i))
  | typing_of_term Ts e (t $ u) = (case fastype_of1 (Ts, t) of
        Type ("fun", [T, U]) => @{code App} (e, dB_of_term t,
          dBtype_of_typ T, dBtype_of_typ U, dB_of_term u,
          typing_of_term Ts e t, typing_of_term Ts e u)
      | _ => error "typing_of_term: function type expected")
  | typing_of_term Ts e (Abs (_, T, t)) =
      let val dBT = dBtype_of_typ T
      in @{code Abs} (e, dBT, dB_of_term t,
        dBtype_of_typ (fastype_of1 (T :: Ts, t)),
        typing_of_term (T :: Ts) (@{code shift} e @{code "0::nat"} dBT) t)
      end
  | typing_of_term _ _ _ = error "typing_of_term: bad term";

fun dummyf _ = error "dummy";

val ct1 = @{cterm "%f. ((%f x. f (f (f x))) ((%f x. f (f (f (f x)))) f))"};
val (dB1, _) = @{code type_NF} (typing_of_term [] dummyf (Thm.term_of ct1));
val ct1' = Thm.cterm_of @{context} (term_of_dB [] (Thm.typ_of_cterm ct1) dB1);

val ct2 = @{cterm "%f x. (%x. f x x) ((%x. f x x) ((%x. f x x) ((%x. f x x) ((%x. f x x) ((%x. f x x) x)))))"};
val (dB2, _) = @{code type_NF} (typing_of_term [] dummyf (Thm.term_of ct2));
val ct2' = Thm.cterm_of @{context} (term_of_dB [] (Thm.typ_of_cterm ct2) dB2);
\<close>

end


header {* \isaheader{Weak Order Dependence} *}

theory WeakOrderDependence imports "../Basic/CFG" DataDependence begin

text {* Weak order dependence is just defined as a static control dependence *}

subsection{* Definition and some lemmas *}

definition (in CFG) weak_order_dependence :: "'node \<Rightarrow> 'node \<Rightarrow> 'node \<Rightarrow> bool"
   ("_ \<longrightarrow>\<^bsub>wod\<^esub> _,_")
where wod_def:"n \<longrightarrow>\<^bsub>wod\<^esub> n\<^sub>1,n\<^sub>2 \<equiv> ((n\<^sub>1 \<noteq> n\<^sub>2) \<and>
   (\<exists>as. (n -as\<rightarrow>* n\<^sub>1) \<and> (n\<^sub>2 \<notin> set (sourcenodes as))) \<and>
   (\<exists>as. (n -as\<rightarrow>* n\<^sub>2) \<and> (n\<^sub>1 \<notin> set (sourcenodes as))) \<and>
   (\<exists>a. (valid_edge a) \<and> (n = sourcenode a) \<and>
        ((\<exists>as. (targetnode a -as\<rightarrow>* n\<^sub>1) \<and>
               (\<forall>as'. (targetnode a -as'\<rightarrow>* n\<^sub>2) \<longrightarrow> n\<^sub>1 \<in> set(sourcenodes as'))) \<or>
         (\<exists>as. (targetnode a -as\<rightarrow>* n\<^sub>2) \<and>
               (\<forall>as'. (targetnode a -as'\<rightarrow>* n\<^sub>1) \<longrightarrow> n\<^sub>2 \<in> set(sourcenodes as'))))))"

inductive_set (in CFG_wf) wod_backward_slice :: "'node set \<Rightarrow> 'node set"
for S :: "'node set"
  where refl:"\<lbrakk>valid_node n; n \<in> S\<rbrakk> \<Longrightarrow> n \<in> wod_backward_slice S"

  | cd_closed:
  "\<lbrakk>n' \<longrightarrow>\<^bsub>wod\<^esub> n\<^sub>1,n\<^sub>2; n\<^sub>1 \<in> wod_backward_slice S; n\<^sub>2 \<in> wod_backward_slice S\<rbrakk>
  \<Longrightarrow> n' \<in> wod_backward_slice S"

  | dd_closed:"\<lbrakk>n' influences V in n''; n'' \<in> wod_backward_slice S\<rbrakk>
  \<Longrightarrow> n' \<in> wod_backward_slice S"

lemma (in CFG_wf)
  wod_backward_slice_valid_node:"n \<in> wod_backward_slice S \<Longrightarrow> valid_node n"
by(induct rule:wod_backward_slice.induct,
   auto dest:path_valid_node simp:wod_def data_dependence_def)

end


theory testvalid
  imports ext_Complementlemma
begin

lemma ex_tran:
  assumes "\<And>x. P x \<Longrightarrow>\<^sub>t R x"
  shows "(\<exists>\<^sub>t x. P x) \<Longrightarrow>\<^sub>t (\<exists>\<^sub>t x. R x)"
  using assms by (auto simp add: ex_assn_def entails_tassn_def)

lemma pure_tran:
  assumes "P \<Longrightarrow>\<^sub>t R "
  shows "(\<up>b \<and>\<^sub>t P) \<Longrightarrow>\<^sub>t (\<up>b \<and>\<^sub>t R)"
  using assms by (auto simp add: pure_assn_def entails_tassn_def conj_assn_def)

lemma pure_simp:
"(\<up>b1 \<and>\<^sub>t \<up>b2 \<and>\<^sub>t P) = (\<up>(b1 \<and> b2) \<and>\<^sub>t P)"
  by (auto simp add: pure_assn_def entails_tassn_def conj_assn_def)

lemma pure_true[simp]:
"(\<up> True \<and>\<^sub>t p) = p"
  by (auto simp add: pure_assn_def entails_tassn_def conj_assn_def)

lemma pure_true'[simp]:
" P  \<Longrightarrow>\<^sub>t  \<up> True "
  by (auto simp add: pure_assn_def entails_tassn_def conj_assn_def)

lemma true_assn[simp]:
" P  \<Longrightarrow>\<^sub>t  true_assn "
by (auto simp add: true_assn_def entails_tassn_def conj_assn_def)

lemma combine_ex_left:
"combine_assn chs (\<exists>\<^sub>t v. p v) (q) = (\<exists>\<^sub>t v. combine_assn chs (p v) q)"
  unfolding combine_assn_def ex_assn_def entails_tassn_def
  by auto

lemma combine_ex_right:
"combine_assn chs (q) (\<exists>\<^sub>t v. p v) = (\<exists>\<^sub>t v. combine_assn chs q (p v))"
  unfolding combine_assn_def ex_assn_def entails_tassn_def
  thm disjE
  by auto

lemma entails_disjE:
"P \<Longrightarrow>\<^sub>A R \<Longrightarrow> Q \<Longrightarrow>\<^sub>A R \<Longrightarrow> (\<lambda> (a,s)  t. P  (a,s) t \<or> Q  (a,s) t) \<Longrightarrow>\<^sub>A R"
  unfolding entails_def by auto

lemma entails_disjE':
"P \<Longrightarrow>\<^sub>A R \<Longrightarrow> Q \<Longrightarrow>\<^sub>A R \<Longrightarrow> (\<lambda> s  t. P  s t \<or> Q  s t) \<Longrightarrow>\<^sub>A R"
  unfolding entails_def by auto

lemma entails_disjI1':
"P \<Longrightarrow>\<^sub>A R1 \<Longrightarrow> P \<Longrightarrow>\<^sub>A (\<lambda> s t. R1 s t \<or> R2 s t)"
  unfolding entails_def by auto

lemma entails_disjI2':
"P \<Longrightarrow>\<^sub>A R2 \<Longrightarrow> P \<Longrightarrow>\<^sub>A (\<lambda> s t. R1 s t \<or> R2 s t)"
  unfolding entails_def by auto

lemma join_disj_assn:
"P @\<^sub>t (Q1 \<or>\<^sub>t Q2) = ((P @\<^sub>t Q1) \<or>\<^sub>t (P @\<^sub>t Q2))"
  unfolding join_assn_def disj_assn_def join_assn_def by blast

lemma Valid_true:
"\<Turnstile> {\<lambda> s t. P t} p {\<lambda> s t. (P @\<^sub>t true\<^sub>A) t}"
  unfolding Valid_def join_assn_def true_assn_def by auto

inductive out_0assn :: "cname \<Rightarrow> real \<Rightarrow> 'a tassn" ("Out0\<^sub>t") where
  "Out0\<^sub>t ch v [OutBlock ch v]"

inductive in_0assn :: "cname \<Rightarrow> real \<Rightarrow> 'a tassn" ("In0\<^sub>t") where
  "In0\<^sub>t ch v [InBlock ch v]"

inductive wait_passn :: "rdy_info \<Rightarrow> 'a tassn" ("Waitp\<^sub>t") where
  "d > 0 \<Longrightarrow> Waitp\<^sub>t rdy [WaitBlk d (\<lambda>\<tau>. p \<tau>) rdy]"

theorem Valid_send_sp_assm0:
  "\<Turnstile> {\<lambda>s t. P s t}
       Cm (ch[!]e)
     {\<lambda>s t. (P s @\<^sub>t (Out0\<^sub>t ch (e s) \<or>\<^sub>t Waitp\<^sub>t ({ch},{}) @\<^sub>t true\<^sub>A)) t}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_send)
  apply (auto simp add: entails_def magic_wand_assn_def join_assn_def disj_assn_def true_assn_def)
    subgoal for a b tr
      apply(rule exI[where x= tr])
      using out_0assn.intros(1) by auto
    subgoal for a b tr d
      apply(rule exI[where x= tr])
      apply(rule conjI)
      apply simp
      apply(rule exI[where x="[WaitBlk d (\<lambda>_. EState (a, b)) ({ch}, {}), OutBlock ch (e (a, b))]"])
      apply(rule conjI)
       apply(rule disjI2)
      using wait_passn.intros(1)[of d]
       apply fastforce
      by auto
    done

lemma tassn_to_assn:
"P \<Longrightarrow>\<^sub>t Q \<Longrightarrow> (\<lambda> s. P) \<Longrightarrow>\<^sub>A (\<lambda> s. Q)"
  unfolding entails_def entails_tassn_def
  by auto

end


(* uses Isabelle2017 and autocorres version 1.0 *)
theory Check_Connected
  imports
  "../Library/Autocorres_Misc"
  "../Witness_Property/Connected_Components"
begin
(* Parse the input file. *)
install_C_file "check_connected.c"

autocorres "check_connected.c"

context check_connected begin

thm "check_r_body_def"

(* Autocorres wp lemmas *)
thm "check_parent_num_body_def"
lemma validNFE_getsE[wp]:
  "\<lbrace>\<lambda>s. P (f s) s\<rbrace> getsE f \<lbrace>P\<rbrace>, \<lbrace>E\<rbrace>!"
  by (auto simp: getsE_def) wp

lemma validNFE_guardE[wp]:
  "\<lbrace>\<lambda>s. f s \<and> P () s\<rbrace> guardE f \<lbrace>P\<rbrace>, \<lbrace>Q\<rbrace>!"
  by (auto simp: guardE_def, wp, linarith)

(* Lemmas for unat and of_nat *)
lemma eq_of_nat_conv:
  assumes "unat w1 = n"
  shows "w2 = of_nat n \<longleftrightarrow> w2 = w1"
  using assms by auto

(* More Lemmas for unat and of_nat *)
lemma less_unat_plus1:
  assumes "a < unat (b + 1)"
  shows "a < unat b \<or> a = unat b"
  apply (subgoal_tac  "b + 1 \<noteq> 0 ")
  using assms unat_minus_one add_diff_cancel
  by fastforce+

lemma unat_minus_plus1_less:
  fixes a b
  assumes "a < b"
  shows "unat (b - (a + 1)) < unat (b - a)"
  by (metis (no_types) ab_semigroup_add_class.add_ac(1) right_minus_eq measure_unat
      add_diff_cancel2 assms is_num_normalize(1) zadd_diff_inverse linorder_neq_iff)

lemma unat_image_upto:
  fixes n :: "32 word"
  shows "unat ` {0..<n} = {unat 0..<unat n}" (is "?A = ?B")
proof
  show "?B \<subseteq> ?A"
  proof
    fix i assume a: "i \<in> ?B"
    then obtain i':: "32 word" where ii: "i=  unat i'"
      by (metis atLeastLessThan_iff le_unat_uoi less_or_eq_imp_le)
    then have "i' \<in> {0..<n}"
      using a word_less_nat_alt by auto
    thus  "i \<in> ?A" using ii by fast
  qed
next
  show "?A \<subseteq> ?B"
  proof
     fix i assume a: "i \<in> ?A"
    then obtain i':: "32 word" where ii: "i=  unat i'" by blast
    then have "i' \<in> {0..<n}" using a by force
    thus  "i \<in> ?B"
      by (metis Un_iff atLeast0LessThan ii ivl_disj_un(8)
          lessThan_iff unat_0 unat_mono word_zero_le)
  qed
qed
(*Implementation Graph Types*)

type_synonym IVertex = "32 word"
type_synonym IEdge_Id = "32 word"
type_synonym IEdge = "IVertex \<times> IVertex"
type_synonym IPEdge = "IVertex \<Rightarrow> 32 word"
type_synonym INum = "IVertex \<Rightarrow> 32 word"
type_synonym IGraph = "32 word \<times> 32 word \<times> (IEdge_Id \<Rightarrow> IEdge)"

abbreviation
  ivertex_cnt :: "IGraph \<Rightarrow> 32 word"
where
  "ivertex_cnt G \<equiv> fst G"

abbreviation
  iedge_cnt :: "IGraph \<Rightarrow> 32 word"
where
  "iedge_cnt G \<equiv> fst (snd G)"

abbreviation
  iedges :: "IGraph \<Rightarrow> IEdge_Id \<Rightarrow> IEdge"
where
  "iedges G \<equiv> snd (snd G)"

(* Make List - makes a list containing the result of a function *)
fun
  bool::"32 word \<Rightarrow> bool"
where
  "bool b = (if b=0 then False else True)"

fun
  mk_list' :: "nat \<Rightarrow> (32 word \<Rightarrow> 'b) \<Rightarrow> 'b list"
where
  "mk_list' n f = map f  (map of_nat [0..<n])"

fun
  mk_list'_temp :: "nat \<Rightarrow> (32 word \<Rightarrow> 'b) \<Rightarrow> nat \<Rightarrow> 'b list"
where
  "mk_list'_temp 0 _ _ = []" |
  "mk_list'_temp (Suc x) f i = (f (of_nat i)) # mk_list'_temp x f (Suc i)"

(* Make graph lists *)
fun
  mk_iedge_list :: "IGraph \<Rightarrow> IEdge list"
where
  "mk_iedge_list G = mk_list' (unat (iedge_cnt G)) (iedges G)"

fun
  mk_inum_list :: "IGraph \<Rightarrow> INum \<Rightarrow> 32 word list"
where
  "mk_inum_list G num = mk_list' (unat (ivertex_cnt G)) num"

fun
  mk_ipedge_list :: "IGraph \<Rightarrow> IPEdge \<Rightarrow> 32 word list"
where
  "mk_ipedge_list G pedge = mk_list' (unat (ivertex_cnt G)) pedge"

(* Equate to Implementation *)
fun
  to_edge :: "IEdge \<Rightarrow> Edge_C"
where
  "to_edge (u,v) = Edge_C u v"

lemma s_C_pte[simp]:
  "s_C (to_edge e) = fst e"
  by (cases e) auto

lemma t_C_pte[simp]:
  "t_C (to_edge e) = snd e"
  by (cases e) auto

definition is_graph where
  "is_graph h iG p \<equiv>
    is_valid_Graph_C h p \<and>
    ivertex_cnt iG = n_C (heap_Graph_C h p) \<and>
    iedge_cnt iG = m_C (heap_Graph_C h p) \<and>
    arrlist (heap_Edge_C h) (is_valid_Edge_C h)
      (map to_edge (mk_iedge_list iG)) (es_C (heap_Graph_C h p))"

definition
  "is_numm h iG iN p \<equiv> arrlist (heap_w32 h) (is_valid_w32 h) (mk_inum_list iG iN) p"

definition
  "is_pedge h iG iP (p:: 32 signed word ptr) \<equiv> arrlist (\<lambda>p. heap_w32 h (ptr_coerce p))
        (\<lambda>p. is_valid_w32 h (ptr_coerce p)) (mk_ipedge_list iG iP) p"

lemma sint_ucast:
  "sint (ucast (x ::word32) :: sword32) = sint x"
  by (clarsimp simp: sint_uint uint_up_ucast is_up)

definition
  is_root :: "IGraph \<Rightarrow> IVertex \<Rightarrow> IPEdge \<Rightarrow> INum \<Rightarrow> bool"
where
  "is_root iG r iP iN \<equiv> r < (ivertex_cnt iG) \<and> (iN r = 0) \<and> (sint (iP r) < 0)"

definition
  parent_num_assms_inv :: "IGraph \<Rightarrow> IVertex \<Rightarrow> IPEdge \<Rightarrow> INum \<Rightarrow> nat \<Rightarrow> bool"
where
  "parent_num_assms_inv G r p n k \<equiv>
    \<forall>i < k. (of_nat i) \<noteq> r \<longrightarrow>
            0 \<le> sint (p (of_nat i)) \<and>
            ((p (of_nat i)) < iedge_cnt G \<and>
            snd (iedges G (p (of_nat i))) = (of_nat i) \<and>
            n (of_nat i) = n (fst (iedges G (p (of_nat i)))) + 1) \<and>
            n (of_nat i) < ivertex_cnt G"

function (in connected_components_locale)
  pwalk :: "'a \<Rightarrow> 'a list"
where
  "pwalk v =
    (if (v = r  \<or> v \<notin> verts G)
      then [v]
      else
       pwalk (tail G (the (parent_edge v))) \<oplus> [tail G (the (parent_edge v)), v])"
  by simp+
termination (in connected_components_locale)
  using parent_num_assms
  by (relation "measure num", auto, fastforce)

lemma (in connected_components_locale) pwalk_simps:
  "v = r \<or> v \<notin> verts G \<Longrightarrow> pwalk v = [v]"
  "v \<noteq> r \<Longrightarrow> v \<in> verts G \<Longrightarrow> pwalk v =
    pwalk (tail G (the (parent_edge v))) @ [v]"
  by (simp, metis drop_0 pwalk.simps
    drop_Suc_Cons vwalk_join_def drop_Suc)

lemma (in connected_components_locale) pwalk_ne: "pwalk v \<noteq> []"
  by (metis drop_0 drop_Suc drop_Suc_Cons not_Cons_self
      pwalk.simps snoc_eq_iff_butlast vwalk_join_def)

lemma (in connected_components_locale) vwalk_length_pwalk:
  assumes "v \<in> verts G"
  assumes "v \<noteq> r"
  shows "vwalk_length (pwalk v) =
         vwalk_length (pwalk (tail G (the (parent_edge v)))) + 1"
  proof -
    have "pwalk v = pwalk (tail G (the (parent_edge v))) \<oplus> [tail G (the (parent_edge v)), v]"
    by (meson assms(1) assms(2) pwalk.simps)
  then show ?thesis
    by (metis (no_types) One_nat_def add_cancel_left_left add_diff_cancel_right'
          length_append length_tl list.size(3) list.size(4) pwalk_ne tl_append2 vwalk_join_def
          vwalk_length_simp)
  qed

lemma (in connected_components_locale) pwalk_split:
  assumes "x \<in> set (pwalk v)"
  shows "\<exists>p. pwalk v = pwalk x @ p"
using assms
proof (induct "vwalk_length (pwalk v)" arbitrary: v)
case (Suc n)
have vnr: "v \<noteq> r"
  using Suc(2) by fastforce
show ?case
  proof (cases "v \<in> verts G")
  case True
    thus ?thesis
    proof (cases "x = v")
    case False
      let ?u = "tail G (the (parent_edge v))"
      have xpu: "x \<in> set (pwalk ?u)"
        using Suc(3) pwalk_simps(2)[OF vnr True] False by fastforce
      hence "\<exists>p. pwalk (tail G (the (parent_edge v))) = pwalk x @ p"
        using vwalk_length_pwalk[OF True vnr] Suc(2)
        by (metis Suc(1)[OF _ xpu] Suc_eq_plus1
            Suc_eq_plus1_left diff_add_inverse)
      thus ?thesis using pwalk_simps(2)[OF vnr True] by fastforce
    qed fast
  qed (metis Suc.prems append_Nil2 empty_iff empty_set pwalk_simps(1) set_ConsD)
qed (metis pwalk_simps(1) add_is_0 vwalk_length_pwalk
     append_Nil2 empty_iff empty_set one_neq_zero set_ConsD)

lemma (in connected_components_locale) path_from_root_num:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "vpath (pwalk v) G \<and>
         hd (pwalk v) = r \<and>
         last (pwalk v) = v \<and>
         num v = vwalk_length (pwalk v)"
using assms
proof (induct "vwalk_length (pwalk v)" arbitrary: v rule: less_induct)
case less
  thus ?case
  proof (cases "v=r")
    case True
      thus ?thesis using r_assms unfolding vpath_def by force
  next
    case False
      then obtain e where ee:
        "e \<in> arcs G"
        "e = the (parent_edge v)"
        "head G e = v \<and> num v = num (tail G e) + 1"
        using less.prems parent_num_assms by force
      let ?te = "tail G e"
      let ?p' = "pwalk ?te"
      let ?q = "[?te, v]"
      obtain p where
        pp: "p = ?p' \<oplus> ?q"
        by presburger
      hence pv: "p = pwalk v"
        using less.prems False ee(2) by force
      have ew: "vwalk ?q G" unfolding vwalk_def
        using ee(3) in_arcs_imp_in_arcs_ends[OF ee(1)]
              less.prems  tail_in_verts[OF ee(1)]
        by auto
      have wlp: "vwalk_length ?p' < vwalk_length (pwalk v)"
        using vwalk_length_pwalk[OF less.prems False] ee(2)
        by presburger
      hence pp':
        "vwalk ?p' G"
        "distinct ?p'"
        "hd ?p' = r"
        "last ?p' = ?te"
        "num ?te = vwalk_length ?p'"
        using less.hyps[where v2="?te",
              OF _ tail_in_verts[OF ee(1)]]
        unfolding vpath_def by linarith+
      have jp: "joinable ?p' ?q"
         unfolding  joinable_def
         by (simp only: pp'(4) pp'(1)[unfolded vwalk_def], simp)
      have "vwalk_length [tail G e, v] = 1" by force
      hence np: "num v = vwalk_length p"
        using pp vwalk_join_vwalk_length[OF jp] ee pp'(5)
        by (simp only: pp vwalk_join_vwalk_length[OF jp] ee pp'(5))
      have wp: "vwalk p G"
        by (metis pp ew pp'(1) jp vwalk_joinI_vwalk)
      {
        fix x assume xp: "x \<in> set ?p'"
        have "vwalk_length (pwalk x) \<le> vwalk_length ?p'"
          using pwalk_split[OF xp]
            by (smt length_append vwalk_length_simp less_or_eq_imp_le
                Nat.add_diff_assoc2 add_lessD1 less_not_refl
                linorder_neqE_nat neq0_conv zero_less_diff)
        then have wlx: "vwalk_length (pwalk x) < vwalk_length (pwalk v)"
          using wlp by linarith
        hence "num x = vwalk_length (pwalk x)"
          using pp'(1) less.hyps[OF wlx] xp vwalk_verts_in_verts by blast
        with wlx have "num x < vwalk_length (pwalk v)" by presburger
      }
    then have "v \<notin> set ?p'" using wlp np pv  by (metis less_not_refl)
    hence dp: "distinct p"
      by (metis butlast_snoc distinct.simps(2) distinct1_rotate pp pp'(2)
        list.simps(2) rotate1.simps(2) rotate1_hd_tl vwalk_join_def)
    hence "vpath p G \<and> hd p = r \<and> last p = v \<and>
           num v = vwalk_length p"
      using dp wp np pp' pp
      by (metis hd_append2 last_snoc list.sel(3) pwalk_ne vpathI vwalk_join_def)
    thus ?thesis using pv by fast
  qed
qed

(* Abstract Graph *)

definition
  no_loops :: "('a, 'b) pre_digraph \<Rightarrow> bool"
where
  "no_loops G \<equiv> \<forall>e \<in> arcs G. tail G e \<noteq> head G e"

definition
  abs_IGraph :: "IGraph \<Rightarrow> (32 word, 32 word) pre_digraph"
where
  "abs_IGraph G \<equiv> \<lparr> verts = {0..<ivertex_cnt G}, arcs = {0..<iedge_cnt G},
    tail = fst o iedges G, head = snd o iedges G \<rparr>"

lemma verts_absI[simp]: "verts (abs_IGraph G) = {0..<ivertex_cnt G}"
  and edges_absI[simp]: "arcs (abs_IGraph G) = {0..<iedge_cnt G}"
  and start_absI[simp]: "tail (abs_IGraph G) e = fst (iedges G e)"
  and target_absI[simp]: "head (abs_IGraph G) e = snd (iedges G e)"
  by (auto simp: abs_IGraph_def)

definition
  abs_pedge :: "(32 word \<Rightarrow> 32 word) \<Rightarrow> 32 word \<Rightarrow> 32 word option"
where
  "abs_pedge p \<equiv> (\<lambda>v. if sint (p v) < 0 then None else Some (p v))"

lemma None_abs_pedgeI[simp]:
  "((abs_pedge p) v = None) = (sint (p v) < 0)"
  using abs_pedge_def by auto

lemma Some_abs_pedgeI[simp]:
  "(\<exists>e. (abs_pedge p) v = Some e) = (sint (p v) \<ge> 0)"
  using None_not_eq None_abs_pedgeI
  by (metis abs_pedge_def linorder_not_le option.simps(3))

(*Helper Lemmas*)

lemma wellformed_iGraph:
  assumes "wf_digraph (abs_IGraph G)"
  shows "\<And>e. e < iedge_cnt G \<Longrightarrow>
        fst (iedges G e) < ivertex_cnt G \<and>
        snd (iedges G e) < ivertex_cnt G"
using assms unfolding wf_digraph_def by simp

lemma path_length:
  assumes "vpath p (abs_IGraph iG)"
  shows "vwalk_length p < unat (ivertex_cnt iG)"
proof -
  have pne: "p \<noteq> []" and dp: "distinct p" using assms by fast+
  have "unat (ivertex_cnt iG) = card (unat ` {0..<(fst iG)})"
    using unat_image_upto by simp
  then have "unat (ivertex_cnt iG) = card ((verts (abs_IGraph iG)))"
     by (simp add: inj_on_def card_image)
  hence "length p  \<le> unat (ivertex_cnt iG)"
      by (metis finite_code card_mono vwalk_def
          distinct_card[OF dp] vpath_def assms)
  hence "length p - 1 < unat (ivertex_cnt iG)"
    by (metis pne Nat.diff_le_self le_neq_implies_less
        less_imp_diff_less minus_eq one_neq_zero length_0_conv)
  thus "vwalk_length p < unat (fst iG)"
    using  assms
    unfolding vpath_def vwalk_def by simp
qed

lemma ptr_coerce_ptr_add_uint[simp]:
  "ptr_coerce (p +\<^sub>p uint x) =  p +\<^sub>p  (uint x)"
  by auto

lemma check_r'_spc:
  "is_graph s iG p \<Longrightarrow>
   is_numm s iG iN p' \<Longrightarrow>
   is_pedge s iG iP p'' \<Longrightarrow>
   check_r' p r p'' p' s =
   Some (if is_root iG r iP iN then 1 else 0)"
  unfolding check_r'_def unfolding is_graph_def is_numm_def is_pedge_def
  apply (simp add: ocondition_def oguard_def ogets_def oreturn_def obind_def)
  apply (simp add: is_root_def uint_nat word_less_def sint_ucast)
  apply (safe, simp_all add: arrlist_nth)
     apply (fastforce simp: dest:arrlist_nth_value[where i="int (unat r)"])
    apply (fastforce dest:arrlist_nth_valid[where i="int (unat r)"])
   apply (fastforce dest:arrlist_nth_value[where i="int (unat r)"])
  apply (fastforce dest:arrlist_nth_valid[where i="int (unat r)"])
  done

(*state monad without exception*)
lemma pedge_num_heap:
  "\<lbrakk>arrlist (\<lambda>p. heap_w32 h (ptr_coerce p)) (\<lambda>p. is_valid_w32 h (ptr_coerce p))
  (map (iL \<circ> of_nat) [0..<unat n]) l; i < n\<rbrakk> \<Longrightarrow>
    iL i = heap_w32 h (l +\<^sub>p int (unat i))"
  apply (subgoal_tac
  "heap_w32 h (l +\<^sub>p int (unat i)) = map (iL \<circ> of_nat) [0..<unat n] ! unat i")
   apply (subgoal_tac "map (iL \<circ> of_nat) [0..<unat n] ! unat i = iL i")
    apply fastforce
   apply (metis (hide_lams, mono_tags) unat_mono word_unat.Rep_inverse
    minus_nat.diff_0 nth_map_upt o_apply plus_nat.add_0)
  apply (simp add: arrlist_nth_value unat_mono)
  done

lemma pedge_num_heap_ptr_coerce:
  "\<lbrakk>arrlist (\<lambda>p. heap_w32 h (ptr_coerce p)) (\<lambda>p. is_valid_w32 h (ptr_coerce p))
  (map (iL \<circ> of_nat) [0..<unat n]) l; i < n; 0 \<le> i\<rbrakk> \<Longrightarrow>
    iL i = heap_w32 h (ptr_coerce (l +\<^sub>p int (unat i)))"
  apply (subgoal_tac
  "heap_w32 h (ptr_coerce (l +\<^sub>p int (unat i))) = map (iL \<circ> of_nat) [0..<unat n] ! unat i")
   apply (subgoal_tac "map (iL \<circ> of_nat) [0..<unat n] ! unat i = iL i")
    apply fastforce
   apply (metis (hide_lams, mono_tags) unat_mono word_unat.Rep_inverse
    minus_nat.diff_0 nth_map_upt o_apply plus_nat.add_0)
  apply (drule arrlist_nth_value[where i="int (unat i)"], (simp add:unat_mono)+)
  done

lemma edge_heap:
  "\<lbrakk> arrlist h v (map (to_edge \<circ> (iedges iG \<circ> of_nat)) [0..<unat m]) ep;
  e < m\<rbrakk> \<Longrightarrow> to_edge ((iedges iG) e) = h (ep +\<^sub>p (int (unat e)))"
  apply (subgoal_tac "h (ep +\<^sub>p (int (unat e))) =
  (map (to_edge \<circ> (iedges iG \<circ> of_nat)) [0..<unat m]) ! unat e")
   apply (subgoal_tac "to_edge ((iedges iG) e) =
   (map (to_edge \<circ> (iedges iG \<circ> of_nat)) [0..<unat m]) ! unat e")
    apply presburger
   apply (metis (hide_lams, mono_tags) length_map length_upt o_apply
      map_upt_eq_vals_D minus_nat.diff_0 unat_mono word_unat.Rep_inverse)
  apply (fastforce simp: unat_mono arrlist_nth_value)
  done

lemma head_heap:
  "\<lbrakk>arrlist h v (map (to_edge \<circ> (iedges iG \<circ> of_nat)) [0..<unat m]) ep; e < m\<rbrakk> \<Longrightarrow>
  snd ((iedges iG) e) = t_C (h (ep +\<^sub>p (uint e)))"
  using edge_heap to_edge.simps t_C_pte by (metis uint_nat)

lemma tail_heap:
  "\<lbrakk>arrlist h v (map (to_edge \<circ> (iedges iG \<circ> of_nat)) [0..<unat m]) ep; e < m\<rbrakk> \<Longrightarrow>
  fst ((iedges iG) e) =  s_C (h (ep +\<^sub>p  (uint e)))"
  using edge_heap to_edge.simps s_C_pte uint_nat by metis

lemma check_parent_num_spc':
  "\<lbrace> P and
    (\<lambda>s. wf_digraph (abs_IGraph iG) \<and>
         is_graph s iG g \<and>
         is_numm s iG iN n \<and>
         is_pedge s iG iP p \<and>
         r < ivertex_cnt iG)\<rbrace>
  check_parent_num' g r p n
  \<lbrace> (\<lambda>_ s. P s) And
    (\<lambda>rr s. rr \<noteq> 0 \<longleftrightarrow> parent_num_assms_inv iG r iP iN (unat (ivertex_cnt iG))) \<rbrace>!"
  apply (clarsimp simp: check_parent_num'_def)
  apply (subst whileLoopE_add_inv[where
        M="\<lambda>(vv, s). unat (ivertex_cnt iG - vv)" and
        I="\<lambda>vv s. P s \<and> parent_num_assms_inv iG r iP iN (unat vv) \<and>
          vv \<le> ivertex_cnt iG \<and>
          wf_digraph (abs_IGraph iG) \<and>
          is_graph s iG g \<and> is_numm s iG iN n \<and>
          is_pedge s iG iP p \<and>
          r < ivertex_cnt iG"])
  apply (simp add: skipE_def)
  apply wp
    unfolding is_graph_def is_numm_def is_pedge_def parent_num_assms_inv_def
      apply (subst if_bool_eq_conj)+
      apply (simp split: if_split_asm, safe, simp_all add: arrlist_nth)
                              apply (rule_tac i=" (uint vv)" in arrlist_nth_valid, simp+)
                              apply (metis uint_nat word_less_def)
                             apply (rule_tac x="unat vv" in exI)
                             apply (subgoal_tac "n_C (heap_Graph_C s g) \<le> iN vv")
                              apply (metis (hide_lams) word_less_nat_alt
                              word_not_le word_unat.Rep_inverse)
                             apply (subst pedge_num_heap[where l=n and iL=iN])
                               apply simp
                              apply simp
                             apply (metis uint_nat)
                            apply (rule_tac i=" (uint vv)" in arrlist_nth_valid)
                              apply simp+
                            apply (metis uint_nat word_less_def)
                           apply (rule_tac x="unat vv" in exI)
                           apply (rule conjI, metis unat_mono, simp)
                           apply (metis sint_ucast not_le uint_nat
                           pedge_num_heap_ptr_coerce word_zero_le)
                          apply (rule_tac x="unat vv" in exI)
                          apply (rule conjI, metis unat_mono, simp)
                          apply (metis not_le uint_nat pedge_num_heap_ptr_coerce word_zero_le)
                         apply (rule_tac x="unat vv" in exI)
                         apply (rule conjI, metis unat_mono, simp)
                         apply (subgoal_tac "snd (snd (snd iG) (iP vv)) =
                           t_C (heap_Edge_C s (es_C (heap_Graph_C s g) +\<^sub>p uint (iP vv)))")
                          apply (metis uint_nat pedge_num_heap_ptr_coerce word_zero_le)
                         apply (subst head_heap[where iG=iG], simp)
                          apply (metis not_le uint_nat pedge_num_heap_ptr_coerce word_zero_le)
                         apply simp
                        apply (rule_tac x="unat vv" in exI)
                        apply (rule conjI, metis unat_mono, simp,clarsimp)
                        apply (subgoal_tac "iN vv \<noteq> iN (fst (snd (snd iG) (iP vv))) + 1")
                         apply fast
                        apply (subst pedge_num_heap[where l=n and iL=iN])
                          apply simp+
                        apply (subst pedge_num_heap[where l=n and iL=iN])
                          apply simp
                         apply (drule wellformed_iGraph[where G=iG])
                          apply simp+
                        apply (subst tail_heap[where iG=iG], simp+)
                        apply (subst pedge_num_heap_ptr_coerce[where l=p and iL=iP])
                           apply simp+
                        apply (metis uint_nat)
                       apply (drule less_unat_plus1, safe, blast)
                       apply (subst pedge_num_heap_ptr_coerce[where l=p and iL=iP])
                          apply simp+
                       apply (metis sint_ucast not_less uint_nat)
                      apply (drule less_unat_plus1, safe, blast)
                      apply (subst pedge_num_heap_ptr_coerce[where l=p and iL=iP])
                         apply simp+
                      apply (metis not_less uint_nat)
                     apply (drule less_unat_plus1, safe, blast)
                     apply (subst pedge_num_heap_ptr_coerce[where l=p and iL=iP])
                        apply simp+
                     apply (subst head_heap[where iG=iG], (simp add: uint_nat)+)
                    apply (drule less_unat_plus1, safe, blast)
                    apply (subst pedge_num_heap[where l=n and iL=iN], simp+)
                    apply (subst pedge_num_heap[where l=n and iL=iN], simp)
                     apply (drule_tac e="iP vv" in  wellformed_iGraph[where G=iG])
                      apply (metis not_le pedge_num_heap_ptr_coerce word_zero_le)
                     apply simp
                    apply (subst tail_heap[where iG=iG], simp+)
                     apply (metis not_le pedge_num_heap_ptr_coerce word_zero_le)
                    apply (subst pedge_num_heap_ptr_coerce[where l=p and iL=iP])
                       apply simp+
                    apply (metis uint_nat)
                   apply (drule less_unat_plus1, safe, blast)
                   apply (subst pedge_num_heap[where l=n and iL=iN])
                     apply (simp add: uint_nat)+
                  apply (metis le_def word_le_nat_alt word_not_le
                  less_unat_plus1 eq_of_nat_conv)
                 apply (metis unat_minus_plus1_less)
                apply (rule arrlist_nth, blast, blast)
                apply (simp add: uint_nat unat_mono)
               apply (rule arrlist_nth, blast, blast)
               apply (simp add: uint_nat)
               apply (drule_tac i=vv in pedge_num_heap_ptr_coerce[where l=p and iL=iP])
                 apply simp+
               apply (drule_tac e="iP vv" in wellformed_iGraph[where G=iG])
                apply simp+
               apply (drule_tac e="iP vv" in tail_heap[where iG=iG])
                apply (simp add: uint_nat unat_mono)+
              apply (rule arrlist_nth, (simp add: uint_nat unat_mono)+)+
          apply (metis less_unat_plus1 word_unat.Rep_inverse)
         apply (metis eq_of_nat_conv less_unat_plus1)
        apply (metis (hide_lams, no_types) eq_of_nat_conv less_unat_plus1)
       apply (metis (no_types) less_unat_plus1 word_unat.Rep_inverse)
      apply (metis (no_types) less_unat_plus1 word_unat.Rep_inverse)
     apply (metis inc_le)
    apply (metis unat_minus_plus1_less)
   apply metis
  apply wp
  apply fast
  done
lemma num_less_n:
  fixes v
  assumes "is_root G r p n"
  assumes "parent_num_assms_inv G r p n (unat (ivertex_cnt G))"
  assumes "v < ivertex_cnt G"
  shows "n v < ivertex_cnt G"
proof -
  have "ivertex_cnt G > 0"
    using assms by (metis word_neq_0_conv word_not_simps(1))
  thus ?thesis
    using assms unfolding parent_num_assms_inv_def is_root_def
    by (cases "v=r", presburger , metis unat_mono word_unat.Rep_inverse)
qed

lemma parent_num_assms_inv_num_ne_0:
  fixes v
  assumes "wf_digraph (abs_IGraph G)"
  assumes "is_root G r p n"
  assumes "parent_num_assms_inv G r p n (unat (ivertex_cnt G))"
  assumes "v \<noteq> r"
  assumes "v < (ivertex_cnt G)"
  shows "n v \<noteq> 0"
proof-
  have "p v \<in> arcs (abs_IGraph G)"
    using assms(3-5) unat_mono
    unfolding parent_num_assms_inv_def
    by fastforce
  hence "fst (iedges G (p v)) \<in> verts (abs_IGraph G)"
     using assms(1) wf_digraph_def  by fastforce
  hence "n (fst (snd (snd G) (p v))) < ivertex_cnt G"
    using num_less_n[OF assms(2,3)] by fastforce
  moreover
  have "n v = n (fst (snd (snd G) (p v))) + 1"
    using assms unat_mono
    unfolding parent_num_assms_inv_def
    by force
  ultimately
  show ?thesis using assms
  by (metis less_is_non_zero_p1)
qed

lemma connected_components_locale_num_eq_invariants':
"\<And>G r p n.
  (connected_components_locale (abs_IGraph G) (unat \<circ>  n) (abs_pedge p) r
  \<and> (\<forall>v \<in> verts (abs_IGraph G). v\<noteq> r \<longrightarrow> (unat \<circ> n) v < unat (ivertex_cnt G))) =
    (wf_digraph (abs_IGraph G) \<and>
    is_root G r p n \<and>
    parent_num_assms_inv G r p n (unat (ivertex_cnt G)))"
proof -
  fix G fix r::"32 word" fix p n::"32 word \<Rightarrow> 32 word"
  let ?aG = "abs_IGraph G"
  let ?ap = "abs_pedge p"
  let ?an = "unat \<circ>  n"
  let ?wf = "wf_digraph ?aG"
  let ?is_root = "r \<in> verts ?aG \<and> ?ap r = None \<and> ?an r = 0"
  let ?pnai = "(\<forall>v. v \<in> verts ?aG \<and> v \<noteq> r \<longrightarrow>
                  (\<exists>e\<in>arcs ?aG. ?ap v = Some e \<and>
                  head ?aG e = v \<and>
                  ?an v = ?an (tail ?aG e) + 1)) \<and>
               (\<forall>v. v \<in>verts ?aG \<and>  v \<noteq> r \<longrightarrow>
                  ?an v < unat (ivertex_cnt G))"
  have isr_eq: "?is_root = is_root G r p n"
    unfolding is_root_def
    using None_abs_pedgeI unat_eq_0 by auto
moreover
  have "(?wf \<and> ?is_root \<and> ?pnai)
      = (?wf \<and> is_root G r p n \<and>
        parent_num_assms_inv G r p n (unat (ivertex_cnt G)))"
  proof -
  {
    assume wf: "?wf"
    assume isr: "?is_root"
    assume *: "\<And> v. v \<in> verts ?aG \<and> v \<noteq> r \<Longrightarrow>
    (\<exists>e \<in> arcs ?aG. ?ap v = Some e \<and>
    head ?aG e = v \<and>
    ?an v =  ?an (tail ?aG e) + 1) \<and> (?an v < unat (ivertex_cnt G))"
    {
      fix i
      let ?i = "of_nat i"
      assume "i < unat (ivertex_cnt G) \<and> ?i \<noteq> r"
      then have ii: "?i \<in> verts (abs_IGraph G) \<and> ?i \<noteq> r"
        by (simp add: word_of_nat_less)
      then obtain e where e_assms:
        "e \<in> arcs ?aG"
        "?ap ?i = Some e"
        "head ?aG e = ?i"
        "?an ?i =  ?an (tail ?aG e) + 1"
        "?an ?i < unat (ivertex_cnt G)" using *[OF ii] by auto
      have pi_e: "p ?i = e"
        using e_assms(2) abs_pedge_def Some_abs_pedgeI
        by (cases "?ap ?i") force+
      with e_assms pi_e  Some_abs_pedgeI have
        "p ?i < iedge_cnt G \<and>
         0 \<le> sint (p ?i) \<and>
         snd (iedges G (p ?i)) = ?i \<and>
         n ?i = n (fst (iedges G (p ?i))) + 1 \<and>
         n ?i < ivertex_cnt G \<and>
         n ?i \<noteq> 0"
         by (auto,
             metis Some_abs_pedgeI,
             metis (hide_lams, mono_tags) Suc_eq_plus1 unat_1
                    word_arith_nat_add word_unat.Rep_inverse,
             metis word_less_nat_alt)
    } then have "is_root G r p n \<and>
                parent_num_assms_inv G r p n (unat (ivertex_cnt G))"
    unfolding parent_num_assms_inv_def using isr isr_eq by blast
  }
  hence "?wf \<and> ?is_root \<and> ?pnai
      \<Longrightarrow> is_root G r p n \<and>
        parent_num_assms_inv G r p n (unat (ivertex_cnt G))" by presburger
  moreover
  {
    assume wf: "?wf"
    assume isr: "is_root G r p n"
    assume pna: "parent_num_assms_inv G r p n (unat (ivertex_cnt G))"
    {
      fix v
      assume vG: "v \<in> verts ?aG"
      assume vnr: "v \<noteq> r"
      have uvG: "unat v < unat (ivertex_cnt G)"
        using vG by (simp add: word_less_nat_alt)
      have nv_ne0: "n v \<noteq> 0" using pna isr wf unfolding parent_num_assms_inv_def
        by (metis parent_num_assms_inv_num_ne_0 pna uvG vnr word_less_nat_alt)
      then have *: "
        p v < iedge_cnt G \<and>
        0 \<le> sint (p v) \<and>
        snd (iedges G (p v)) =  v \<and>
        n v = n (fst (iedges G (p v))) + 1 \<and>
        n v < ivertex_cnt G"
        using vnr pna
        unfolding parent_num_assms_inv_def
        by (metis uvG word_unat.Rep_inverse)
      then have 1:
      "\<exists>e. e \<in> arcs ?aG \<and> ?ap v = Some e \<and>
           head ?aG e = v \<and>
           ?an v = ?an (tail ?aG e) + 1"
        using abs_pedge_def linorder_not_less unatSuc2 nv_ne0 by auto
     have 2: "?an v < unat (ivertex_cnt G)"
     using * by (metis o_apply word_less_nat_alt)
     from 1 2 have
     "(\<exists>e. e \<in> arcs ?aG \<and> ?ap v = Some e \<and>
           head ?aG e = v \<and>
           ?an v = ?an (tail ?aG e) + 1) \<and>
      ?an v < unat (ivertex_cnt G)" by blast
   } then have "?is_root \<and> ?pnai" using  isr isr_eq by fast
  }
  hence "?wf \<and> is_root G r p n \<and>
        parent_num_assms_inv G r p n (unat (ivertex_cnt G)) \<Longrightarrow>
        ?is_root \<and> ?pnai" by presburger
  ultimately
    show ?thesis by blast
  qed
ultimately
show  "?thesis G r p n"
  unfolding connected_components_locale_def
  connected_components_locale_axioms_def
  fin_digraph_def fin_digraph_axioms_def
  by auto
qed

lemma cc_num_less_n:
  assumes "connected_components_locale (abs_IGraph G) (unat \<circ>  n) (abs_pedge p) r"
  assumes "v \<in> verts (abs_IGraph G)"
  shows "(unat \<circ> n) v < unat (ivertex_cnt G)"
using connected_components_locale.path_from_root_num[OF assms] path_length
by presburger

lemma connected_components_locale_eq_invariants':
"\<And>G r p n.
  (connected_components_locale (abs_IGraph G) (unat \<circ>  n) (abs_pedge p) r) =
    (wf_digraph (abs_IGraph G) \<and>
    is_root G r p n \<and>
    parent_num_assms_inv G r p n (unat (ivertex_cnt G)))"
    using connected_components_locale_num_eq_invariants' cc_num_less_n by blast

lemma check_connected_spc:
  "\<lbrace> P and
    (\<lambda>s. wf_digraph (abs_IGraph iG) \<and>
         is_graph s iG g \<and>
         is_numm s iG iN n \<and>
         is_pedge s iG iP p)\<rbrace>
  check_connected' g r p n
  \<lbrace> (\<lambda>_ s. P s) And
    (\<lambda>rr s. rr \<noteq> 0 \<longleftrightarrow>
      connected_components_locale (abs_IGraph iG) (unat \<circ>  iN) (abs_pedge iP) r) \<rbrace>!"
  apply (clarsimp simp: check_connected'_def)
  apply (clarsimp simp: connected_components_locale_eq_invariants')
  apply wp
  apply (rule_tac P1=" P and
    (\<lambda>s. wf_digraph (abs_IGraph iG) \<and>
         is_graph s iG g \<and>
         is_numm s iG iN n \<and>
         is_pedge s iG iP p \<and>
         r < ivertex_cnt iG \<and>
         is_root iG r iP iN)"
     in validNF_post_imp[OF _ check_parent_num_spc'])
  unfolding fin_digraph_def fin_digraph_axioms_def
  apply force
   apply wp
  apply wp
  apply (auto simp: check_r'_spc is_root_def)[]
  done

end
end


section \<open>Static data dependence\<close>

theory DataDependence imports "../Basic/DynDataDependence" begin

context CFG_wf begin

definition data_dependence :: "'node \<Rightarrow> 'var \<Rightarrow> 'node \<Rightarrow> bool"
    ("_ influences _ in _" [51,0])
where data_dependences_eq:"n influences V in n' \<equiv> \<exists>as. n influences V in n' via as"

lemma data_dependence_def: "n influences V in n' =
  (\<exists>a' as'. (V \<in> Def n) \<and> (V \<in> Use n') \<and>
                 (n -a'#as'\<rightarrow>* n') \<and> (\<forall>n'' \<in> set (sourcenodes as'). V \<notin> Def n''))"
by(auto simp:data_dependences_eq dyn_data_dependence_def)

end

end