(*
 * @TAG(OTHER_LGPL)
 *)

(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      HoarePartialDef.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

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

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

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

header {* Hoare Logic for Partial Correctness *}
theory HoarePartialDef imports Semantic begin

type_synonym ('s,'p) quadruple = "('s assn \<times> 'p \<times> 's assn \<times> 's assn)"

subsection {* Validity of Hoare Tuples: @{text "\<Gamma>,\<Theta>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"} *}

definition
  valid :: "[('s,'p,'f) body,'f set,'s assn,('s,'p,'f) com,'s assn,'s assn] => bool"
                ("_\<Turnstile>\<^bsub>'/_\<^esub>/ _ _ _,_"  [61,60,1000, 20, 1000,1000] 60)
where
 "\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A \<equiv> \<forall>s t. \<Gamma>\<turnstile>\<langle>c,s\<rangle> \<Rightarrow> t \<longrightarrow> s \<in> Normal ` P \<longrightarrow> t \<notin> Fault ` F
                      \<longrightarrow>  t \<in>  Normal ` Q \<union> Abrupt ` A"

definition
  cvalid::
  "[('s,'p,'f) body,('s,'p) quadruple set,'f set,
      's assn,('s,'p,'f) com,'s assn,'s assn] =>bool"
                ("_,_\<Turnstile>\<^bsub>'/_\<^esub>/ _ _ _,_"  [61,60,60,1000, 20, 1000,1000] 60)
where
 "\<Gamma>,\<Theta>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A \<equiv> (\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P (Call p) Q,A) \<longrightarrow> \<Gamma> \<Turnstile>\<^bsub>/F\<^esub> P c Q,A"

definition
  nvalid :: "[('s,'p,'f) body,nat,'f set,
                's assn,('s,'p,'f) com,'s assn,'s assn] => bool"
                ("_\<Turnstile>_:\<^bsub>'/_\<^esub>/ _ _ _,_"  [61,60,60,1000, 20, 1000,1000] 60)
where
 "\<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A \<equiv> \<forall>s t. \<Gamma>\<turnstile>\<langle>c,s \<rangle> =n\<Rightarrow> t \<longrightarrow> s \<in> Normal ` P \<longrightarrow> t \<notin> Fault ` F
                        \<longrightarrow> t \<in>  Normal ` Q \<union> Abrupt ` A"

definition
  cnvalid::
  "[('s,'p,'f) body,('s,'p) quadruple set,nat,'f set,
     's assn,('s,'p,'f) com,'s assn,'s assn] \<Rightarrow> bool"
                ("_,_\<Turnstile>_:\<^bsub>'/_\<^esub>/ _ _ _,_"  [61,60,60,60,1000, 20, 1000,1000] 60)
where
 "\<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A \<equiv> (\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P (Call p) Q,A) \<longrightarrow> \<Gamma> \<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A"

notation (ascii)
  valid  ("_|='/_/ _ _ _,_"  [61,60,1000, 20, 1000,1000] 60) and
  cvalid  ("_,_|='/_/ _ _ _,_"  [61,60,60,1000, 20, 1000,1000] 60) and
  nvalid  ("_|=_:'/_/ _ _ _,_"  [61,60,60,1000, 20, 1000,1000] 60) and
  cnvalid  ("_,_|=_:'/_/ _ _ _,_"  [61,60,60,60,1000, 20, 1000,1000] 60)

subsection {*Properties of Validity *}

lemma valid_iff_nvalid: "\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A = (\<forall>n. \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A)"
  apply (simp only: valid_def nvalid_def exec_iff_execn )
  apply (blast dest: exec_final_notin_to_execn)
  done

lemma cnvalid_to_cvalid: "(\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A) \<Longrightarrow> \<Gamma>,\<Theta>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"
  apply (unfold cvalid_def cnvalid_def valid_iff_nvalid [THEN eq_reflection])
  apply fast
  done

lemma nvalidI:
 "\<lbrakk>\<And>s t. \<lbrakk>\<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> =n\<Rightarrow> t;s \<in> P; t\<notin> Fault ` F\<rbrakk> \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A\<rbrakk>
  \<Longrightarrow> \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A"
  by (auto simp add: nvalid_def)

lemma validI:
 "\<lbrakk>\<And>s t. \<lbrakk>\<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> \<Rightarrow> t;s \<in> P; t\<notin>Fault ` F\<rbrakk> \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A\<rbrakk>
  \<Longrightarrow> \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"
  by (auto simp add: valid_def)

lemma cvalidI:
 "\<lbrakk>\<And>s t. \<lbrakk>\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P (Call p) Q,A;\<Gamma>\<turnstile>\<langle>c,Normal s\<rangle> \<Rightarrow> t;s \<in> P;t\<notin>Fault ` F\<rbrakk>
          \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"
  by (auto simp add: cvalid_def valid_def)

lemma cvalidD:
 "\<lbrakk>\<Gamma>,\<Theta>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A;\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P (Call p) Q,A;\<Gamma>\<turnstile>\<langle>c,Normal s\<rangle> \<Rightarrow> t;s \<in> P;t\<notin>Fault ` F\<rbrakk>
  \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A"
  by (auto simp add: cvalid_def valid_def)

lemma cnvalidI:
 "\<lbrakk>\<And>s t. \<lbrakk>\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P (Call p) Q,A;
   \<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> =n\<Rightarrow> t;s \<in> P;t\<notin>Fault ` F\<rbrakk>
          \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A"
  by (auto simp add: cnvalid_def nvalid_def)

lemma cnvalidD:
 "\<lbrakk>\<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A;\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P (Call p) Q,A;
   \<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> =n\<Rightarrow> t;s \<in> P;
   t\<notin>Fault ` F\<rbrakk>
  \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A"
  by (auto simp add: cnvalid_def nvalid_def)

lemma nvalid_augment_Faults:
  assumes validn:"\<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A"
  assumes F': "F \<subseteq> F'"
  shows "\<Gamma>\<Turnstile>n:\<^bsub>/F'\<^esub> P c Q,A"
proof (rule nvalidI)
  fix s t
  assume exec: "\<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> =n\<Rightarrow> t"
  assume P: "s \<in> P"
  assume F: "t \<notin> Fault ` F'"
  with F' have "t \<notin> Fault ` F"
    by blast
  with exec P validn
  show "t \<in> Normal ` Q \<union> Abrupt ` A"
    by (auto simp add: nvalid_def)
qed

lemma valid_augment_Faults:
  assumes validn:"\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"
  assumes F': "F \<subseteq> F'"
  shows "\<Gamma>\<Turnstile>\<^bsub>/F'\<^esub> P c Q,A"
proof (rule validI)
  fix s t
  assume exec: "\<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> \<Rightarrow> t"
  assume P: "s \<in> P"
  assume F: "t \<notin> Fault ` F'"
  with F' have "t \<notin> Fault ` F"
    by blast
  with exec P validn
  show "t \<in> Normal ` Q \<union> Abrupt ` A"
    by (auto simp add: valid_def)
qed

lemma nvalid_to_nvalid_strip:
  assumes validn:"\<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A"
  assumes F': "F' \<subseteq> -F"
  shows "strip F' \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A"
proof (rule nvalidI)
  fix s t
  assume exec_strip: "strip F' \<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> =n\<Rightarrow> t"
  assume P: "s \<in> P"
  assume F: "t \<notin> Fault ` F"
  from exec_strip obtain t' where
    exec: "\<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> =n\<Rightarrow> t'" and
    t': "t' \<in> Fault ` (-F') \<longrightarrow> t'=t" "\<not> isFault t' \<longrightarrow> t'=t"
    by (blast dest: execn_strip_to_execn)
  show "t \<in> Normal ` Q \<union> Abrupt ` A"
  proof (cases "t' \<in> Fault ` F")
    case True
    with t' F F' have False
      by blast
    thus ?thesis ..
  next
    case False
    with exec P validn
    have "t' \<in> Normal ` Q \<union> Abrupt ` A"
      by (auto simp add: nvalid_def)
    moreover
    from this t' have "t'=t"
      by auto
    ultimately show ?thesis
      by simp
  qed
qed

lemma valid_to_valid_strip:
  assumes valid:"\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"
  assumes F': "F' \<subseteq> -F"
  shows "strip F' \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"
proof (rule validI)
  fix s t
  assume exec_strip: "strip F' \<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> \<Rightarrow> t"
  assume P: "s \<in> P"
  assume F: "t \<notin> Fault ` F"
  from exec_strip obtain t' where
    exec: "\<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> \<Rightarrow> t'" and
    t': "t' \<in> Fault ` (-F') \<longrightarrow> t'=t" "\<not> isFault t' \<longrightarrow> t'=t"
    by (blast dest: exec_strip_to_exec)
  show "t \<in> Normal ` Q \<union> Abrupt ` A"
  proof (cases "t' \<in> Fault ` F")
    case True
    with t' F F' have False
      by blast
    thus ?thesis ..
  next
    case False
    with exec P valid
    have "t' \<in> Normal ` Q \<union> Abrupt ` A"
      by (auto simp add: valid_def)
    moreover
    from this t' have "t'=t"
      by auto
    ultimately show ?thesis
      by simp
  qed
qed

subsection {* The Hoare Rules: @{text "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"} *}

lemma mono_WeakenContext: "A \<subseteq> B \<Longrightarrow>
        (\<lambda>(P, c, Q, A'). (\<Gamma>, \<Theta>, F, P, c, Q, A') \<in> A) x \<longrightarrow>
        (\<lambda>(P, c, Q, A'). (\<Gamma>, \<Theta>, F, P, c, Q, A') \<in> B) x"
apply blast
done

inductive "hoarep"::"[('s,'p,'f) body,('s,'p) quadruple set,'f set,
    's assn,('s,'p,'f) com, 's assn,'s assn] => bool"
    ("(3_,_/\<turnstile>\<^bsub>'/_ \<^esub>(_/ (_)/ _,/_))" [60,60,60,1000,20,1000,1000]60)
  for \<Gamma>::"('s,'p,'f) body"
where
  Skip: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> Q Skip Q,A"

| Basic: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. f s \<in> Q} (Basic f) Q,A"

| Spec: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. (\<forall>t. (s,t) \<in> r \<longrightarrow> t \<in> Q) \<and> (\<exists>t. (s,t) \<in> r)} (Spec r) Q,A"

| Seq: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c\<^sub>1 R,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c\<^sub>2 Q,A\<rbrakk>
        \<Longrightarrow>
        \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Seq c\<^sub>1 c\<^sub>2) Q,A"

| Cond: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P \<inter> b) c\<^sub>1 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P \<inter> - b) c\<^sub>2 Q,A\<rbrakk>
         \<Longrightarrow>
         \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Cond b c\<^sub>1 c\<^sub>2) Q,A"

| While: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P \<inter> b) c P,A
          \<Longrightarrow>
          \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (While b c) (P \<inter> - b),A"

| Guard: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (g \<inter> P) c Q,A
          \<Longrightarrow>
          \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (g \<inter> P) (Guard f g c) Q,A"

| Guarantee: "\<lbrakk>f \<in> F; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (g \<inter> P) c Q,A\<rbrakk>
              \<Longrightarrow>
              \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Guard f g c) Q,A"

| CallRec:
  "\<lbrakk>(P,p,Q,A) \<in> Specs;
    \<forall>(P,p,Q,A) \<in> Specs. p \<in> dom \<Gamma> \<and> \<Gamma>,\<Theta>\<union>Specs\<turnstile>\<^bsub>/F\<^esub> P (the (\<Gamma> p)) Q,A \<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Call p) Q,A"

| DynCom:
      "\<forall>s \<in> P. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (c s) Q,A
      \<Longrightarrow>
      \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (DynCom c) Q,A"

| Throw: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> A Throw Q,A"

| Catch: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c\<^sub>1 Q,R; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c\<^sub>2 Q,A\<rbrakk> \<Longrightarrow>  \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P Catch c\<^sub>1 c\<^sub>2 Q,A"

| Conseq: "\<forall>s \<in> P. \<exists>P' Q' A'. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' c Q',A' \<and> s \<in> P' \<and> Q' \<subseteq> Q \<and> A' \<subseteq> A
           \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"

| Asm: "\<lbrakk>(P,p,Q,A) \<in> \<Theta>\<rbrakk>
         \<Longrightarrow>
         \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Call p) Q,A"

| ExFalso: "\<lbrakk>\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A; \<not> \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
  -- {* This is a hack rule that enables us to derive completeness for
        an arbitrary context @{text "\<Theta>"}, from completeness for an empty context.*}

text {* Does not work, because of rule ExFalso, the context @{text "\<Theta>"} is to blame.
 A weaker version with empty context can be derived from soundness
 and completeness later on. *}
lemma hoare_strip_\<Gamma>:
  assumes deriv: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P p Q,A"
  shows "strip (-F) \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P p Q,A"
using deriv
proof induct
  case Skip thus ?case by (iprover intro: hoarep.Skip)
next
  case Basic thus ?case by (iprover intro: hoarep.Basic)
next
  case Spec thus ?case by (iprover intro: hoarep.Spec)
next
  case Seq thus ?case by (iprover intro: hoarep.Seq)
next
  case Cond thus ?case by (iprover intro: hoarep.Cond)
next
  case While thus ?case by (iprover intro: hoarep.While)
next
  case Guard thus ?case by (iprover intro: hoarep.Guard)
(*next
  case CallSpec thus ?case by (iprover intro: hoarep.CallSpec)
next
  case (CallRec A Abr Abr' Init P Post Pre Procs Q R Result Return Z \<Gamma> \<Theta> init p
         result return )
  from CallRec.hyps
  have "\<forall>p\<in>Procs. \<forall>Z. (strip \<Gamma>),\<Theta> \<union>
             (\<Union>\<^bsub>p\<in>Procs\<^esub>
                 \<Union>\<^bsub>Z\<^esub> {(Pre p Z, Call (Init p) p (Return p) (Result p),
                      Post p Z, Abr p Z)})\<turnstile>
            (Pre p Z) (the (\<Gamma> p)) (R p Z),(Abr' p Z)" by blast
  hence "\<forall>p\<in>Procs. \<forall>Z. (strip \<Gamma>),\<Theta> \<union>
             (\<Union>\<^bsub>p\<in>Procs\<^esub>
                 \<Union>\<^bsub>Z\<^esub> {(Pre p Z, Call (Init p) p (Return p) (Result p),
                      Post p Z, Abr p Z)})\<turnstile>
            (Pre p Z) (the ((strip \<Gamma>) p)) (R p Z),(Abr' p Z)"
    by (auto intro: hoarep.StripI)
  then show ?case
    apply -
    apply (rule hoarep.CallRec)
    apply (assumption | simp only:dom_strip)+
    done*)
next
  case DynCom
  thus ?case
    by - (rule hoarep.DynCom,best  elim!: ballE exE)
next
  case Throw thus ?case by (iprover intro: hoarep.Throw)
next
  case Catch thus ?case by (iprover intro: hoarep.Catch)
(*next
  case CONSEQ thus ?case apply (auto intro: hoarep.CONSEQ)*)
next
  case Asm thus ?case by (iprover intro: hoarep.Asm)
next
  case ExFalso
  thus ?case
    oops

lemma hoare_augment_context:
  assumes deriv: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P p Q,A"
  shows "\<And>\<Theta>'. \<Theta> \<subseteq> \<Theta>' \<Longrightarrow> \<Gamma>,\<Theta>'\<turnstile>\<^bsub>/F\<^esub> P p Q,A"
using deriv
proof (induct)
  case CallRec
  case (CallRec P p Q A Specs \<Theta> F \<Theta>')
  from CallRec.prems
  have "\<Theta>\<union>Specs
       \<subseteq> \<Theta>'\<union>Specs"
    by blast
  with CallRec.hyps (2)
  have "\<forall>(P,p,Q,A)\<in>Specs.  p \<in> dom \<Gamma> \<and> \<Gamma>,\<Theta>'\<union>Specs \<turnstile>\<^bsub>/F\<^esub> P  (the (\<Gamma> p)) Q,A"
    by fastforce

  with CallRec show ?case by - (rule hoarep.CallRec)
next
  case DynCom thus ?case by (blast intro: hoarep.DynCom)
next
  case (Conseq P \<Theta> F c Q A \<Theta>')
  from Conseq
  have "\<forall>s \<in> P.
         (\<exists>P' Q' A'. \<Gamma>,\<Theta>' \<turnstile>\<^bsub>/F\<^esub> P' c Q',A' \<and> s \<in> P' \<and> Q' \<subseteq> Q \<and> A' \<subseteq> A)"
    by blast
  with Conseq show ?case by - (rule hoarep.Conseq)
next
  case (ExFalso \<Theta> F P c Q A \<Theta>')
  have valid_ctxt: "\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A" "\<Theta> \<subseteq> \<Theta>'" by fact+
  hence "\<forall>n. \<Gamma>,\<Theta>'\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A"
    by (simp add: cnvalid_def) blast
  moreover have invalid: "\<not> \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"  by fact
  ultimately show ?case
    by (rule hoarep.ExFalso)
qed (blast intro: hoarep.intros)+

subsection {* Some Derived Rules *}

lemma  Conseq': "\<forall>s. s \<in> P \<longrightarrow>
            (\<exists>P' Q' A'.
              (\<forall> Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) c (Q' Z),(A' Z)) \<and>
                    (\<exists>Z. s \<in> P' Z \<and> (Q' Z \<subseteq> Q) \<and> (A' Z \<subseteq> A)))
           \<Longrightarrow>
           \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
apply (rule Conseq)
apply (rule ballI)
apply (erule_tac x=s in allE)
apply (clarify)
apply (rule_tac x="P' Z" in exI)
apply (rule_tac x="Q' Z" in exI)
apply (rule_tac x="A' Z" in exI)
apply blast
done

lemma conseq:"\<lbrakk>\<forall>Z. \<Gamma>,\<Theta> \<turnstile>\<^bsub>/F\<^esub> (P' Z) c (Q' Z),(A' Z);
              \<forall>s. s \<in> P \<longrightarrow> (\<exists> Z. s\<in>P' Z \<and> (Q' Z \<subseteq> Q) \<and> (A' Z \<subseteq> A))\<rbrakk>
              \<Longrightarrow>
              \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
  by (rule Conseq) blast

theorem conseqPrePost [trans]:
  "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' c Q',A' \<Longrightarrow> P \<subseteq> P' \<Longrightarrow>  Q' \<subseteq> Q \<Longrightarrow> A' \<subseteq> A \<Longrightarrow>  \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
  by (rule conseq [where ?P'="\<lambda>Z. P'" and ?Q'="\<lambda>Z. Q'"]) auto

lemma conseqPre [trans]: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' c Q,A \<Longrightarrow> P \<subseteq> P' \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
by (rule conseq) auto

lemma conseqPost [trans]: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q',A' \<Longrightarrow> Q' \<subseteq> Q \<Longrightarrow> A' \<subseteq> A
 \<Longrightarrow>   \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
  by (rule conseq) auto

lemma CallRec':
  "\<lbrakk>p\<in>Procs; Procs \<subseteq> dom \<Gamma>;
   \<forall>p\<in>Procs.
    \<forall>Z. \<Gamma>,\<Theta> \<union> (\<Union>p\<in>Procs. \<Union>Z. {((P p Z),p,Q p Z,A p Z)})
        \<turnstile>\<^bsub>/F\<^esub> (P p Z) (the (\<Gamma> p)) (Q p Z),(A p Z)\<rbrakk>
   \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P p Z) (Call p) (Q p Z),(A p Z)"
apply (rule CallRec [where Specs="\<Union>p\<in>Procs. \<Union>Z. {((P p Z),p,Q p Z,A p Z)}"])
apply  blast
apply blast
done

end


(*  Title:      HOL/Imperative_HOL/Heap.thy
    Author:     John Matthews, Galois Connections; Alexander Krauss, TU Muenchen
*)

section \<open>A polymorphic heap based on cantor encodings\<close>

theory Heap
imports Main "~~/src/HOL/Library/Countable"
begin

subsection \<open>Representable types\<close>

text \<open>The type class of representable types\<close>

class heap = typerep + countable

instance unit :: heap ..

instance bool :: heap ..

instance nat :: heap ..

instance prod :: (heap, heap) heap ..

instance sum :: (heap, heap) heap ..

instance list :: (heap) heap ..

instance option :: (heap) heap ..

instance int :: heap ..

instance String.literal :: heap ..

instance typerep :: heap ..

subsection \<open>A polymorphic heap with dynamic arrays and references\<close>

text \<open>
  References and arrays are developed in parallel,
  but keeping them separate makes some later proofs simpler.
\<close>

type_synonym addr = nat \<comment> "untyped heap references"
type_synonym heap_rep = nat \<comment> "representable values"

record heap =
  arrays :: "typerep \<Rightarrow> addr \<Rightarrow> heap_rep list"
  refs :: "typerep \<Rightarrow> addr \<Rightarrow> heap_rep"
  lim  :: addr

definition empty :: heap where
  "empty = \<lparr>arrays = (\<lambda>_ _. []), refs = (\<lambda>_ _. 0), lim = 0\<rparr>"

datatype 'a array = Array addr \<comment> "note the phantom type 'a"
datatype 'a ref = Ref addr \<comment> "note the phantom type 'a"

primrec addr_of_array :: "'a array \<Rightarrow> addr" where
  "addr_of_array (Array x) = x"

primrec addr_of_ref :: "'a ref \<Rightarrow> addr" where
  "addr_of_ref (Ref x) = x"

lemma addr_of_array_inj [simp]:
  "addr_of_array a = addr_of_array a' \<longleftrightarrow> a = a'"
  by (cases a, cases a') simp_all

lemma addr_of_ref_inj [simp]:
  "addr_of_ref r = addr_of_ref r' \<longleftrightarrow> r = r'"
  by (cases r, cases r') simp_all

instance array :: (type) countable
  by (rule countable_classI [of addr_of_array]) simp

instance ref :: (type) countable
  by (rule countable_classI [of addr_of_ref]) simp

text \<open>Syntactic convenience\<close>

setup \<open>
  Sign.add_const_constraint (@{const_name Array}, SOME @{typ "nat \<Rightarrow> 'a::heap array"})
  #> Sign.add_const_constraint (@{const_name Ref}, SOME @{typ "nat \<Rightarrow> 'a::heap ref"})
  #> Sign.add_const_constraint (@{const_name addr_of_array}, SOME @{typ "'a::heap array \<Rightarrow> nat"})
  #> Sign.add_const_constraint (@{const_name addr_of_ref}, SOME @{typ "'a::heap ref \<Rightarrow> nat"})
\<close>

hide_const (open) empty

end


(*<*)
(*
 * Copyright 2015, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory CIMP_vcg
imports
  CIMP_lang
begin

(*>*)
section\<open> State-based invariants \label{sec:cimp-invariants} \<close>

text\<open>

We provide a simple-minded verification condition generator (VCG) for this language, providing
support for establishing state-based invariants. It is just one way of reasoning about CIMP programs
and is proven sound wrt to the CIMP semantics.

Our approach follows \<^citet>\<open>"DBLP:journals/acta/Lamport80" and "DBLP:journals/toplas/LamportS84"\<close>
(and the later \<^citet>\<open>"Lamport:2002"\<close>) and closely
related work by \<^citet>\<open>"AptFrancezDeRoever:1980"\<close>,
\<^citet>\<open>"CousotCousot:1980"\<close> and \<^citet>\<open>"DBLP:journals/acta/LevinG81"\<close>, who suggest the
incorporation of a history variable. \<^citet>\<open>"CousotCousot:1980"\<close> apparently contains a completeness proof.
Lamport mentions that this technique was well-known in the mid-80s
when he proposed the use of prophecy variables\footnote{@{url
"https://lamport.azurewebsites.net/pubs/pubs.html"}}. See also \<^citet>\<open>"deRoeverEtAl:2001"\<close> for an extended discussion of
some of this.

\<close>

declare small_step.intros[intro]

inductive_cases small_step_inv:
  "(\<lbrace>l\<rbrace> Request action val # cs, ls) \<rightarrow>\<^bsub>a\<^esub> s'"
  "(\<lbrace>l\<rbrace> Response action # cs, ls) \<rightarrow>\<^bsub>a\<^esub> s'"
  "(\<lbrace>l\<rbrace> LocalOp R # cs, ls) \<rightarrow>\<^bsub>a\<^esub> s'"
  "(\<lbrace>l\<rbrace> IF b THEN c FI # cs, ls) \<rightarrow>\<^bsub>a\<^esub> s'"
  "(\<lbrace>l\<rbrace> IF b THEN c1 ELSE c2 FI # cs, ls) \<rightarrow>\<^bsub>a\<^esub> s'"
  "(\<lbrace>l\<rbrace> WHILE b DO c OD # cs, ls) \<rightarrow>\<^bsub>a\<^esub> s'"
  "(LOOP DO c OD # cs, ls) \<rightarrow>\<^bsub>a\<^esub> s'"

lemma small_step_stuck:
  "\<not> ([], s) \<rightarrow>\<^bsub>\<alpha>\<^esub> c'"
by (auto elim: small_step.cases)

declare system_step.intros[intro]

text\<open>

By default we ask the simplifier to rewrite @{const "atS"} using
ambient @{const "AT"} information.

\<close>

lemma atS_state_weak_cong[cong]:
  "AT s p = AT s' p \<Longrightarrow> atS p ls s \<longleftrightarrow> atS p ls s'"
by (auto simp: atS_def)

text\<open>

We provide an incomplete set of basic rules for label sets.

\<close>

lemma atS_simps:
  "\<not>atS p {} s"
  "atS p {l} s \<longleftrightarrow> at p l s"
  "\<lbrakk>at p l s; l \<in> ls\<rbrakk> \<Longrightarrow> atS p ls s"
  "(\<forall>l. at p l s \<longrightarrow> l \<notin> ls) \<Longrightarrow> \<not>atS p ls s"
by (auto simp: atS_def)

lemma atS_mono:
  "\<lbrakk>atS p ls s; ls \<subseteq> ls'\<rbrakk> \<Longrightarrow> atS p ls' s"
by (auto simp: atS_def)

lemma atS_un:
  "atS p (l \<union> l') s \<longleftrightarrow> atS p l s \<or> atS p l' s"
by (auto simp: atS_def)

lemma atLs_disj_union[simp]:
  "(atLs p label0 \<^bold>\<or> atLs p label1) = atLs p (label0 \<union> label1)"
unfolding atLs_def by simp

lemma atLs_insert_disj:
  "atLs p (insert l label0) = (atL p l \<^bold>\<or> atLs p label0)"
by simp

lemma small_step_terminated:
  "s \<rightarrow>\<^bsub>x\<^esub> s' \<Longrightarrow> atCs (fst s) = {} \<Longrightarrow> atCs (fst s') = {}"
by (induct pred: small_step) auto

lemma atC_not_empty:
  "atC c \<noteq> {}"
by (induct c) auto

lemma atCs_empty:
  "atCs cs = {} \<longleftrightarrow> cs = []"
by (induct cs) (auto simp: atC_not_empty)

lemma terminated_no_commands:
  assumes "terminated p sh"
  shows "\<exists>s. GST sh p = ([], s)"
using assms unfolding atLs_def AT_def by (metis atCs_empty prod.collapse singletonD)

lemma terminated_GST_stable:
  assumes "system_step q sh' sh"
  assumes "terminated p sh"
  shows "GST sh p = GST sh' p"
using assms by (auto dest!: terminated_no_commands simp: small_step_stuck elim!: system_step.cases)

lemma terminated_stable:
  assumes "system_step q sh' sh"
  assumes "terminated p sh"
  shows "terminated p sh'"
using assms unfolding atLs_def AT_def
by (fastforce split: if_splits prod.splits
               dest: small_step_terminated
              elim!: system_step.cases)

lemma system_step_pls_nonempty:
  assumes "system_step pls sh' sh"
  shows "pls \<noteq> {}"
using assms by cases simp_all

lemma system_step_no_change:
  assumes "system_step ps sh' sh"
  assumes "p \<notin> ps"
  shows "GST sh' p = GST sh p"
using assms by cases simp_all

lemma initial_stateD:
  assumes "initial_state sys s"
  shows "AT (\<lparr>GST = s, HST = []\<rparr>) = atC \<circ> PGMs sys \<and> INIT sys (\<lparr>GST = s, HST = []\<rparr>)\<down> \<and> (\<forall>p l. \<not>taken p l \<lparr>GST = s, HST = []\<rparr>)"
using assms unfolding initial_state_def split_def o_def LST_def AT_def taken_def by simp

lemma initial_states_initial[iff]:
  assumes "initial_state sys s"
  shows "at p l (\<lparr>GST = s, HST = []\<rparr>) \<longleftrightarrow> l \<in> atC (PGMs sys p)"
using assms unfolding initial_state_def split_def AT_def by simp

definition
  reachable_state :: "('answer, 'location, 'proc, 'question, 'state, 'ext) pre_system_ext
                    \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) state_pred"
where
  "reachable_state sys s \<longleftrightarrow> (\<exists>\<sigma> i. prerun sys \<sigma> \<and> \<sigma> i = s)"

lemma reachable_stateE:
  assumes "reachable_state sys sh"
  assumes "\<And>\<sigma> i. prerun sys \<sigma> \<Longrightarrow> P (\<sigma> i)"
  shows "P sh"
using assms unfolding reachable_state_def by blast

lemma prerun_reachable_state:
  assumes "prerun sys \<sigma>"
  shows "reachable_state sys (\<sigma> i)"
using assms unfolding prerun_def LTL.defs system_step_reflclp_def reachable_state_def by auto

lemma reachable_state_induct[consumes 1, case_names init LocalStep CommunicationStep, induct set: reachable_state]:
  assumes r: "reachable_state sys sh"
  assumes i: "\<And>s. initial_state sys s \<Longrightarrow> P \<lparr>GST = s, HST = []\<rparr>"
  assumes l: "\<And>sh ls' p. \<lbrakk>reachable_state sys sh; P sh; GST sh p \<rightarrow>\<^bsub>\<tau>\<^esub> ls'\<rbrakk> \<Longrightarrow> P \<lparr>GST = (GST sh)(p := ls'), HST = HST sh\<rparr>"
  assumes c: "\<And>sh ls1' ls2' p1 p2 \<alpha> \<beta>.
                 \<lbrakk>reachable_state sys sh; P sh;
                 GST sh p1 \<rightarrow>\<^bsub>\<guillemotleft>\<alpha>, \<beta>\<guillemotright>\<^esub> ls1'; GST sh p2 \<rightarrow>\<^bsub>\<guillemotright>\<alpha>, \<beta>\<guillemotleft>\<^esub> ls2'; p1 \<noteq> p2 \<rbrakk>
                    \<Longrightarrow> P \<lparr>GST = (GST sh)(p1 := ls1', p2 := ls2'), HST = HST sh @ [(\<alpha>, \<beta>)]\<rparr>"
  shows "P sh"
using r
proof(rule reachable_stateE)
  fix \<sigma> i assume "prerun sys \<sigma>" show "P (\<sigma> i)"
  proof(induct i)
    case 0 from \<open>prerun sys \<sigma>\<close> show ?case
      unfolding prerun_def by (metis (full_types) i old.unit.exhaust system_state.surjective)
  next
    case (Suc i) with \<open>prerun sys \<sigma>\<close> show ?case
unfolding prerun_def LTL.defs system_step_reflclp_def reachable_state_def
apply clarsimp
apply (drule_tac x=i in spec)
apply (erule disjE; clarsimp)
apply (erule system_step.cases; clarsimp)
 apply (metis (full_types) \<open>prerun sys \<sigma>\<close> l old.unit.exhaust prerun_reachable_state system_state.surjective)
apply (metis (full_types) \<open>prerun sys \<sigma>\<close> c old.unit.exhaust prerun_reachable_state system_state.surjective)
done
  qed
qed

lemma prerun_valid_TrueI:
  shows "sys \<Turnstile>\<^bsub>pre\<^esub> \<langle>True\<rangle>"
unfolding prerun_valid_def by simp

lemma prerun_valid_conjI:
  assumes "sys \<Turnstile>\<^bsub>pre\<^esub> P"
  assumes "sys \<Turnstile>\<^bsub>pre\<^esub> Q"
  shows "sys \<Turnstile>\<^bsub>pre\<^esub> P \<^bold>\<and> Q"
using assms unfolding prerun_valid_def always_def by simp

lemma valid_prerun_lift:
  assumes "sys \<Turnstile>\<^bsub>pre\<^esub> I"
  shows "sys \<Turnstile> \<box>\<lceil>I\<rceil>"
using assms unfolding prerun_valid_def valid_def run_def by blast

lemma prerun_valid_induct:
  assumes "\<And>\<sigma>. prerun sys \<sigma> \<Longrightarrow> \<lceil>I\<rceil> \<sigma>"
  assumes "\<And>\<sigma>. prerun sys \<sigma> \<Longrightarrow> (\<lceil>I\<rceil> \<^bold>\<hookrightarrow> (\<circle>\<lceil>I\<rceil>)) \<sigma>"
  shows "sys \<Turnstile>\<^bsub>pre\<^esub> I"
unfolding prerun_valid_def using assms by (simp add: always_induct)

lemma prerun_validI:
  assumes "\<And>s. reachable_state sys s \<Longrightarrow> I s"
  shows "sys \<Turnstile>\<^bsub>pre\<^esub> I"
unfolding prerun_valid_def using assms by (simp add: alwaysI prerun_reachable_state)

lemma prerun_validE:
  assumes "reachable_state sys s"
  assumes "sys \<Turnstile>\<^bsub>pre\<^esub> I"
  shows "I s"
using assms unfolding prerun_valid_def
by (metis alwaysE reachable_stateE suffix_state_prop)

subsubsection\<open>Relating reachable states to the initial programs \label{sec:cimp-decompose-small-step}\<close>

text\<open>

To usefully reason about the control locations presumably embedded in
the single global invariant, we need to link the programs we have in
reachable state \<open>s\<close> to the programs in the initial states. The
\<open>fragments\<close> function decomposes the program into statements
that can be directly executed (\S\ref{sec:cimp-decompose}). We also
compute the locations we could be at after executing that statement as
a function of the process's local state.

Eliding the bodies of \<open>IF\<close> and \<open>WHILE\<close> statements
yields smaller (but equivalent) proof obligations.

\<close>

type_synonym  ('answer, 'location, 'question, 'state) loc_comp
  = "'state \<Rightarrow> 'location set"

fun lconst :: "'location set \<Rightarrow> ('answer, 'location, 'question, 'state) loc_comp" where
  "lconst lp s = lp"

definition lcond :: "'location set \<Rightarrow> 'location set \<Rightarrow> 'state bexp
                   \<Rightarrow> ('answer, 'location, 'question, 'state) loc_comp" where
  "lcond lp lp' b s = (if b s then lp else lp')"

lemma lcond_split:
  "Q (lcond lp lp' b s) \<longleftrightarrow> (b s \<longrightarrow> Q lp) \<and> (\<not>b s \<longrightarrow> Q lp')"
unfolding lcond_def by (simp split: if_splits)

lemma lcond_split_asm:
  "Q (lcond lp lp' b s) \<longleftrightarrow> \<not> ((b s \<and> \<not>Q lp) \<or> (\<not>b s \<and> \<not> Q lp'))"
unfolding lcond_def by (simp split: if_splits)

lemmas lcond_splits = lcond_split lcond_split_asm

fun
  fragments :: "('answer, 'location, 'question, 'state) com
              \<Rightarrow> 'location set
              \<Rightarrow> ( ('answer, 'location, 'question, 'state) com
               \<times> ('answer, 'location, 'question, 'state) loc_comp ) set"
where
  "fragments (\<lbrace>l\<rbrace> IF b THEN c FI) aft
       = { (\<lbrace>l\<rbrace> IF b THEN c' FI, lcond (atC c) aft b) |c'. True }
        \<union> fragments c aft"
| "fragments (\<lbrace>l\<rbrace> IF b THEN c1 ELSE c2 FI) aft
       = { (\<lbrace>l\<rbrace> IF b THEN c1' ELSE c2' FI, lcond (atC c1) (atC c2) b) |c1' c2'. True }
        \<union> fragments c1 aft \<union> fragments c2 aft"
| "fragments (LOOP DO c OD) aft = fragments c (atC c)"
| "fragments (\<lbrace>l\<rbrace> WHILE b DO c OD) aft
       =  fragments c {l} \<union> { (\<lbrace>l\<rbrace> WHILE b DO c' OD, lcond (atC c) aft b) |c'. True }"
| "fragments (c1;; c2) aft = fragments c1 (atC c2) \<union> fragments c2 aft"
| "fragments (c1 \<oplus> c2) aft = fragments c1 aft \<union> fragments c2 aft"
| "fragments c aft = { (c, lconst aft) }"

fun
  fragmentsL :: "('answer, 'location, 'question, 'state) com list
               \<Rightarrow> ( ('answer, 'location, 'question, 'state) com
                 \<times> ('answer, 'location, 'question, 'state) loc_comp ) set"
where
  "fragmentsL [] = {}"
| "fragmentsL [c] = fragments c {}"
| "fragmentsL (c # c' # cs) = fragments c (atC c') \<union> fragmentsL (c' # cs)"

abbreviation
  fragmentsLS :: "('answer, 'location, 'question, 'state) local_state
               \<Rightarrow> ( ('answer, 'location, 'question, 'state) com
                 \<times> ('answer, 'location, 'question, 'state) loc_comp ) set"
where
  "fragmentsLS s \<equiv> fragmentsL (cPGM s)"

text\<open>

We show that taking system steps preserves fragments.

\<close>

lemma small_step_fragmentsLS:
  assumes "s \<rightarrow>\<^bsub>\<alpha>\<^esub> s'"
  shows "fragmentsLS s' \<subseteq> fragmentsLS s"
using assms by induct (case_tac [!] cs, auto)

lemma reachable_state_fragmentsLS:
  assumes "reachable_state sys sh"
  shows "fragmentsLS (GST sh p) \<subseteq> fragments (PGMs sys p) {}"
using assms
by (induct rule: reachable_state_induct)
   (auto simp: initial_state_def dest: subsetD[OF small_step_fragmentsLS])

inductive
  basic_com :: "('answer, 'location, 'question, 'state) com \<Rightarrow> bool"
where
  "basic_com (\<lbrace>l\<rbrace> Request action val)"
| "basic_com (\<lbrace>l\<rbrace> Response action)"
| "basic_com (\<lbrace>l\<rbrace> LocalOp R)"
| "basic_com (\<lbrace>l\<rbrace> IF b THEN c FI)"
| "basic_com (\<lbrace>l\<rbrace> IF b THEN c1 ELSE c2 FI)"
| "basic_com (\<lbrace>l\<rbrace> WHILE b DO c OD)"

lemma fragments_basic_com:
  assumes "(c', aft') \<in> fragments c aft"
  shows "basic_com c'"
using assms by (induct c arbitrary: aft) (auto intro: basic_com.intros)

lemma fragmentsL_basic_com:
  assumes "(c', aft') \<in> fragmentsL cs"
  shows "basic_com c'"
using assms
apply (induct cs)
 apply simp
apply (case_tac cs)
 apply (auto simp: fragments_basic_com)
done

text\<open>

To reason about system transitions we need to identify which basic
statement gets executed next. To that end we factor out the recursive
cases of the @{term "small_step"} semantics into \emph{contexts},
which isolate the \<open>basic_com\<close> commands with immediate
externally-visible behaviour. Note that non-determinism means that
more than one \<open>basic_com\<close> can be enabled at a time.

The representation of evaluation contexts follows \<^citet>\<open>"DBLP:journals/jar/Berghofer12"\<close>. This style of
operational semantics was originated by \<^citet>\<open>"FelleisenHieb:1992"\<close>.

\<close>

type_synonym ('answer, 'location, 'question, 'state) ctxt
  = "(('answer, 'location, 'question, 'state) com \<Rightarrow> ('answer, 'location, 'question, 'state) com)
   \<times> (('answer, 'location, 'question, 'state) com \<Rightarrow> ('answer, 'location, 'question, 'state) com list)"

inductive_set
  ctxt :: "('answer, 'location, 'question, 'state) ctxt set"
where
  C_Hole: "(id, \<langle>[]\<rangle>) \<in> ctxt"
| C_Loop: "(E, fctxt) \<in> ctxt \<Longrightarrow> (\<lambda>c1. LOOP DO E c1 OD, \<lambda>c1. fctxt c1 @ [LOOP DO E c1 OD]) \<in> ctxt"
| C_Seq: "(E, fctxt) \<in> ctxt \<Longrightarrow> (\<lambda>c1. E c1;; c2, \<lambda>c1. fctxt c1 @ [c2]) \<in> ctxt"
| C_Choose1: "(E, fctxt) \<in> ctxt \<Longrightarrow> (\<lambda>c1. E c1 \<oplus> c2, fctxt) \<in> ctxt"
| C_Choose2: "(E, fctxt) \<in> ctxt \<Longrightarrow> (\<lambda>c2. c1 \<oplus> E c2, fctxt) \<in> ctxt"

text\<open>

We can decompose a small step into a context and a @{const "basic_com"}.

\<close>

fun
  decompose_com :: "('answer, 'location, 'question, 'state) com
                      \<Rightarrow> ( ('answer, 'location, 'question, 'state) com
                        \<times> ('answer, 'location, 'question, 'state) ctxt ) set"
where
  "decompose_com (LOOP DO c1 OD) = { (c, \<lambda>t. LOOP DO ictxt t OD, \<lambda>t. fctxt t @ [LOOP DO ictxt t OD]) |c fctxt ictxt. (c, ictxt, fctxt) \<in> decompose_com c1 }"
| "decompose_com (c1;; c2) = { (c, \<lambda>t. ictxt t;; c2, \<lambda>t. fctxt t @ [c2]) |c fctxt ictxt. (c, ictxt, fctxt) \<in> decompose_com c1 }"
| "decompose_com (c1 \<oplus> c2) = { (c, \<lambda>t. ictxt t \<oplus> c2, fctxt) |c fctxt ictxt. (c, ictxt, fctxt) \<in> decompose_com c1 }
                           \<union> { (c, \<lambda>t. c1 \<oplus> ictxt t, fctxt) |c fctxt ictxt. (c, ictxt, fctxt) \<in> decompose_com c2 }"
| "decompose_com c = {(c, id, \<langle>[]\<rangle>)}"

definition
  decomposeLS :: "('answer, 'location, 'question, 'state) local_state
               \<Rightarrow> ( ('answer, 'location, 'question, 'state) com
                 \<times> (('answer, 'location, 'question, 'state) com \<Rightarrow> ('answer, 'location, 'question, 'state) com)
                 \<times> (('answer, 'location, 'question, 'state) com \<Rightarrow> ('answer, 'location, 'question, 'state) com list) ) set"
where
  "decomposeLS s = (case cPGM s of c # _ \<Rightarrow> decompose_com c | _ \<Rightarrow> {})"

lemma ctxt_inj:
  assumes "(E, fctxt) \<in> ctxt"
  assumes "E x = E y"
  shows "x = y"
using assms by (induct set: ctxt) auto

lemma decompose_com_non_empty: "decompose_com c \<noteq> {}"
by (induct c) auto

lemma decompose_com_basic_com:
  assumes "(c', ctxts) \<in> decompose_com c"
  shows "basic_com c'"
using assms by (induct c arbitrary: c' ctxts) (auto intro: basic_com.intros)

lemma decomposeLS_basic_com:
  assumes "(c', ctxts) \<in> decomposeLS s"
  shows "basic_com c'"
using assms unfolding decomposeLS_def by (simp add: decompose_com_basic_com split: list.splits)

lemma decompose_com_ctxt:
  assumes "(c', ctxts) \<in> decompose_com c"
  shows "ctxts \<in> ctxt"
using assms by (induct c arbitrary: c' ctxts) (auto intro: ctxt.intros)

lemma decompose_com_ictxt:
  assumes "(c', ictxt, fctxt) \<in> decompose_com c"
  shows "ictxt c' = c"
using assms by (induct c arbitrary: c' ictxt fctxt) auto

lemma decompose_com_small_step:
  assumes as: "(c' # fctxt c' @ cs, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> s'"
  assumes ds: "(c', ictxt, fctxt) \<in> decompose_com c"
  shows "(c # cs, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> s'"
using decompose_com_ctxt[OF ds] as decompose_com_ictxt[OF ds]
by (induct ictxt fctxt arbitrary: c cs)
   (cases s', fastforce simp: fun_eq_iff dest: ctxt_inj)+

theorem context_decompose:
  "s \<rightarrow>\<^bsub>\<alpha>\<^esub> s' \<longleftrightarrow> (\<exists>(c, ictxt, fctxt) \<in> decomposeLS s.
                     cPGM s = ictxt c # tl (cPGM s)
                   \<and> (c # fctxt c @ tl (cPGM s), cTKN s, cLST s) \<rightarrow>\<^bsub>\<alpha>\<^esub> s'
                   \<and> (\<forall>l\<in>atC c. cTKN s' = Some l))" (is "?lhs = ?rhs")
proof(rule iffI)
  assume ?lhs then show ?rhs
  unfolding decomposeLS_def
  proof(induct rule: small_step.induct)
    case (Choose1 c1 cs s \<alpha> cs' s' c2) then show ?case
      apply clarsimp
      apply (rename_tac c ictxt fctxt)
      apply (rule_tac x="(c, \<lambda>t. ictxt t \<oplus> c2, fctxt)" in bexI)
      apply auto
      done
  next
    case (Choose2 c2 cs s \<alpha> cs' s' c1) then show ?case
      apply clarsimp
      apply (rename_tac c ictxt fctxt)
      apply (rule_tac x="(c, \<lambda>t. c1 \<oplus> ictxt t, fctxt)" in bexI)
      apply auto
      done
  qed fastforce+
next
  assume ?rhs then show ?lhs
    unfolding decomposeLS_def
    by (cases s) (auto split: list.splits dest: decompose_com_small_step)
qed

text\<open>

While we only use this result left-to-right (to decompose a small step
into a basic one), this equivalence shows that we lose no information
in doing so.

Decomposing a compound command preserves @{const \<open>fragments\<close>} too.

\<close>

fun
  loc_compC :: "('answer, 'location, 'question, 'state) com
                            \<Rightarrow> ('answer, 'location, 'question, 'state) com list
                            \<Rightarrow> ('answer, 'location, 'question, 'state) loc_comp"
where
  "loc_compC (\<lbrace>l\<rbrace> IF b THEN c FI) cs = lcond (atC c) (atCs cs) b"
| "loc_compC (\<lbrace>l\<rbrace> IF b THEN c1 ELSE c2 FI) cs = lcond (atC c1) (atC c2) b"
| "loc_compC (LOOP DO c OD) cs = lconst (atC c)"
| "loc_compC (\<lbrace>l\<rbrace> WHILE b DO c OD) cs = lcond (atC c) (atCs cs) b"
| "loc_compC c cs = lconst (atCs cs)"

lemma decompose_fragments:
  assumes "(c, ictxt, fctxt) \<in> decompose_com c0"
  shows "(c, loc_compC c (fctxt c @ cs)) \<in> fragments c0 (atCs cs)"
using assms
proof(induct c0 arbitrary: c ictxt fctxt cs)
  case (Loop c01 c ictxt fctxt cs)
  from Loop.prems Loop.hyps(1)[where cs="ictxt c # cs"] show ?case by (auto simp: decompose_com_ictxt)
next
  case (Seq c01 c02 c ictxt fctxt cs)
  from Seq.prems Seq.hyps(1)[where cs="c02 # cs"] show ?case by auto
qed auto

lemma at_decomposeLS:
  assumes "(c, ictxt, fctxt) \<in> decomposeLS s"
  shows "atC c \<subseteq> atCs (cPGM s)"
using assms unfolding decomposeLS_def by (auto simp: at_decompose split: list.splits)

lemma decomposeLS_fragmentsLS:
  assumes "(c, ictxt, fctxt) \<in> decomposeLS s"
  shows "(c, loc_compC c (fctxt c @ tl (cPGM s))) \<in> fragmentsLS s"
using assms
proof(cases "cPGM s")
  case (Cons d ds)
  with assms decompose_fragments[where cs="ds"] show ?thesis
    by (cases ds) (auto simp: decomposeLS_def)
qed (simp add: decomposeLS_def)

lemma small_step_loc_compC:
  assumes "basic_com c"
  assumes "(c # cs, ls) \<rightarrow>\<^bsub>\<alpha>\<^esub> ls'"
  shows "loc_compC c cs (snd ls) = atCs (cPGM ls')"
using assms by (fastforce elim: basic_com.cases elim!: small_step_inv split: lcond_splits)

text\<open>

The headline result allows us to constrain the initial and final states
of a given small step in terms of the original programs, provided the
initial state is reachable.

\<close>

theorem decompose_small_step:
  assumes "GST sh p \<rightarrow>\<^bsub>\<alpha>\<^esub> ps'"
  assumes "reachable_state sys sh"
  obtains c cs aft
    where "(c, aft) \<in> fragments (PGMs sys p) {}"
      and "atC c \<subseteq> atCs (cPGM (GST sh p))"
      and "aft (cLST (GST sh p)) = atCs (cPGM ps')"
      and "(c # cs, cTKN (GST sh p), cLST (GST sh p)) \<rightarrow>\<^bsub>\<alpha>\<^esub> ps'"
      and "\<forall>l\<in>atC c. cTKN ps' = Some l"
using assms
apply -
apply (frule iffD1[OF context_decompose])
apply clarsimp
apply (frule decomposeLS_fragmentsLS)
apply (frule at_decomposeLS)
apply (frule (1) subsetD[OF reachable_state_fragmentsLS])
apply (frule decomposeLS_basic_com)
apply (frule (1) small_step_loc_compC)
apply simp
done

text\<open>

Reasoning by induction over the reachable states
with @{thm [source] "decompose_small_step"} is quite tedious. We
provide a very simple VCG that generates friendlier local proof
obligations in \S\ref{sec:vcg}.

\<close>

subsection\<open>Simple-minded Hoare Logic/VCG for CIMP \label{sec:vcg}\<close>

text\<open>

\label{sec:cimp-vcg}

We do not develop a proper Hoare logic or full VCG for CIMP: this
machinery merely packages up the subgoals that arise from induction
over the reachable states (\S\ref{sec:cimp-invariants}). This is
somewhat in the spirit of \<^citet>\<open>"Ridge:2009"\<close>.

Note that this approach is not compositional: it consults the original
system to find matching communicating pairs, and \<open>aft\<close>
tracks the labels of possible successor statements. More serious Hoare
logics are provided by \<^citet>\<open>"DBLP:journals/acta/Lamport80" and "DBLP:journals/toplas/LamportS84"
and "CousotCousot89-IC"\<close>.

Intuitively we need to discharge a proof obligation for either @{const
"Request"}s or @{const "Response"}s but not both. Here we choose to
focus on @{const "Request"}s as we expect to have more local
information available about these.

\<close>

inductive
  vcg :: "('answer, 'location, 'proc, 'question, 'state) programs
        \<Rightarrow> 'proc
        \<Rightarrow> ('answer, 'location, 'question, 'state) loc_comp
        \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) state_pred
        \<Rightarrow> ('answer, 'location, 'question, 'state) com
        \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) state_pred
        \<Rightarrow> bool" ("_, _, _ \<turnstile>/ \<lbrace>_\<rbrace>/ _/ \<lbrace>_\<rbrace>" [11,0,0,0,0,0] 11)
where
  "\<lbrakk> \<And>aft' action' s ps' p's' l' \<beta> s' p'.
      \<lbrakk> pre s; (\<lbrace>l'\<rbrace> Response action', aft') \<in> fragments (coms p') {}; p \<noteq> p';
        ps' \<in> val \<beta> (s\<down> p); (p's', \<beta>) \<in> action' (action (s\<down> p)) (s\<down> p');
        at p l s; at p' l' s;
        AT s' = (AT s)(p := aft (s\<down> p), p' := aft' (s\<down> p'));
        s'\<down> = s\<down>(p := ps', p' := p's');
        taken p l s';
        HST s' = HST s @ [(action (s\<down> p), \<beta>)];
        \<forall>p''\<in>-{p,p'}. GST s' p'' = GST s p''
      \<rbrakk> \<Longrightarrow> post s'
   \<rbrakk> \<Longrightarrow> coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> Request action val \<lbrace>post\<rbrace>"
| "\<lbrakk> \<And>s ps' s'.
      \<lbrakk> pre s; ps' \<in> f (s\<down> p);
        at p l s;
        AT s' = (AT s)(p := aft (s\<down> p));
        s'\<down> = s\<down>(p := ps');
        taken p l s';
        HST s' = HST s;
        \<forall>p''\<in>-{p}. GST s' p'' = GST s p''
      \<rbrakk> \<Longrightarrow> post s'
   \<rbrakk> \<Longrightarrow> coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> LocalOp f \<lbrace>post\<rbrace>"
| "\<lbrakk> \<And>s s'.
      \<lbrakk> pre s;
        at p l s;
        AT s' = (AT s)(p := aft (s\<down> p));
        s'\<down> = s\<down>;
        taken p l s';
        HST s' = HST s;
        \<forall>p''\<in>-{p}. GST s' p'' = GST s p''
      \<rbrakk> \<Longrightarrow> post s'
   \<rbrakk> \<Longrightarrow> coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> IF b THEN t FI \<lbrace>post\<rbrace>"
| "\<lbrakk> \<And>s s'.
      \<lbrakk> pre s;
        at p l s;
        AT s' = (AT s)(p := aft (s\<down> p));
        s'\<down> = s\<down>;
        taken p l s';
        HST s' = HST s;
        \<forall>p''\<in>-{p}. GST s' p'' = GST s p''
      \<rbrakk> \<Longrightarrow> post s'
   \<rbrakk> \<Longrightarrow> coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> IF b THEN t ELSE e FI \<lbrace>post\<rbrace>"
| "\<lbrakk> \<And>s s'.
      \<lbrakk> pre s;
        at p l s;
        AT s' = (AT s)(p := aft (s\<down> p));
        s'\<down> = s\<down>;
        taken p l s';
        HST s' = HST s;
        \<forall>p''\<in>-{p}. GST s' p'' = GST s p''
      \<rbrakk> \<Longrightarrow> post s'
   \<rbrakk> \<Longrightarrow> coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> WHILE b DO c OD \<lbrace>post\<rbrace>"
\<comment> \<open>There are no proof obligations for the following commands, but including them makes some basic rules hold (\S\ref{sec:cimp:vcg_rules}):\<close>
| "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> Response action \<lbrace>post\<rbrace>"
| "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> c1 ;; c2 \<lbrace>post\<rbrace>"
| "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> LOOP DO c OD \<lbrace>post\<rbrace>"
| "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> c1 \<oplus> c2 \<lbrace>post\<rbrace>"

text\<open>

We abbreviate invariance with one-sided validity syntax.

\<close>

abbreviation valid_inv ("_, _, _ \<turnstile>/ \<lbrace>_\<rbrace>/ _" [11,0,0,0,0] 11) where
  "coms, p, aft \<turnstile> \<lbrace>I\<rbrace> c \<equiv> coms, p, aft \<turnstile> \<lbrace>I\<rbrace> c \<lbrace>I\<rbrace>"

inductive_cases vcg_inv:
  "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> Request action val \<lbrace>post\<rbrace>"
  "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> LocalOp f \<lbrace>post\<rbrace>"
  "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> IF b THEN t FI \<lbrace>post\<rbrace>"
  "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> IF b THEN t ELSE e FI \<lbrace>post\<rbrace>"
  "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> WHILE b DO c OD \<lbrace>post\<rbrace>"
  "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> LOOP DO c OD \<lbrace>post\<rbrace>"
  "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> Response action \<lbrace>post\<rbrace>"
  "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> c1 ;; c2 \<lbrace>post\<rbrace>"
  "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> Choose c1 c2 \<lbrace>post\<rbrace>"

text\<open>

We tweak @{const "fragments"} by omitting @{const "Response"}s,
yielding fewer obligations

\<close>

fun
  vcg_fragments' :: "('answer, 'location, 'question, 'state) com
               \<Rightarrow> 'location set
               \<Rightarrow> ( ('answer, 'location, 'question, 'state) com
                 \<times> ('answer, 'location, 'question, 'state) loc_comp ) set"
where
  "vcg_fragments' (\<lbrace>l\<rbrace> Response action) aft = {}"
| "vcg_fragments' (\<lbrace>l\<rbrace> IF b THEN c FI) aft
       = vcg_fragments' c aft
       \<union> { (\<lbrace>l\<rbrace> IF b THEN c' FI, lcond (atC c) aft b) |c'. True }"
| "vcg_fragments' (\<lbrace>l\<rbrace> IF b THEN c1 ELSE c2 FI) aft
       = vcg_fragments' c2 aft \<union> vcg_fragments' c1 aft
       \<union> { (\<lbrace>l\<rbrace> IF b THEN c1' ELSE c2' FI, lcond (atC c1) (atC c2) b) |c1' c2'. True }"
| "vcg_fragments' (LOOP DO c OD) aft = vcg_fragments' c (atC c)"
| "vcg_fragments' (\<lbrace>l\<rbrace> WHILE b DO c OD) aft
       = vcg_fragments' c {l} \<union> { (\<lbrace>l\<rbrace> WHILE b DO c' OD, lcond (atC c) aft b) |c'. True }"
| "vcg_fragments' (c1 ;; c2) aft = vcg_fragments' c2 aft \<union> vcg_fragments' c1 (atC c2)"
| "vcg_fragments' (c1 \<oplus> c2) aft = vcg_fragments' c1 aft \<union> vcg_fragments' c2 aft"
| "vcg_fragments' c aft = {(c, lconst aft)}"

abbreviation
  vcg_fragments :: "('answer, 'location, 'question, 'state) com
                  \<Rightarrow> ( ('answer, 'location, 'question, 'state) com
                    \<times> ('answer, 'location, 'question, 'state) loc_comp ) set"
where
  "vcg_fragments c \<equiv> vcg_fragments' c {}"

fun isResponse :: "('answer, 'location, 'question, 'state) com \<Rightarrow> bool" where
  "isResponse (\<lbrace>l\<rbrace> Response action) \<longleftrightarrow> True"
| "isResponse _ \<longleftrightarrow> False"

lemma fragments_vcg_fragments':
  "\<lbrakk> (c, aft) \<in> fragments c' aft'; \<not>isResponse c \<rbrakk> \<Longrightarrow> (c, aft) \<in> vcg_fragments' c' aft'"
by (induct c' arbitrary: aft') auto

lemma vcg_fragments'_fragments:
  "vcg_fragments' c' aft' \<subseteq> fragments c' aft'"
by (induct c' arbitrary: aft') (auto 10 0)

lemma VCG_step:
  assumes V: "\<And>p. \<forall>(c, aft) \<in> vcg_fragments (PGMs sys p). PGMs sys, p, aft \<turnstile> \<lbrace>pre\<rbrace> c \<lbrace>post\<rbrace>"
  assumes S: "system_step p sh' sh"
  assumes R: "reachable_state sys sh"
  assumes P: "pre sh"
  shows "post sh'"
using S
proof cases
  case LocalStep with P show ?thesis
    apply -
    apply (erule decompose_small_step[OF _ R])
    apply (frule fragments_basic_com)
    apply (erule basic_com.cases)
    apply (fastforce dest!: fragments_vcg_fragments' V[rule_format]
                      elim: vcg_inv elim!: small_step_inv
                      simp: LST_def AT_def taken_def fun_eq_iff)+
    done
next
  case CommunicationStep with P show ?thesis
    apply -
    apply (erule decompose_small_step[OF _ R])
    apply (erule decompose_small_step[OF _ R])
    subgoal for c cs aft c' cs' aft'
    apply (frule fragments_basic_com[where c'=c])
    apply (frule fragments_basic_com[where c'=c'])
    apply (elim basic_com.cases; clarsimp elim!: small_step_inv)
    apply (drule fragments_vcg_fragments')
    apply (fastforce dest!: V[rule_format]
                      elim: vcg_inv elim!: small_step_inv
                      simp: LST_def AT_def taken_def fun_eq_iff)+
    done
    done
qed

text\<open>

The user sees the conclusion of \<open>V\<close> for each element of @{const \<open>vcg_fragments\<close>}.

\<close>

lemma VCG_step_inv_stable:
  assumes V: "\<And>p. \<forall>(c, aft) \<in> vcg_fragments (PGMs sys p). PGMs sys, p, aft \<turnstile> \<lbrace>I\<rbrace> c"
  assumes "prerun sys \<sigma>"
  shows "(\<lceil>I\<rceil> \<^bold>\<hookrightarrow> \<circle>\<lceil>I\<rceil>) \<sigma>"
apply (rule alwaysI)
apply clarsimp
apply (rule nextI)
apply clarsimp
using assms(2) unfolding prerun_def
apply clarsimp
apply (erule_tac i=i in alwaysE)
unfolding system_step_reflclp_def
apply clarsimp
apply (erule disjE; clarsimp)
using VCG_step[where pre=I and post=I] V assms(2) prerun_reachable_state
apply blast
done

lemma VCG:
  assumes I: "\<forall>s. initial_state sys s \<longrightarrow> I (\<lparr>GST = s, HST = []\<rparr>)"
  assumes V: "\<And>p. \<forall>(c, aft) \<in> vcg_fragments (PGMs sys p). PGMs sys, p, aft \<turnstile> \<lbrace>I\<rbrace> c"
  shows "sys \<Turnstile>\<^bsub>pre\<^esub> I"
apply (rule prerun_valid_induct)
 apply (clarsimp simp: prerun_def state_prop_def)
 apply (metis (full_types) I old.unit.exhaust system_state.surjective)
using VCG_step_inv_stable[OF V] apply blast
done

lemmas VCG_valid = valid_prerun_lift[OF VCG, of sys I] for sys I
(*<*)

end
(*>*)


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

section "32-Bit Machine Word Setup"

theory Word_Setup_32
imports Word_Enum
begin

text \<open>This theory defines standard platform-specific word size and alignment.\<close>

definition
  word_bits :: nat where
  "word_bits \<equiv> len_of TYPE(32)"

definition
  word_size :: "'a :: numeral" where
  "word_size \<equiv> 4"

lemma word_bits_conv[code]:
  "word_bits = 32" unfolding word_bits_def by simp

lemma word_bits_word_size_conv:
  "word_bits = word_size * 8"
  unfolding word_bits_def word_size_def by simp

end


theory Fibonacci
  imports "../DP_Lifting" "../DP_CRelVS" "../DP_Proof"
begin

  (*
fun fib :: "nat \<Rightarrow> int option" where
  "fib 0 = Some 0"
| "fib (Suc 0) = Some 1"
| "fib (Suc (Suc n)) = (case (fib (Suc n), fib n) of (Some f1, Some f0) \<Rightarrow> Some (f1 + f0) | _ \<Rightarrow> None)"
term 0 (**)
*)

fun fib :: "nat \<Rightarrow> int option" where
  "fib 0 = Some 0"
| "fib (Suc 0) = Some 1"
| "fib (Suc (Suc n)) = case_prod
      (\<lambda>of1 of0. case_option
        None
        (\<lambda>f1. case_option
          None
          (\<lambda>f0. Some (f1 + f0))
          of0)
        of1)
      (Pair (fib (Suc n)) (fib n))"

ML_file \<open>../Transform.ML\<close>
local_setup \<open>
lift_fun NONE;
\<close>

interpretation fib: dp_consistency fib .

lemma fib\<^sub>T_correct:
  "fib.consistentDP fib\<^sub>T"
  by (dp_match induct: fib\<^sub>T.induct simp: fib.simps simp\<^sub>T: fib\<^sub>T.simps)

definition fib\<^sub>T_entry :: "nat \<Rightarrow> int option" where
  "fib\<^sub>T_entry n \<equiv> fst (runState (fib\<^sub>T n) Mapping.empty)"

lemma fib\<^sub>T_entry_correct:
  "fib\<^sub>T_entry = fib"
  unfolding fib\<^sub>T_entry_def using fib.consistentDP_entry[OF fib\<^sub>T_correct] ..

lemma Let_absorb:
  "(let (a, b) = (let (c, d) = x in (p c d, q c d)) in f a b)
 = (let (c, d) = x; (a, b) = (p c d, q c d) in f a b)"
  by (auto simp: Let_def split: prod.splits)

lemma Let_absorb2:
  "(let (a, b) = (let (c, d) = x; (e, f) = y c d in (p c d e f, q c d e f)) in g a b)
 = (let (c, d) = x; (e, f) = y c d; (a, b) = (p c d e f, q c d e f) in g a b)"
  by (auto simp: Let_def split: prod.splits)

lemma Let_unfold_pair:
  "(let (a, b) = (x, y) in f a b) = f x y"
  by (auto simp: Let_def split: prod.splits)

lemma Let_split_pair:
  "(let (a, b) = (x, y) in f a b) = (let a=x; b=y in f a b)"
  by auto

lemma runState_option:
  "runState (case x of None \<Rightarrow> f0 | Some y \<Rightarrow> ifSome f1 y) M
 = (case x of None \<Rightarrow> runState f0 M | Some y \<Rightarrow> runState (ifSome f1 y) M)"
  by (auto split: option.split)

definition "runState' \<equiv> runState"

schematic_goal fib\<^sub>T_simp1:
  "runState (fib\<^sub>T 0) M = ?x"
  apply (subst fib\<^sub>T.simps(1))
  apply (subst checkmem_def)
  apply (subst bind_def)
  apply (subst state.sel)
  apply (subst get_def)
  apply (subst state.sel)
  apply (subst Let_unfold_pair)
  apply (subst bind_def)
  apply (subst return_def)
  apply (subst state.sel)
  apply (subst Let_unfold_pair)
  apply (subst bind_def)
  apply (subst get_def)
  apply (subst state.sel)
  apply (subst state.sel)
  apply (subst Let_unfold_pair)
  apply (subst bind_def)
  apply (subst put_def)
  apply (subst state.sel)
  apply (subst state.sel)
  apply (subst Let_unfold_pair)
  apply (subst return_def)
  apply (subst state.sel)
  apply (subst runState_option)
  apply (subst state.sel)
  apply (subst return_def)
  apply (subst state.sel)
  apply (rule refl)
  done

schematic_goal fib\<^sub>T_simp2:
  "runState (fib\<^sub>T (Suc 0)) M = ?x"
  apply (subst fib\<^sub>T.simps(2))
  apply (subst checkmem_def)
  apply (subst bind_def)
  apply (subst state.sel)
  apply (subst get_def)
  apply (subst state.sel)
  apply (subst Let_unfold_pair)
  apply (subst bind_def)
  apply (subst return_def)
  apply (subst state.sel)
  apply (subst Let_unfold_pair)
  apply (subst bind_def)
  apply (subst get_def)
  apply (subst state.sel)
  apply (subst state.sel)
  apply (subst Let_unfold_pair)
  apply (subst bind_def)
  apply (subst put_def)
  apply (subst state.sel)
  apply (subst state.sel)
  apply (subst Let_unfold_pair)
  apply (subst return_def)
  apply (subst state.sel)
  apply (subst runState_option)
  apply (subst state.sel)
  apply (subst return_def)
  apply (subst state.sel)
  apply (rule refl)
  done

schematic_goal fib\<^sub>T_simp3:
  "runState (fib\<^sub>T (Suc (Suc n))) M = ?x"
  apply (subst fib\<^sub>T.simps(3))
  apply (subst checkmem_def)
  apply (subst bind_def)
  apply (subst state.sel)
  apply (subst get_def)
  apply (subst state.sel)
  apply (subst Let_def)
  apply (subst prod.case)
  apply (subst fun_app_lifted_def)
  apply (subst bind_def)
  apply (subst case_prod\<^sub>T_def)
  apply (subst return_def)
  apply (subst state.sel)
  apply (subst Let_def)
  apply (subst prod.case)
  apply (subst bind_def)
  apply (subst state.sel)
  apply (subst return_def)
  apply (subst state.sel)
  apply (subst Let_def)
  apply (subst prod.case)
  apply (subst unlift_33_def)
  apply (subst fun_app_lifted_def)
  apply (subst bind_def)
  apply (subst return_def)
  apply (subst return_def)
  apply (subst state.sel)
  apply (subst state.sel)
  apply (subst return_def)
  apply (subst Let_unfold_pair)
  apply (subst state.collapse)
  apply (subst bind_def)
  apply (subst return_def)
  apply (subst state.sel)
  apply (subst Let_unfold_pair)
  apply (subst state.sel)
  apply (subst bind_def)
  apply (subst fun_app_lifted_def)
  apply (subst bind_def)
  apply (subst state.sel)
  apply (subst Let_unfold_pair)
  apply (subst state.collapse)
  apply (subst fun_app_lifted_def)
  apply (subst bind_def)
  apply (subst return_def)
  apply (subst state.sel)
  apply (subst Let_unfold_pair)
  apply (subst state.collapse)
  apply (subst bind_def)
  apply (subst state.sel)
  apply (subst state.sel)
  apply (subst Let_unfold_pair)
  apply (subst fun_app_lifted_def)
  apply (subst bind_def)
  apply (subst return_def)
  apply (subst state.sel)
  apply (subst Let_unfold_pair)
  apply (subst state.collapse)
  apply (subst fun_app_lifted_def)
  apply (subst bind_def)
  apply (subst bind_def)
  apply (subst state.sel)
  apply (subst return_def)
  apply (subst state.sel)
  apply (subst Let_absorb)
  apply (subst Let_unfold_pair)
  apply (subst bind_def)
  apply (subst state.sel)
  apply (subst return_def)
  apply (subst state.sel)
  apply (subst bind_def)
  apply (subst state.sel)
  apply (subst state.sel)
  apply (subst Let_absorb2)
  apply (subst Let_unfold_pair)
  apply (subst prod.case)
  apply (subst return_def)
  apply (subst state.sel)
  apply (subst Let_absorb2)
  apply (subst Let_split_pair)
  apply (subst bind_def)
  apply (subst state.sel)
  apply (subst bind_def)
  apply (subst state.sel)
  apply (subst put_def)
  apply (subst state.sel)
  apply (subst Let_unfold_pair)
  apply (subst get_def)
  apply (subst state.sel)
  apply (subst Let_unfold_pair)
  apply (subst return_def)
  apply (subst state.sel)
  apply (subst runState_option)
  apply (subst state.sel)
  apply (subst return_def)
  apply (subst state.sel)
  apply (unfold runState'_def[symmetric])
  apply (rule refl)
  done

lemmas fib\<^sub>T_runState_simps[code_unfold] =
  fib\<^sub>T_simp1 fib\<^sub>T_simp2 fib\<^sub>T_simp3

fun fib\<^sub>T' :: "nat \<Rightarrow> (nat, int option) mapping \<Rightarrow> (int option \<times> (nat, int option) mapping)" where
  "fib\<^sub>T' 0 M = runState (fib\<^sub>T 0) M"
| "fib\<^sub>T' (Suc 0) M = runState (fib\<^sub>T (Suc 0)) M"
| "fib\<^sub>T' (Suc (Suc n)) M = runState (fib\<^sub>T (Suc (Suc n))) M"

lemma runState'_fold[code_unfold]:
  "runState' (fib\<^sub>T n) M = fib\<^sub>T' n M"
  unfolding runState'_def by (induction rule: fib\<^sub>T'.induct) auto

definition fib\<^sub>T'_entry where
  "fib\<^sub>T'_entry n \<equiv> fst (fib\<^sub>T' n Mapping.empty)"

lemma fib\<^sub>T'_entry_correct:
  "fib\<^sub>T'_entry = fib"
  apply (unfold fib\<^sub>T_entry_correct[symmetric])
  unfolding fib\<^sub>T'_entry_def fib\<^sub>T_entry_def
  apply (rule ext)
  apply (rule arg_cong[where f=fst])
  apply (induct_tac rule: fib\<^sub>T'.induct)
    apply auto
  done

export_code fib\<^sub>T'_entry in SML

end


theory Hopcroft_Tarjan_3
  imports
    Hopcroft_Tarjan
begin

type_synonym ('a, 'b) component = "('a, 'b) Directed_Multigraph.edge list"

record ('b, 't, 'g, 'a) state =
  root :: 'b
  tree :: 't
  multigraph :: 'g
  ESTACK :: "('a, 'b) Directed_Multigraph.edge list"
  Cs :: "('a, 'b) component list"

locale path_search =
  other
  where other = other +
    T: Map
  where empty = T_empty
    and update = T_update
    and delete = T_delete
    and lookup = T_lookup
    and invar = T_invar +
    P: Incidence_Structure
  where insert = insert
  for other :: "('a::linorder, 'b::linorder) Multigraph.edge \<Rightarrow> 'b \<Rightarrow> 'b"
    and T_empty
    and T_update :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and T_delete
    and T_lookup
    and T_invar
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes algorithm_5 :: "('b \<Rightarrow> nat) \<Rightarrow> ('a, 'b) Directed_Multigraph.edge \<Rightarrow> ('b, 't, 'g, 'a) state \<Rightarrow> ('b, 't, 'g, 'a) state"
  fixes algorithm_6 :: "('b \<Rightarrow> nat) \<Rightarrow> ('a, 'b) Directed_Multigraph.edge \<Rightarrow> ('b, 't, 'g, 'a) state \<Rightarrow> ('b, 't, 'g, 'a) state"
  assumes root_algorithm_5: "root (algorithm_5 N e \<sigma>) = root \<sigma>"
  assumes root_algorithm_6: "root (algorithm_6 N e \<sigma>) = root \<sigma>"
begin

definition tree_arc_2 where
  "tree_arc_2 e \<sigma> \<equiv> tree.tree_arc (T_lookup (tree \<sigma>)) e"

definition incidence_2 where
  "incidence_2 G \<equiv> Directed_Multigraph.incidence (\<lambda>v. incidence v G)"

(*
function (domintros) path_search where
  "path_search N e \<sigma> =
   (if tree_arc_2 e \<sigma>
    then let \<sigma>1 = fold (path_search N) (incidence_2 (multigraph \<sigma>) (head e)) \<sigma>;
             \<sigma>2 = \<sigma>1\<lparr>ESTACK := e # ESTACK \<sigma>1\<rparr>;
             \<sigma>3 = algorithm_5 N e \<sigma>2;
             \<sigma>4 = algorithm_6 N e \<sigma>3
         in \<sigma>4
    else \<sigma>\<lparr>ESTACK := e # ESTACK \<sigma>\<rparr>)"
  by auto
thm path_search.pinduct
*)

function (domintros) path_search where
  "path_search N v \<sigma> =
   fold
    (\<lambda>e \<sigma>'.
        if tree_arc_2 e \<sigma>
        then let \<sigma>1 = path_search N (head e) \<sigma>';
                 \<sigma>2 = \<sigma>1\<lparr>ESTACK := e # ESTACK \<sigma>1\<rparr>;
                 \<sigma>3 = algorithm_5 N e \<sigma>2;
                 \<sigma>4 = algorithm_6 N e \<sigma>3
             in \<sigma>4
        else \<sigma>'\<lparr>ESTACK := e # ESTACK \<sigma>'\<rparr>)
    (incidence_2 (multigraph \<sigma>) v)
    \<sigma>"
  by auto
thm path_search.pinduct

definition traverse_tree_arc where
  "traverse_tree_arc N e \<sigma> \<equiv>
   let \<sigma>1 = path_search N (head e) \<sigma>;
       \<sigma>2 = \<sigma>1\<lparr>ESTACK := e # ESTACK \<sigma>1\<rparr>;
       \<sigma>3 = algorithm_5 N e \<sigma>2;
       \<sigma>4 = algorithm_6 N e \<sigma>3
   in \<sigma>4"

definition traverse_frond where
  "traverse_frond N e \<sigma> = \<sigma>\<lparr>ESTACK := e # ESTACK \<sigma>\<rparr>"

definition traverse_edge where
  "traverse_edge N e \<sigma> \<equiv>
   if tree_arc_2 e \<sigma> then traverse_tree_arc N e \<sigma>
   else traverse_frond N e \<sigma>"

end

locale algorithm_3_pre = path_search
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g"
begin

definition init where
  "init r T P \<equiv>
   \<lparr>root = r,
    tree = T,
    multigraph = P,
    ESTACK = [],
    Cs = []\<rparr>"

definition algorithm_3 where
  "algorithm_3 r T P N \<equiv>
   let \<sigma> = path_search N r (init r T P)
   in ESTACK \<sigma> # Cs \<sigma>"

end

locale algorithm_3 = algorithm_3_pre
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes T :: "'g \<Rightarrow> 'b \<Rightarrow> 't"
  fixes N :: "'g \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> nat"
  fixes I :: "'g \<Rightarrow> 'b \<Rightarrow> 'g"
  assumes steps_1_2_3_high_3:
    "\<lbrakk> biconnected_multigraph other (P.E G); r \<in> Multigraph.V (P.E G) \<rbrakk> \<Longrightarrow>
     steps_1_2_3_high_3 other r (\<lambda>v. incidence v (I G r)) (N G r) (P.E G) (T_lookup (T G r))"
begin

definition algorithm_3' :: "'g \<Rightarrow> 'b \<Rightarrow> ('a, 'b) Multigraph.edge list list" where
  "algorithm_3' G r \<equiv> map (map undirect) (algorithm_3 r (T G r) (I G r) (N G r))"

end

subsection \<open>Verification of the correctness of the algorithm\<close>

subsubsection \<open>Assumptions on the input\<close>

locale path_search_valid_input = path_search
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes N :: "'b \<Rightarrow> nat"
  fixes v :: 'b
  assumes "0 \<le> N v"
begin

abbreviation path_search' where
  "path_search' \<equiv> path_search N v"

abbreviation traverse_edge' where
  "traverse_edge' \<equiv> traverse_edge N"

abbreviation traverse_tree_arc' where
  "traverse_tree_arc' \<equiv> traverse_tree_arc N"

abbreviation traverse_frond' where
  "traverse_frond' \<equiv> traverse_frond N"

end

locale algorithm_3_pre_valid_input = algorithm_3_pre
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes r :: 'b
  fixes T :: 't
  fixes P :: 'g
  fixes N :: "'b \<Rightarrow> nat"
  assumes steps_1_2_3_high_2: "steps_1_2_3_high_2 r (\<lambda>v. incidence v P) (T_lookup T) N"
begin
sublocale path_search_valid_input
  where N = N
    and v = r
  sorry
end

abbreviation (in algorithm_3_pre) algorithm_3_pre_valid_input' where
  "algorithm_3_pre_valid_input' \<equiv>
   algorithm_3_pre_valid_input
    empty delete incidence invar
    other
    T_empty T_delete T_lookup T_invar
    algorithm_5
    algorithm_6
    T_update
    insert"

locale algorithm_3_valid_input = algorithm_3
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes G :: 'g
  fixes r :: 'b
  assumes biconnected_multigraph: "biconnected_multigraph other (P.E G)"
  assumes r_mem_V: "r \<in> Multigraph.V (P.E G)"
begin
sublocale algorithm_3_pre_valid_input
  where T = "T G r"
    and P = "I G r"
    and N = "N G r"
  sorry
end

abbreviation (in algorithm_3) algorithm_3_valid_input' where
  "algorithm_3_valid_input' \<equiv>
   algorithm_3_valid_input
    empty delete incidence invar
    other
    T_empty T_delete T_lookup T_invar
    algorithm_5
    algorithm_6
    T
    N
    I
    T_update
    insert"

subsubsection \<open>Loop invariants\<close>

locale path_search_invar = path_search_valid_input
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes \<sigma> :: "('b, 't, 'g, 'a) state"
    (* QUESTION: Use P.E instead? *)
  assumes finite_multigraph: "finite (undirect ` P.A (multigraph \<sigma>))"
  assumes simple_multigraph: "simple (undirect ` P.A (multigraph \<sigma>))"
  assumes finite_Cs: "Ball (set (map set (map (map undirect) (Cs \<sigma>)))) finite"
  assumes no_separation_pair_Cs: "\<forall>G\<in>set (map set (map (map undirect) (Cs \<sigma>))). \<not> (\<exists>a b. is_separation_pair G a b)"
    (* TODO: Order. *)
  assumes palm_tree_2: "palm_tree_2 (root \<sigma>) (T_lookup (tree \<sigma>)) (\<lambda>v. incidence v (multigraph \<sigma>))"
begin
end

abbreviation (in path_search) path_search_invar' where
  "path_search_invar' N v \<equiv>
   path_search_invar
    empty delete incidence invar
    other
    T_empty T_delete T_lookup T_invar
    algorithm_5
    algorithm_6
    N
    v
    T_update
    insert"

abbreviation (in path_search_valid_input) path_search_invar'' where
  "path_search_invar'' \<equiv> path_search_invar' N v"

lemma (in algorithm_3_pre_valid_input) path_search_invar_init:
  shows "path_search_invar' N r (init r T P)"
  sorry

subsubsection \<open>Termination\<close>

lemma (in path_search_valid_input) path_search_dom:
  assumes "path_search_invar'' \<sigma>"
  shows "path_search_dom (N, v, \<sigma>)"
  sorry

lemma (in path_search_invar) path_search_dom:
  shows "path_search_dom (N, v, \<sigma>)"
  using path_search_invar_axioms
  by (intro path_search_dom)

lemma (in path_search) path_search_simps:
  assumes "path_search_invar' N v \<sigma>"
  shows
    "path_search N v \<sigma> =
     fold (traverse_edge N) (incidence_2 (multigraph \<sigma>) v) \<sigma>"
  unfolding traverse_edge_def traverse_tree_arc_def traverse_frond_def
  using assms
  by (intro path_search_invar.path_search_dom path_search.psimps)

lemma (in path_search) path_search_induct:
  assumes "path_search_invar' N v \<sigma>"
  assumes
    "\<And>N v \<sigma>.
        (\<And>e \<sigma>'.
            e \<in> set (incidence_2 (multigraph \<sigma>) v) \<Longrightarrow>
            tree_arc_2 e \<sigma> \<Longrightarrow>
            P N (head e) \<sigma>') \<Longrightarrow>
        P N v \<sigma>"
  shows "P N v \<sigma>"
  using assms
  by (blast intro: path_search_invar.path_search_dom path_search.pinduct)

subsubsection \<open>Correctness\<close>

lemma root_fold:
  assumes "\<And>e \<sigma>. e \<in> set l \<Longrightarrow> root (f e \<sigma>) = root \<sigma>"
  shows "root (fold f l \<sigma>) = root \<sigma>"
  using assms
proof (induct l arbitrary: \<sigma>)
  case Nil
  thus ?case
    by fastforce
next
  case (Cons e es)
  have "root (fold f (e # es) \<sigma>) = root (fold f es (f e \<sigma>))"
    by fastforce
  also have "... = root (f e \<sigma>)"
    using Cons.prems
    by (intro Cons.hyps) simp
  also have "... = root \<sigma>"
    by (intro Cons.prems) simp
  finally show ?case
    .
qed

lemma (in path_search) root_traverse_edge:
  assumes
    "tree_arc_2 e \<sigma> \<Longrightarrow>
     root (path_search N (head e) \<sigma>) =
     root \<sigma>"
  shows "root (traverse_edge N e \<sigma>) = root \<sigma>"
proof (cases "tree_arc_2 e \<sigma>")
  case True
  hence
    "root (traverse_edge N e \<sigma>) =
     root (path_search N (head e) \<sigma>)"
    by (simp add: traverse_edge_def traverse_tree_arc_def Let_def root_algorithm_6 root_algorithm_5)
  also have "... = root \<sigma>"
    using True
    by (intro assms)
  finally show ?thesis
    .
next
  case False
  thus ?thesis
    by (simp add: traverse_edge_def traverse_frond_def)
qed

lemma (in path_search_valid_input) root_path_search:
  assumes "path_search_invar'' \<sigma>"
  shows "root (path_search N v \<sigma>) = root \<sigma>"
  using assms
proof (induct rule: path_search_induct[OF assms])
  case (1 N v \<sigma>)
  then show ?case sorry
qed

(**)

lemma (in path_search_valid_input) path_search_correct:
  assumes "path_search_invar'' \<sigma>"
  shows
    "let \<sigma>' = path_search N v \<sigma>
     in are_split_components
         (undirect ` P.A (multigraph \<sigma>))
         (map set (map (map undirect) (ESTACK \<sigma>' # Cs \<sigma>')))"
  sorry

lemma (in algorithm_3_pre_valid_input) algorithm_3_correct:
  shows "are_split_components (undirect ` P.A P) (map set (map (map undirect) (algorithm_3 r T P N)))"
  using path_search_invar_init
  by (auto simp add: algorithm_3_def Let_def init_def dest: path_search_correct)

lemma (in algorithm_3_valid_input) image_undirect_A_eq_E:
  shows "undirect ` P.A (I G r) = P.E G"
  sorry

lemma (in algorithm_3_valid_input) algorithm_3'_correct:
  shows "are_split_components (P.E G) (map set (algorithm_3' G r))"
  unfolding image_undirect_A_eq_E[symmetric] algorithm_3'_def
  using algorithm_3_correct
  .

lemma (in algorithm_3) algorithm_3'_correct:
  assumes "algorithm_3_valid_input' G r"
  shows "are_split_components (P.E G) (map set (algorithm_3' G r))"
  using assms
  by (intro algorithm_3_valid_input.algorithm_3'_correct)

end