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

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

Copyright (C) 2006-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
*)

theory XVcg
imports Vcg

begin

text {* We introduce a syntactic variant of the let-expression so that we can
safely unfold it during verification condition generation. With the new
theorem attribute @{text "vcg_simp"} we can declare equalities to be used
by the verification condition generator, while simplifying assertions.
*}

syntax
"_Let'" :: "[letbinds, basicblock] => basicblock"  ("(LET (_)/ IN (_))" 23)

translations
  "_Let' (_binds b bs) e"  == "_Let' b (_Let' bs e)"
  "_Let' (_bind x a) e"    == "CONST Let' a (%x. e)"

lemma Let'_unfold [vcg_simp]: "Let' x f = f x"
  by (simp add: Let'_def Let_def)

lemma Let'_split_conv [vcg_simp]:
  "(Let' x  (\<lambda>p. (case_prod (f p) (g p)))) =
   (Let' x  (\<lambda>p. (f p) (fst (g p)) (snd (g p))))"
  by (simp add: split_def)

end


           (*-------------------------------------------*
            |                                           |
            |            Safety of ParaCtrl             |
            |                                           |
            *-------------------------------------------*)

theory ParaCtrl_safe
  imports MBP_algo CSP_wsim SeqCtrl_safe
begin

(*************************************************************

         1. ParaAlgo
         2.
         3.
         4.

 *************************************************************)
definition
  Sim :: "nodes => edges => (nat => nodes) =>
         ((ParaName,Event)proc * (SpecName,Event)proc) set"
  where
    Sim_def : "Sim Blks Deps Asn
            == {(ParaCtrl Blks Deps Asn,SeqCtrl Blks Deps)}
           Un {PQ. EX P Q S. PQ = (P,Q) &
               P = ($Bfr Blks Deps Asn 1 S |[ComFin]| $Bfr Blks Deps Asn 2 S) ~~ Com &
               Q = $Seq Blks Deps S & S <= Blks}
           Un {PQ. EX P Q S S' n. PQ = (P,Q) &
               P = ($Aft Blks Deps Asn 1 S n|[ComFin]| $Bfr Blks Deps Asn 2 S) ~~ Com &
               Q = $Seq Blks Deps S' & S' = (S Un {n}) & S' <= Blks & ~(n : S) & n : Asn 1}
           Un {PQ. EX P Q S S' m . PQ = (P,Q) &
               P = ($Bfr Blks Deps Asn 1 S |[ComFin]| $Aft Blks Deps Asn 2 S m) ~~ Com &
               Q = $Seq Blks Deps S' & S' = (S Un {m}) & S' <= Blks & ~(m : S) & m : Asn 2}
           Un {PQ. EX P Q S S' n m. PQ = (P,Q) &
               P = ($Aft Blks Deps Asn 1 S n|[ComFin]| $Aft Blks Deps Asn 2 S m) ~~ Com &
               Q = $Seq Blks Deps S' & S' = (S Un {n,m}) & S' <= Blks & ~(n : S)
                   & ~(m : S) & n : Asn 1  & m : Asn 2 }
           Un {PQ. EX P Q. PQ = (P,Q) &
               P = (STOP |[ComFin]| STOP) ~~ Com &
               Q = STOP}
"

(* ------------------------------------ *
 |              lemmas                  |
 * ------------------------------------ *)

(*Bfr[]Bfr*)
lemma ParaAlgo_ws_BfrBfr:
  " ALL P e P' S Q.  P ---e---> P' -->
       P = ($Bfr Blks Deps Asn (Suc 0) S |[ComFin]| $Bfr Blks Deps Asn 2 S) ~~ Com &
       Q = $Seq Blks Deps S & S <= Blks -->
      ( EX Q'. Q ===^e===> Q' & (P', Q') : Sim Blks Deps Asn)"

  apply (simp)
  apply (intro allI impI)
  apply (erule trn.cases,auto)
   apply (erule trn.cases,auto)
     apply (insert ParaAlgo_Bfr_blk[of Blks Deps Asn])

(*subgoal 1*)
     apply (drule_tac x="e" in spec)
     apply (drule_tac x="Suc 0" in spec)
     apply (drule_tac x="S" in spec)
     apply (drule_tac x="P'" in spec)
     apply (simp)
     apply (elim exE conjE)
     apply (simp)
     apply (rule_tac x="$Seq Blks Deps (S Un {n})" in exI)
     apply (rule conjI)
      apply (simp add: weak_tau_trn_seq_trn)
      apply (rule_tac x="[Ev (blk n)]" in exI)
      apply (simp)
      apply (rule Base)
      apply (simp add: Seq_trn_blk)

     apply (simp add: Sim_def)
     apply (rule disjI2)
     apply (simp add: enable_def)

(*subgoal 2*)
    apply (drule_tac x="e" in spec)
    apply (drule_tac x="2" in spec)
    apply (drule_tac x="S" in spec)
    apply (drule_tac x="Q'" in spec)
    apply (simp)
    apply (elim exE conjE)
    apply (simp)
    apply (rule_tac x="$Seq Blks Deps (S Un {n})" in exI)
    apply (rule conjI)
     apply (simp add: weak_tau_trn_seq_trn)
     apply (rule_tac x="[Ev (blk n)]" in exI)
     apply (simp)
     apply (rule Base)
      apply (simp add: Seq_trn_blk)

    apply (simp add: Sim_def)
    apply (rule disjI2)
    apply (simp add: enable_def)

(*subgoal 3*)
   apply (rotate_tac 5)
   apply (erule rem_asmE)
   apply (insert ParaAlgo_Bfr_blk_finish[of Blks Deps Asn])

   apply (drule_tac x="Ev a" in spec)
   apply (drule_tac x="1" in spec)
   apply (drule_tac x="S" in spec)
   apply (drule_tac x="P'" in spec)

   apply (insert ParaAlgo_Bfr_blk_finish[of Blks Deps Asn])
   apply (drule_tac x="Ev a" in spec)
   apply (drule_tac x="2" in spec)
   apply (drule_tac x="S" in spec)
   apply (drule_tac x="Q'" in spec)
   apply (rule_tac x="STOP" in exI)
   apply (rule conjI)
    apply (simp add: weak_tau_trn_seq_trn)
    apply (rule_tac x="[Ev finish]" in exI)
    apply (simp)
    apply (rule Base)
    apply (simp add: Seq_trn_finish)

   apply (simp add: Sim_def)
  apply (simp)

(*subgoal 4*)
  apply (rotate_tac 3)
  apply (erule rem_asmE)
  apply (erule rem_asmE)
  apply (erule trn.cases, auto)

    apply (simp add: ComFin_def)
   apply (simp add: ComFin_def)
  apply (insert ParaAlgo_Bfr_blk_com[of Blks Deps Asn])
  apply (drule_tac x="Ev aa" in spec)
  apply (drule_tac x="Suc 0" in spec)
  apply (drule_tac x="S" in spec)
  apply (drule_tac x="P'" in spec)
  apply (insert ParaAlgo_Bfr_blk_com[of Blks Deps Asn])
  apply (drule_tac x="Ev aa" in spec)
  apply (drule_tac x="2" in spec)
  apply (drule_tac x="S" in spec)
  apply (drule_tac x="Q'" in spec)
  apply (simp)
  apply (elim exE conjE disjE)
  apply (simp)

  done

(*Afr[]Bfr*)
lemma ParaAlgo_ws_AftBfr:
  "ALL P e P' S n Q . P ---e---> P' -->
       P = ($Aft Blks Deps Asn (Suc 0) S n |[ComFin]| $Bfr Blks Deps Asn 2 S) ~~ Com &
       Q = $Seq Blks Deps (insert n S)
       & n:Blks & S <= Blks & n ~:S & n:Asn(Suc 0) & Asn 1 Int Asn 2 = {} -->
       (EX Q'. Q ===^e===> Q' & (P', Q') : Sim Blks Deps Asn)"

(*subgoal 1*)
  apply (simp)
  apply (intro allI)
  apply (intro impI)
  apply (erule trn.cases,auto)
   apply (erule trn.cases,auto)

(*Hide1, Para1*)
     apply (insert ParaAlgo_Aft_blk[of Blks Deps Asn])
     apply (drule_tac x="e" in spec)
     apply (drule_tac x="1" in spec)
     apply (drule_tac x="S" in spec)
     apply (drule_tac x="n" in spec)
     apply (drule_tac x="P'" in spec)
     apply (simp)
     apply (erule disjE)
      apply (simp add: Com_def)
     apply (erule exE)
     apply (simp add: Com_def)

(*Hide1, Para2*)
    apply (rotate_tac 8)
    apply (erule rem_asmE)
    apply (insert ParaAlgo_Bfr_blk[of Blks Deps Asn])
    apply (drule_tac x="e" in spec)
    apply (drule_tac x="2" in spec)
    apply (drule_tac x="S" in spec)
    apply (drule_tac x="Q'" in spec)
    apply (simp)
    apply (erule exE)
    apply (elim exE conjE)
    apply (simp)
    apply (rule_tac x="$Seq Blks Deps (S Un {na,n})" in exI)
    apply (rule conjI)
     apply (simp add: weak_tau_trn_seq_trn)
     apply (rule_tac x="[Ev (blk na)]" in exI)
     apply (simp)
     apply (rule Base)
     apply (rule PName)
     apply (simp)
     apply (rule ExtCh2)
     apply (rule If1)
     apply (rule conjI)
      apply (rule NatExtCh1)
      apply (rule conjI)
       apply (simp)
       apply (rule Prefix)
      apply (simp add: enable_def)
      apply (rule conjI)
       apply (simp add: subset_iff)
      apply (force)
     apply (simp add: enable_def)
     apply (force)
    apply (simp add: Sim_def)
    apply (rule disjI2)
    apply (simp add: enable_def)
    apply (force)

(*Hide1, Para3*)
   apply (rotate_tac 9)
   apply (erule rem_asmE)
   apply (erule rem_asmE)
   apply (insert ParaAlgo_Bfr_blk_finish[of Blks Deps Asn])
   apply (drule_tac x="Ev a" in spec)
   apply (drule_tac x="2" in spec)
   apply (drule_tac x="S" in spec)
   apply (drule_tac x="Q'" in spec)
   apply (simp)

(*Hide2*)
  apply (rotate_tac 7)
  apply (erule rem_asmE)
  apply (erule rem_asmE)
  apply (erule rem_asmE)
  apply (erule trn.cases,auto)

(*Hide2, Para1*)
    apply (simp add: ComFin_def)

(*Hide2, Para2*)
   apply (simp add: ComFin_def)

(*Hide2, Para3*)
  apply (insert ParaAlgo_Aft_blk[of Blks Deps Asn])
  apply (drule_tac x="Ev aa" in spec)
  apply (drule_tac x="1" in spec)
  apply (drule_tac x="S" in spec)
  apply (drule_tac x="n" in spec)
  apply (drule_tac x="P'" in spec)
  apply (simp)
  apply (insert ParaAlgo_Bfr_blk_com[of Blks Deps Asn])
  apply (drule_tac x="Ev aa" in spec)
  apply (drule_tac x="2" in spec)
  apply (drule_tac x="S" in spec)
  apply (drule_tac x="Q'" in spec)
  apply (simp)

  apply (elim disjE exE conjE)
   apply (simp)
   apply (rule_tac x=" $Seq Blks Deps (insert n S)" in exI)
   apply (simp add: weak_tau_trn_id)
   apply (simp add:Sim_def)
  apply (simp)

  done

(*Bfr[]Aft*)
lemma ParaAlgo_ws_BfrAft:
  "     ALL P e P' S m Q. P ---e---> P' -->
       P = ($Bfr Blks Deps Asn (Suc 0) S  |[ComFin]| $Aft Blks Deps Asn 2 S m) ~~ Com &
       Q = $Seq Blks Deps (insert m S)
       & m:Blks & S <= Blks & m ~:S & m:Asn 2 & Asn 1 Int Asn 2 = {}-->
       (EX Q'. Q ===^e===> Q' & (P', Q') : Sim Blks Deps Asn)"
  apply (simp)
  apply (intro allI conjI)
  apply (intro impI)
  apply (erule trn.cases,auto)

(*Hide1*)
   apply (erule trn.cases,auto)

(*Hide1, Para1*)
     apply (insert ParaAlgo_Bfr_blk[of Blks Deps Asn])
     apply (drule_tac x="e" in spec)
     apply (drule_tac x="1" in spec)
     apply (drule_tac x="S" in spec)
     apply (drule_tac x="P'" in spec)
     apply (simp)
     apply (elim exE conjE)
     apply (simp)
     apply (rule_tac x="$Seq Blks Deps (insert n (insert m S))" in exI)
     apply (rule conjI)
      apply (simp add: weak_tau_trn_seq_trn)
      apply (rule_tac x="[Ev (blk n)]" in exI)
      apply (simp)
      apply (rule Base)
      apply (rule PName)
      apply (simp)
      apply (rule ExtCh2)
      apply (rule If1)
      apply (rule conjI)
       apply (rule NatExtCh1)
       apply (rule conjI)
        apply (simp)
        apply (rule Prefix)
       apply (simp add: enable_def)
       apply (rule conjI)
        apply (simp add: subset_iff)
       apply (force)
      apply (simp add: enable_def)
      apply (force)
     apply (simp add: Sim_def)
     apply (rule disjI2)
     apply (simp add: enable_def)

(*Hide1, Para2*)
    apply (rotate_tac 8)
    apply (erule rem_asmE)
    apply (insert ParaAlgo_Aft_blk[of Blks Deps Asn])
    apply (drule_tac x="e" in spec)
    apply (drule_tac x="2" in spec)
    apply (drule_tac x="S" in spec)
    apply (drule_tac x="m" in spec)
    apply (drule_tac x="Q'" in spec)
    apply (simp)
    apply (erule disjE)
     apply (simp add: Com_def)
    apply (erule exE)
    apply (simp add: Com_def)

(*Hide1, Para3*)
   apply (rotate_tac 9)
   apply (erule rem_asmE)
   apply (erule rem_asmE)
   apply (insert ParaAlgo_Bfr_blk_finish[of Blks Deps Asn])
   apply (drule_tac x="Ev a" in spec)
   apply (drule_tac x="1" in spec)
   apply (drule_tac x="S" in spec)
   apply (drule_tac x="P'" in spec)
   apply (simp)

(*Hide2*)
  apply (rotate_tac 7)
  apply (erule rem_asmE)
  apply (erule rem_asmE)
  apply (erule rem_asmE)
  apply (erule trn.cases,auto)

(*Hide2, Para1*)
    apply (simp add: ComFin_def)

(*Hide2, Para2*)
   apply (simp add: ComFin_def)

(*Hide2, Para3*)
  apply (insert ParaAlgo_Aft_blk[of Blks Deps Asn])
  apply (drule_tac x="Ev aa" in spec)
  apply (drule_tac x="2" in spec)
  apply (drule_tac x="S" in spec)
  apply (drule_tac x="m" in spec)
  apply (drule_tac x="Q'" in spec)
  apply (simp)
  apply (insert ParaAlgo_Bfr_blk_com[of Blks Deps Asn])
  apply (drule_tac x="Ev aa" in spec)
  apply (drule_tac x="1" in spec)
  apply (drule_tac x="S" in spec)
  apply (drule_tac x="P'" in spec)
  apply (simp)

  apply (elim disjE exE conjE)
   apply (simp)
   apply (rule_tac x=" $Seq Blks Deps (insert m S)" in exI)
   apply (simp add: weak_tau_trn_id)
   apply (simp add:Sim_def)
  apply (simp)

  done

(*Afr[]Afr p13*)
lemma ParaAlgo_ws_AftAft:
"      ALL P e P' S n m Q. P ---e---> P' -->
       P = ($Aft Blks Deps Asn (Suc 0) S n |[ComFin]| $Aft Blks Deps Asn 2 S m) ~~ Com &
       Q = $Seq Blks Deps(insert n (insert m S)) & n:Blks & m:Blks
       & S <= Blks & n ~:S & m ~:S & n:Asn 1 & m:Asn 2 & Asn 1 Int Asn 2 = {}-->
       (EX Q'. Q ===^e===> Q' & (P', Q') : Sim Blks Deps Asn)"
  apply (simp)
  apply (intro allI conjI impI)
  apply (erule trn.cases,auto)
(*Hide1*)
   apply (erule trn.cases,auto)

(*Hide1, Para1*)
     apply (insert ParaAlgo_Aft_blk[of Blks Deps Asn])
     apply (drule_tac x="e" in spec)
     apply (drule_tac x="1" in spec)
     apply (drule_tac x="S" in spec)
     apply (drule_tac x="n" in spec)
     apply (drule_tac x="P'" in spec)
     apply (simp)
     apply (erule disjE)
      apply (simp add: Com_def)
     apply (erule exE)
     apply (simp add: Com_def)

(*Hide1, Para2*)
    apply (rotate_tac 11)
    apply (erule rem_asmE)
    apply (insert ParaAlgo_Aft_blk[of Blks Deps Asn])
    apply (drule_tac x="e" in spec)
    apply (drule_tac x="2" in spec)
    apply (drule_tac x="S" in spec)
    apply (drule_tac x="m" in spec)
    apply (drule_tac x="Q'" in spec)
    apply (simp)
    apply (erule disjE)
     apply (simp add: Com_def)
    apply (erule exE)
    apply (simp add: Com_def)

(*Hide1, Para3*)

   apply (drule_tac x="Ev a" in spec)
   apply (drule_tac x="1" in spec)
   apply (drule_tac x="S" in spec)
   apply (drule_tac x="n" in spec)
   apply (drule_tac x="P'" in spec)

   apply (drule_tac x="Ev a" in spec)
   apply (drule_tac x="2" in spec)
   apply (drule_tac x="S" in spec)
   apply (drule_tac x="m" in spec)
   apply (drule_tac x="Q'" in spec)
   apply (simp)
   apply (elim disjE)
      apply (simp add: Com_def)
     apply (erule exE)
     apply (simp add: Com_def)
    apply (simp add: Com_def)
   apply (erule exE)
   apply (simp add: Com_def)

(*Hide2*)
  apply (rotate_tac 10)
  apply (erule rem_asmE)
  apply (erule rem_asmE)
  apply (erule trn.cases,auto)

(*Hide2, Para1*)
    apply (insert ParaAlgo_Aft_blk[of Blks Deps Asn])
    apply (drule_tac x="Ev a" in spec)
    apply (drule_tac x="1" in spec)
    apply (drule_tac x="S" in spec)
    apply (drule_tac x="n" in spec)
    apply (drule_tac x="P'" in spec)
    apply (simp)
    apply (elim disjE)
     apply (simp add: ComFin_def)
    apply (erule exE)
    apply (simp add: ComFin_def)

(*Hide2, Para2*)
   apply (rotate_tac 11)
   apply (erule rem_asmE)
   apply (insert ParaAlgo_Aft_blk[of Blks Deps Asn])
   apply (drule_tac x="Ev a" in spec)
   apply (drule_tac x="2" in spec)
   apply (drule_tac x="S" in spec)
   apply (drule_tac x="m" in spec)
   apply (drule_tac x="Q'" in spec)
   apply (simp)
   apply (erule disjE)
    apply (simp add: ComFin_def)
   apply (erule exE)
   apply (simp add: ComFin_def)

(*Hide2, Para3*)

  apply (drule_tac x="Ev aa" in spec)
  apply (drule_tac x="1" in spec)
  apply (drule_tac x="S" in spec)
  apply (drule_tac x="n" in spec)
  apply (drule_tac x="P'" in spec)

  apply (drule_tac x="Ev aa" in spec)
  apply (drule_tac x="2" in spec)
  apply (drule_tac x="S" in spec)
  apply (drule_tac x="m" in spec)
  apply (drule_tac x="Q'" in spec)
  apply (simp)

  apply (elim disjE)
     apply (simp)
    apply (erule exE)
    apply (rule_tac x="$Seq Blks Deps (insert n (insert m S))" in exI)
    apply (rule conjI)
     apply (simp add: weak_tau_trn_id)
    apply (simp add:Sim_def)
    apply (force)

   apply (erule exE)
   apply (rule_tac x="$Seq Blks Deps (insert n (insert m S))" in exI)
   apply (rule conjI)
    apply (simp add: weak_tau_trn_id)
   apply (simp add:Sim_def)
   apply (force)
  apply (elim exE)
  apply (simp)
  done

(*Para[]Seq*)
lemma ParaAlgo_ws_ParaSeq:
"ALL P e P' Q. P ---e---> P' -->
       P = ParaCtrl Blks Deps Asn  & Q = SeqCtrl Blks Deps -->
      ( EX Q'. Q ===^e===> Q' & (P', Q') : Sim Blks Deps Asn)"
  apply (simp)
  apply (intro allI impI)
  apply (simp add:ParaCtrl_def)
  apply (simp add:SeqCtrl_def)
  apply (insert ParaAlgo_ws_BfrBfr[of Blks Deps Asn])
  apply (drule_tac x="($Bfr Blks Deps Asn (Suc 0) {} |[ComFin]| $Bfr Blks Deps Asn 2 {}) ~~ Com" in spec)
  apply (drule_tac x="e" in spec)
  apply (drule_tac x="P'" in spec)
  apply (drule_tac x="{}" in spec)
  apply (drule_tac x="$Seq Blks Deps {}" in spec)
  apply (simp)
  done

lemma ParaAlgo_ws_sim:
  " ALL P e P' Q. Asn 1 Int Asn 2 = {}  --> P ---e---> P' --> (P, Q) : Sim Blks Deps Asn
    --> P ---e---> P' --> (EX Q'. Q ===^e===> Q' & (P', Q') : Sim Blks Deps Asn)"
  apply (intro impI allI)
  apply (simp add: Sim_def)
  apply (erule disjE)
   apply (insert ParaAlgo_ws_STST)
   apply (drule_tac x="P" in spec)
   apply (drule_tac x="e" in spec)
   apply (drule_tac x="P'" in spec)
   apply (simp)

  apply (rotate_tac -1)
  apply (erule rem_asmE)
  apply (erule disjE)
   apply (insert ParaAlgo_ws_ParaSeq[of Blks Deps Asn])
   apply (drule_tac x="P" in spec)
   apply (drule_tac x="e" in spec)
   apply (drule_tac x="P'" in spec)
   apply (drule_tac x="Q" in spec)
   apply (simp)
   apply (erule exE)
   apply (rule_tac x="Q'" in exI)
   apply (simp add: Sim_def)

  apply (rotate_tac -1)
  apply (erule rem_asmE)
  apply (erule disjE)
   apply (erule exE)
   apply (insert ParaAlgo_ws_BfrBfr[of Blks Deps Asn])
   apply (drule_tac x="P" in spec)
   apply (drule_tac x="e" in spec)
   apply (drule_tac x="P'" in spec)
   apply (drule_tac x="S" in spec)
   apply (drule_tac x="Q" in spec)
   apply (simp)
   apply (erule exE)
   apply (rule_tac x="Q'" in exI)
   apply (simp add: Sim_def)

  apply (rotate_tac -1)
  apply (erule rem_asmE)
  apply (erule disjE)
   apply (elim exE)
   apply (insert ParaAlgo_ws_AftBfr[of Blks Deps Asn])
   apply (drule_tac x="P" in spec)
   apply (drule_tac x="e" in spec)
   apply (drule_tac x="P'" in spec)
   apply (drule_tac x="S" in spec)
   apply (drule_tac x="n" in spec)
   apply (drule_tac x="Q" in spec)
   apply (simp)
   apply (erule exE)
   apply (rule_tac x="Q'" in exI)
   apply (simp add: Sim_def)

  apply (rotate_tac -1)
  apply (erule rem_asmE)
  apply (erule disjE)
   apply (elim exE)
   apply (insert ParaAlgo_ws_BfrAft[of Blks Deps Asn])
   apply (drule_tac x="P" in spec)
   apply (drule_tac x="e" in spec)
   apply (drule_tac x="P'" in spec)
   apply (drule_tac x="S" in spec)
   apply (drule_tac x="m" in spec)
   apply (drule_tac x="Q" in spec)
   apply (simp)
   apply (erule exE)
   apply (rule_tac x="Q'" in exI)
   apply (simp add: Sim_def)

  apply (rotate_tac -1)
  apply (erule rem_asmE)
  apply (elim exE)
  apply (insert ParaAlgo_ws_AftAft[of Blks Deps Asn])
  apply (drule_tac x="P" in spec)
  apply (drule_tac x="e" in spec)
  apply (drule_tac x="P'" in spec)
  apply (drule_tac x="S" in spec)
  apply (drule_tac x="n" in spec)
  apply (drule_tac x="m" in spec)
  apply (drule_tac x="Q" in spec)
  apply (simp)
  apply (erule exE)
  apply (rule_tac x="Q'" in exI)
  apply (simp add: Sim_def)
  done

lemma Sim_weak_sim:
  "Asn 1 \<inter> Asn 2 = {} \<Longrightarrow> weak_sim (Sim Blks Deps Asn)"
  apply (simp add: weak_sim_def)
  apply (intro allI impI)
  apply (insert ParaAlgo_ws_sim[of Asn Blks Deps])
  apply (drule_tac x="P" in spec)
  apply (drule_tac x="e" in spec)
  apply (drule_tac x="P'" in spec)
  apply (drule_tac x="Q" in spec)
  apply (simp)
  done

theorem ParaCtrl_refine_SeqCtrl_traces:
  " Asn 1 Int Asn 2 = {} ==> SeqCtrl Blks Deps [T= ParaCtrl Blks Deps Asn"
  apply (rule weak_sim_traces_ref[of "Sim Blks Deps Asn"])
   apply (simp add:Sim_weak_sim)
  apply (simp add:Sim_def)
  done

theorem Paractrl_safe:
  "Asn 1 Int Asn 2 = {} ==> t:traces(ParaCtrl Blks Deps Asn) ==> k < length(t)
 ==> (EX n. t!k = blk n & src Blks Deps n <= dones t k)
 | t!k = finish"
  apply (rule Seqctrl_safe)
   apply (insert ParaCtrl_refine_SeqCtrl_traces[of Asn Blks Deps])
   apply (simp)
   apply (simp add:refT_def)
   apply (simp add:subset_iff)
  apply (simp)
  done

end


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

(* A folding operation for separation algebra, to facilitate mappings with sharing
 *
 * Ordinarily when we map over a list, we require that the heap initially satisfies some
 * precondition P for every element of the list, and we transform it into a heap which satisfies
 * a post-condition Q for every element, i.e.
 *
 *  \<And>* map P xs \<and>* ((\<And>* map Q xs) \<longrightarrow>* R))
 *
 * However, what if we only have one copy of some resource required by P, and we want to share it
 * between iterations? The above formulation is insufficient, as it would require a copy of the
 * resource for every x \<in> xs. That's where sep_fold comes in.
 *
 * As you can see in the definition below, sep_fold nests each iteration's pre-condition under
 * the post-conditions for previous iterations, which allows a shared resource to be passed down.
 *
 * For a real-world example of sep_fold usage, see the lemmas in SysInit.InitVSpace
 *
 * See also the Sep_Fold_Cancel lemmas and tactics, which automatically detect and cancel sharing
 *)

theory Sep_Fold
imports
  Separation_Algebra
  Sep_ImpI
begin

definition
  sep_fold :: "('b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow>
               ('b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow>
               ('a \<Rightarrow> bool) \<Rightarrow>
               'b list \<Rightarrow>
               ('a::sep_algebra \<Rightarrow> bool)"
  where
  "sep_fold P Q R xs \<equiv> foldr (\<lambda>x R. (P x \<and>* (Q x \<longrightarrow>* R))) xs R"

notation sep_fold ("\<lparr>{_} \<and>* ({_} \<longrightarrow>* {_})\<rparr> _")

lemma sep_map_sep_foldI: "(\<And>* map P xs \<and>* ((\<And>* map Q xs) \<longrightarrow>* R)) s \<Longrightarrow> sep_fold P Q R xs s"
  apply (clarsimp simp: sep_fold_def)
  apply (induct xs arbitrary: s; clarsimp)
   apply (metis sep_add_zero sep_disj_zero sep_empty_zero sep_impl_def)
  apply (clarsimp simp: sep_conj_ac)
  apply (erule (1) sep_conj_impl)
  apply (erule sep_conj_sep_impl)
  apply (clarsimp simp: sep_conj_ac)
  apply (drule meta_spec)
   apply (erule meta_mp)
  apply (subst (asm) sep_conj_assoc[symmetric])
  apply (erule sep_conj_sep_impl2)
  apply (erule sep_conj_sep_impl2)
  apply (rule sep_wand_collapse)
  apply (rule sep_wand_match, assumption)
  apply (erule sep_curry[rotated])
  apply (metis (no_types) sep_conj_sep_impl2 sep_conj_commute sep_wand_collapse)
  done

lemma sep_factor_foldI:
  "(R' \<and>* (sep_fold P Q R xs)) s \<Longrightarrow>
   sep_fold (\<lambda>x. R' \<and>* P x) (\<lambda>x. R' \<and>* Q x) (R' \<and>* R) xs s"
  apply (induct xs arbitrary: s; clarsimp simp: sep_fold_def)
  apply (clarsimp simp: sep_conj_ac)
  apply (erule (1) sep_conj_impl)
  apply (erule (1) sep_conj_impl)
  apply (erule sep_conj_sep_impl)
  apply (clarsimp simp: sep_conj_ac)
  apply (drule (1) sep_conj_impl)
   apply (subst (asm) sep_conj_commute, erule (1) sep_conj_sep_impl2)
  by blast

end


(******************************************************************************
 * Orca: A Functional Correctness Verifier for Imperative Programs
 *       Based on Isabelle/UTP
 *
 * Copyright (c) 2016-2018 Virginia Tech, USA
 *               2016-2018 Technische Universität München, Germany
 *               2016-2018 University of York, UK
 *               2016-2018 Université Paris-Saclay, Univ. Paris-Sud, France
 *
 * This software may be distributed and modified according to the terms of
 * the GNU Lesser General Public License version 3.0 or any later version.
 * Note that NO WARRANTY is provided.
 *
 * See CONTRIBUTORS, LICENSE and CITATION files for details.
 ******************************************************************************)

section \<open>Algebraic laws of programming\<close>

text \<open>In this section we introduce the semantic rules related to the different
      statements of IMP. In the literature this also known as the algebraic laws of programming.
      In our framework we will use these rules in order to optimize a given program written in our
      language, and this before any deductive proof verification activity or formal testing.\<close>

theory Algebraic_Laws_aux
  imports "../../Isabelle-UTP/theories/utp_designs"
begin

subsection \<open>Complementing usubst\<close>
lemma bool_seqr_laws [usubst]:
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s true) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>true/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s false) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>false/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s true) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>true/$x\<acute>\<rbrakk>)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s false) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>false/$x\<acute>\<rbrakk>)"
    by (simp_all add: bool_seqr_laws)

subsection \<open>Complementing unrest\<close>
lemma undep_imp_unrest[unrest]: (*FIXME:This law should be used by alphabet-backend to automatically generate unrest between different fields*)
  assumes "x \<bowtie> y "
  shows "$x \<sharp> $y"
  using assms unfolding lens_indep_def
  by pred_auto

subsection \<open>Complementing laws for preds\<close>

lemma upred_not_not[simp]:
"\<not> \<not> P = P"
  by rel_auto

subsection \<open>Laws for urel\<close>

lemma unrest_iuvar_not[unrest]: "out\<alpha> \<sharp> (\<not>$x)"
  by rel_auto

lemma unrest_ouvar_not[unrest]: "in\<alpha> \<sharp> (\<not>$x\<acute>)"
  by rel_auto

lemma assigns_r_usubst_skip_r[usubst]:
  "(\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> II) =  \<langle>\<sigma>\<rangle>\<^sub>a"
  by rel_auto

lemma cond_not_cond_L6_right[urel_cond]:
  "(P \<triangleleft> b \<triangleright> (Q \<triangleleft> \<not> b \<triangleright> R)) = (P \<triangleleft> b \<triangleright> Q)"
  by rel_auto

lemma cond_not_cond_L6_right_variant[urel_cond]:
  "(P \<triangleleft> \<not> b \<triangleright> (Q \<triangleleft>  b \<triangleright> R)) = (P \<triangleleft> \<not> b \<triangleright> Q)"
  by rel_auto

lemma cond_not_cond_L6_left[urel_cond]:
  "((P \<triangleleft> b \<triangleright> Q) \<triangleleft> \<not> b \<triangleright> R) = (Q \<triangleleft>\<not> b \<triangleright> R)"
  by rel_auto

lemma cond_not_cond_L6_left_variant[urel_cond]:
  "((P \<triangleleft> \<not> b \<triangleright> Q) \<triangleleft> b \<triangleright> R) = (Q \<triangleleft> b \<triangleright> R)"
  by rel_auto

lemma cond_L6_left[urel_cond]:
  "((P \<triangleleft>  b \<triangleright> Q) \<triangleleft> b \<triangleright> R) = (P \<triangleleft> b \<triangleright> R)"
  by rel_auto

subsection \<open>Laws for des\<close>

lemma usubst_d_true[usubst]: "\<sigma> \<dagger> \<lceil>true\<rceil>\<^sub>D = \<lceil>true\<rceil>\<^sub>D"
  by rel_auto

lemma usubst_d_false[usubst]: "\<sigma> \<dagger> \<lceil>false\<rceil>\<^sub>D = \<lceil>false\<rceil>\<^sub>D"
  by rel_auto

lemma usubst_des_skip_des [usubst]:
  assumes "$ok \<sharp> \<sigma>" "$ok\<acute> \<sharp> \<sigma>"
  shows "(\<sigma> \<dagger> II\<^sub>D) = (\<lceil>true\<rceil>\<^sub>D \<turnstile> (\<sigma> \<dagger> \<lceil>II\<rceil>\<^sub>D))"
  using assms unfolding skip_d_def rdesign_def
  by (simp add: assms usubst)

lemma cond_L6_right_des[urel_cond]:
  "(R \<triangleleft> b \<triangleright> (S \<turnstile> (P \<triangleleft> b \<triangleright> Q))) = (R \<triangleleft> b \<triangleright> (S \<turnstile> Q))"
  by rel_auto

lemma cond_L6_left_des[urel_cond]:
  "((S \<turnstile> (P \<triangleleft> b \<triangleright> Q)) \<triangleleft> b \<triangleright> R) = (S \<turnstile> P \<triangleleft>b \<triangleright> R)"
  by rel_auto

lemma cond_not_cond_L6_right_des[urel_cond]:
  "( R \<triangleleft> \<not> b \<triangleright> (S \<turnstile> (P \<triangleleft> b \<triangleright> Q)) ) = (R \<triangleleft> \<not> b \<triangleright> (S \<turnstile> P))"
  by rel_auto

lemma cond_not_cond_L6_right_des_variant[urel_cond]:
  "R \<triangleleft> b \<triangleright> (S \<turnstile> (P \<triangleleft> \<not> b \<triangleright> Q)) = R \<triangleleft> b \<triangleright> (S \<turnstile> P)"
  by rel_auto

lemma cond_not_cond_L6_left_des[urel_cond]:
  "((S \<turnstile> (P \<triangleleft> b \<triangleright> Q)) \<triangleleft> \<not> b \<triangleright> R) = ((S \<turnstile> Q) \<triangleleft> \<not> b \<triangleright> R)"
  by rel_auto

lemma cond_not_cond_L6_left_des_variant[urel_cond]:
  "((S \<turnstile> (P \<triangleleft> \<not> b \<triangleright> Q)) \<triangleleft> b \<triangleright> R) = ((S \<turnstile> Q) \<triangleleft> b \<triangleright> R)"
  by rel_auto

end


(*
 * Copyright 2018, Data61
 * Commonwealth Scientific and Industrial Research Organisation (CSIRO)
 * ABN 41 687 119 230.
 *
 * 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(DATA61_BSD)
 *)

theory StringMap

(* assumes CParser or AutoCorres to find StaticFun *)
imports CParser.StaticFun

begin

datatype LexOrdString = LexOrdString "string"

instantiation LexOrdString :: linorder begin

definition
  less_LexOrdString_def[simp]:
  "(s < t) = (case s of LexOrdString s' \<Rightarrow> case t of LexOrdString t' \<Rightarrow>
    (s', t') \<in> lexord {(c, c'). (of_char c :: nat) < of_char c'})"

definition
  le_LexOrdString_def[simp]:
  "(s \<le> t) = ((s :: LexOrdString) < t \<or> s = t)"

lemma nat_of_char_trans:
  "trans {(c, c'). (of_char c :: nat) < of_char c'}"
  by (auto intro!: transI)

instance
  apply intro_classes
      apply (clarsimp split: LexOrdString.split)
      apply safe[1]
       apply (drule(1) lexord_trans[OF _ _ nat_of_char_trans])
       apply (simp add: lexord_irreflexive)
      apply (simp add: lexord_irreflexive)
     apply (clarsimp)
    apply (clarsimp split: LexOrdString.split_asm)
    apply safe[1]
    apply (erule(1) lexord_trans)
    apply (rule nat_of_char_trans)
   apply (clarsimp split: LexOrdString.split_asm)
   apply safe[1]
   apply (drule(1) lexord_trans[OF _ _ nat_of_char_trans])
   apply (simp add: lexord_irreflexive)
  apply (clarsimp split: LexOrdString.split)
  apply (rename_tac lista listb)
  apply (cut_tac lexord_linear[where r="{(c, c'). (of_char c :: nat) < of_char c'}"])
   apply auto
  done

end

ML \<open>

structure StringMap = struct

fun define_string_map name assocs ctxt =
  let
    val th_names = map (prefix (Binding.name_of name ^ "_") o fst) assocs
    val mappings = map (apfst HOLogic.mk_string) assocs
  in StaticFun.define_tree_and_save_thms name th_names mappings
    @{term LexOrdString} @{thms of_char_def} ctxt
  end
end

\<close>

text \<open> Testing \<close>

(*
local_setup \<open> StringMap.define_string_map @{binding foo}
  [("x", @{term "1 :: nat"}), ("y", @{term "2 :: nat"})]
  #> snd
\<close>
*)

end


section\<open>Increment and Reset\<close>
text\<open>The ``increment and reset'' heuristic proposed in \cite{foster2019} is a naive way of
introducing an incrementing register into a model. This this theory implements that heuristic.\<close>

theory Increment_Reset
  imports "../Inference"
begin

definition initialiseReg :: "transition \<Rightarrow> nat \<Rightarrow> transition" where
  "initialiseReg t newReg = \<lparr>Label = Label t, Arity = Arity t, Guards = Guards t, Outputs = Outputs t, Updates = ((newReg, L (Num 0))#Updates t)\<rparr>"

definition "guardMatch t1 t2  = (\<exists>n n'. Guards t1 = [gexp.Eq (V (vname.I 0)) (L (Num n))] \<and> Guards t2 = [gexp.Eq (V (vname.I 0)) (L (Num n'))])"
definition "outputMatch t1 t2 = (\<exists>m m'. Outputs t1 = [L (Num m)] \<and> Outputs t2 = [L (Num m')])"

lemma guard_match_commute: "guardMatch t1 t2 = guardMatch t2 t1"
  apply (simp add: guardMatch_def)
  by auto

lemma guard_match_length:
  "length (Guards t1) \<noteq> 1 \<or> length (Guards t2) \<noteq> 1 \<Longrightarrow> \<not> guardMatch t1 t2"
  apply (simp add: guardMatch_def)
  by auto

fun insert_increment :: update_modifier where
  "insert_increment t1ID t2ID s new _ old check = (let
     t1 = get_by_ids new t1ID;
     t2 = get_by_ids new t2ID in
     if guardMatch t1 t2 \<and> outputMatch t1 t2 then let
          r = case max_reg new of None \<Rightarrow> 1 | Some r \<Rightarrow> r+ 1;
          newReg = R r;
          newT1 = \<lparr>Label = Label t1, Arity = Arity t1, Guards = [], Outputs = [Plus (V newReg) (V (vname.I 0))], Updates=((r, Plus (V newReg) (V (vname.I 0)))#Updates t1)\<rparr>;
          newT2 = \<lparr>Label = Label t2, Arity = Arity t2, Guards = [], Outputs = [Plus (V newReg) (V (vname.I 0))], Updates=((r, Plus (V newReg) (V (vname.I 0)))#Updates t2)\<rparr>;
          to_initialise = ffilter (\<lambda>(uid, (from, to), t). (to = dest t1ID new \<or> to = dest t2ID new) \<and> t \<noteq> t1 \<and> t \<noteq> t2) new;
          initialisedTrans = fimage (\<lambda>(uid, (from, to), t). (uid, initialiseReg t r)) to_initialise;
          initialised = replace_transitions new (sorted_list_of_fset initialisedTrans);
          rep = replace_transitions new [(t1ID, newT1), (t2ID, newT2)]
     in
          if check (tm rep) then Some rep else None
     else
       None
     )"

definition struct_replace_all :: "iEFSM \<Rightarrow> transition \<Rightarrow> transition \<Rightarrow> iEFSM" where
  "struct_replace_all e old new = (let
    to_replace = ffilter (\<lambda>(uid, (from, dest), t). same_structure t old) e;
    replacements = fimage (\<lambda>(uid, (from, to), t). (uid, new)) to_replace
    in
    replace_transitions e (sorted_list_of_fset replacements))"

lemma output_match_symmetry: "(outputMatch t1 t2) = (outputMatch t2 t1)"
  apply (simp add: outputMatch_def)
  by auto

lemma guard_match_symmetry: "(guardMatch t1 t2) = (guardMatch t2 t1)"
  apply (simp add: guardMatch_def)
  by auto

fun insert_increment_2 :: update_modifier where
  "insert_increment_2 t1ID t2ID s new _ old check = (let
     t1 = get_by_ids new t1ID;
     t2 = get_by_ids new t2ID in
     if guardMatch t1 t2 \<and> outputMatch t1 t2 then let
          r = case max_reg new of None \<Rightarrow> 1 | Some r \<Rightarrow> r + 1;
          newReg = R r;
          newT1 = \<lparr>Label = Label t1, Arity = Arity t1, Guards = [], Outputs = [Plus (V newReg) (V (vname.I 0))], Updates=((r, Plus (V newReg) (V (vname.I 0)))#Updates t1)\<rparr>;
          newT2 = \<lparr>Label = Label t2, Arity = Arity t2, Guards = [], Outputs = [Plus (V newReg) (V (vname.I 0))], Updates=((r, Plus (V newReg) (V (vname.I 0)))#Updates t2)\<rparr>;
          to_initialise = ffilter (\<lambda>(uid, (from, to), t). (to = dest t1ID new \<or> to = dest t2ID new) \<and> t \<noteq> t1 \<and> t \<noteq> t2) new;
          initialisedTrans = fimage (\<lambda>(uid, (from, to), t). (uid, initialiseReg t r)) to_initialise;
          initialised = replace_transitions new (sorted_list_of_fset initialisedTrans);
          rep = struct_replace_all (struct_replace_all initialised t2 newT2) t1 newT1
      in
          if check (tm rep) then Some rep else None
     else
       None
     )"

fun guardMatch_alt_2 :: "vname gexp list \<Rightarrow> bool" where
  "guardMatch_alt_2 [(gexp.Eq (V (vname.I i)) (L (Num n)))] = (i = 1)" |
  "guardMatch_alt_2 _ = False"

fun outputMatch_alt_2 :: "vname aexp list \<Rightarrow> bool" where
  "outputMatch_alt_2 [(L (Num n))] = True" |
  "outputMatch_alt_2 _ = False"

end


(*  Title:      Jinja/J/execute_WellType.thy
    Author:     Christoph Petzinger
    Copyright   2004 Technische Universitaet Muenchen
*)

section \<open>Code Generation For WellType\<close>

theory execute_WellType
imports
  WellType Examples
begin

(* Replace WT_WTs.WTCond with new intros WT_WTs.WTCond1 and WT_WTs.WTCond2 *)

lemma WTCond1:
  "\<lbrakk>P,E \<turnstile> e :: Boolean;  P,E \<turnstile> e\<^sub>1::T\<^sub>1;  P,E \<turnstile> e\<^sub>2::T\<^sub>2; P \<turnstile> T\<^sub>1 \<le> T\<^sub>2;
    P \<turnstile> T\<^sub>2 \<le> T\<^sub>1 \<longrightarrow> T\<^sub>2 = T\<^sub>1 \<rbrakk> \<Longrightarrow> P,E \<turnstile> if (e) e\<^sub>1 else e\<^sub>2 :: T\<^sub>2"
by (fastforce)

lemma WTCond2:
  "\<lbrakk>P,E \<turnstile> e :: Boolean;  P,E \<turnstile> e\<^sub>1::T\<^sub>1;  P,E \<turnstile> e\<^sub>2::T\<^sub>2; P \<turnstile> T\<^sub>2 \<le> T\<^sub>1;
    P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<longrightarrow> T\<^sub>1 = T\<^sub>2 \<rbrakk> \<Longrightarrow> P,E \<turnstile> if (e) e\<^sub>1 else e\<^sub>2 :: T\<^sub>1"
by (fastforce)

lemmas [code_pred_intro] =
  WT_WTs.WTNew
  WT_WTs.WTCast
  WT_WTs.WTVal
  WT_WTs.WTVar
  WT_WTs.WTBinOpEq
  WT_WTs.WTBinOpAdd
  WT_WTs.WTLAss
  WT_WTs.WTFAcc
  WT_WTs.WTFAss
  WT_WTs.WTCall
  WT_WTs.WTBlock
  WT_WTs.WTSeq

declare
  WTCond1 [code_pred_intro WTCond1]
  WTCond2 [code_pred_intro WTCond2]

lemmas [code_pred_intro] =
  WT_WTs.WTWhile
  WT_WTs.WTThrow
  WT_WTs.WTTry
  WT_WTs.WTNil
  WT_WTs.WTCons

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool as type_check, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool as infer_type)
  WT
proof -
  case WT
  from WT.prems show thesis
  proof(cases (no_simp))
    case (WTCond E e e1 T1 e2 T2 T)
    from \<open>x \<turnstile> T1 \<le> T2 \<or> x \<turnstile> T2 \<le> T1\<close> show thesis
    proof
      assume "x \<turnstile> T1 \<le> T2"
      with \<open>x \<turnstile> T1 \<le> T2 \<longrightarrow> T = T2\<close> have "T = T2" ..
      from \<open>xa = E\<close> \<open>xb = if (e) e1 else e2\<close> \<open>xc = T\<close> \<open>x,E \<turnstile> e :: Boolean\<close>
        \<open>x,E \<turnstile> e1 :: T1\<close> \<open>x,E \<turnstile> e2 :: T2\<close> \<open>x \<turnstile> T1 \<le> T2\<close> \<open>x \<turnstile> T2 \<le> T1 \<longrightarrow> T = T1\<close>
      show ?thesis unfolding \<open>T = T2\<close> by(rule WT.WTCond1[OF refl])
    next
      assume "x \<turnstile> T2 \<le> T1"
      with \<open>x \<turnstile> T2 \<le> T1 \<longrightarrow> T = T1\<close> have "T = T1" ..
      from \<open>xa = E\<close> \<open>xb = if (e) e1 else e2\<close> \<open>xc = T\<close> \<open>x,E \<turnstile> e :: Boolean\<close>
        \<open>x,E \<turnstile> e1 :: T1\<close> \<open>x,E \<turnstile> e2 :: T2\<close> \<open>x \<turnstile> T2 \<le> T1\<close> \<open>x \<turnstile> T1 \<le> T2 \<longrightarrow> T = T2\<close>
      show ?thesis unfolding \<open>T = T1\<close> by(rule WT.WTCond2[OF refl])
    qed
  qed(assumption|erule (2) WT.that[OF refl])+
next
  case WTs
  from WTs.prems show thesis
    by(cases (no_simp))(assumption|erule (2) WTs.that[OF refl])+
qed

notation infer_type ("_,_ \<turnstile> _ :: '_" [51,51,51]100)

definition test1 where "test1 = [],Map.empty \<turnstile> testExpr1 :: _"
definition test2 where "test2 = [], Map.empty  \<turnstile> testExpr2 :: _"
definition test3 where "test3 = [], Map.empty(''V'' \<mapsto> Integer)  \<turnstile> testExpr3 :: _"
definition test4 where "test4 = [], Map.empty(''V'' \<mapsto> Integer)  \<turnstile> testExpr4 :: _"
definition test5 where "test5 = [classObject, (''C'',(''Object'',[(''F'',Integer)],[]))], Map.empty  \<turnstile> testExpr5 :: _"
definition test6 where "test6 = [classObject, classI], Map.empty  \<turnstile> testExpr6 :: _"

ML_val \<open>
  val SOME(@{code Integer}, _) = Predicate.yield @{code test1};
  val SOME(@{code Integer}, _) = Predicate.yield @{code test2};
  val SOME(@{code Integer}, _) = Predicate.yield @{code test3};
  val SOME(@{code Void}, _) = Predicate.yield @{code test4};
  val SOME(@{code Void}, _) = Predicate.yield @{code test5};
  val SOME(@{code Integer}, _) = Predicate.yield @{code test6};
\<close>

definition testmb_isNull where "testmb_isNull = [classObject, classA], Map.empty([this] [\<mapsto>] [Class ''A'']) \<turnstile> mb_isNull :: _"
definition testmb_add where "testmb_add = [classObject, classA], Map.empty([this,''i''] [\<mapsto>] [Class ''A'',Integer]) \<turnstile> mb_add :: _"
definition testmb_mult_cond where "testmb_mult_cond = [classObject, classA], Map.empty([this,''j''] [\<mapsto>] [Class ''A'',Integer]) \<turnstile> mb_mult_cond :: _"
definition testmb_mult_block where "testmb_mult_block = [classObject, classA], Map.empty([this,''i'',''j'',''temp''] [\<mapsto>] [Class ''A'',Integer,Integer,Integer]) \<turnstile> mb_mult_block :: _"
definition testmb_mult where "testmb_mult = [classObject, classA], Map.empty([this,''i'',''j''] [\<mapsto>] [Class ''A'',Integer,Integer]) \<turnstile> mb_mult :: _"

ML_val \<open>
  val SOME(@{code Boolean}, _) = Predicate.yield @{code testmb_isNull};
  val SOME(@{code Integer}, _) = Predicate.yield @{code testmb_add};
  val SOME(@{code Boolean}, _) = Predicate.yield @{code testmb_mult_cond};
  val SOME(@{code Void}, _) = Predicate.yield @{code testmb_mult_block};
  val SOME(@{code Integer}, _) = Predicate.yield @{code testmb_mult};
\<close>

definition test where "test = [classObject, classA], Map.empty \<turnstile> testExpr_ClassA :: _"

ML_val \<open>
  val SOME(@{code Integer}, _) = Predicate.yield @{code test};
\<close>

end


(*
  This file contains the locale WordArray which includes the locale generated by AutoCorres from
  the C file containing the word array functions.

  This file also includes the proof that the WordArray locale is a subset of the top level
  correspondence locale.

  This file also contains the various abstractions for the word array functions.
*)

theory WordArray_Abstractions
  imports "../build_random_seed/Random_seed_master_AllRefine"
begin

section "Helper Word Lemmas"

lemma word_mult_cancel_left:
  fixes a b c :: "('a::len) word"
  assumes "uint c * uint a \<le> uint (max_word :: ('a::len) word)"
  assumes "uint c * uint b \<le> uint (max_word :: ('a::len) word)"
  shows "c * a = c * b \<longleftrightarrow> c = 0 \<or> a = b"
  apply (rule iffI)
   using assms
   apply (unfold word_mult_def word_of_int_def)
    apply (clarsimp simp:Abs_word_inject max_word_def uint_word_of_int m1mod2k uint_0_iff )
   apply fastforce
   done

lemma word_mult_cancel_left_bounded:
  fixes a b c d :: "('a::len) word"
  assumes "a \<le> d" "b \<le> d"
  assumes "unat c * unat d \<le> unat (max_word :: ('a::len) word)"
  shows "c * a = c * b \<longleftrightarrow> c = 0 \<or> a = b"
  using assms
  apply -
  apply (clarsimp simp: word_le_nat_alt)
  apply (frule_tac i = "unat a" and j = "unat d" and k = "unat c" in mult_le_mono2)
  apply (drule_tac i = "unat b" and j = "unat d" and k = "unat c" in mult_le_mono2)
  by (metis (mono_tags, hide_lams) assms(3) le_unat_uoi mult_left_cancel mult_zero_left not_less_iff_gr_or_eq unat_0 unat_mono word_arith_nat_mult)

section "Helper Functions"

fun is_prim_type :: "type \<Rightarrow> bool"
  where
"is_prim_type (TPrim _) = True" |
"is_prim_type _ = False"

fun is_num_type :: "prim_type \<Rightarrow> bool"
  where
"is_num_type (Num _) = True" |
"is_num_type _ = False"

fun size_of_num_type :: "num_type \<Rightarrow> ptrtyp"
  where
"size_of_num_type U8 = 1" |
"size_of_num_type U16 = 2" |
"size_of_num_type U32 = 4" |
"size_of_num_type U64 = 8"

lemma size_of_num_type_not_zero:
  "size_of_num_type t \<noteq> 0"
  by (case_tac t; clarsimp)

fun zero_num_lit :: "num_type \<Rightarrow> lit"
  where
"zero_num_lit U8 = LU8 0" |
"zero_num_lit U16 = LU16 0" |
"zero_num_lit U32 = LU32 0" |
"zero_num_lit U64 = LU64 0"

fun funarg_type :: "type \<Rightarrow> type"
  where
"funarg_type (TFun a b) = a" |
"funarg_type _ = undefined"

fun funret_type :: "type \<Rightarrow> type"
  where
"funret_type (TFun a b) = b" |
"funret_type _ = undefined"

fun present_type :: "name \<times> type \<times> record_state \<Rightarrow> type"
  where
"present_type (_, t, Present) = t" |
"present_type (_, _, Taken) = undefined"

fun rec_type_list :: "type \<Rightarrow> (name \<times> type \<times> record_state) list"
  where
"rec_type_list (TRecord ts _) = ts" |
"rec_type_list _ = undefined"

fun is_uval_fun :: "('f, 'a, 'l) uval \<Rightarrow> bool"
  where
"is_uval_fun (UFunction _ _) = True" |
"is_uval_fun (UAFunction _ _) = True" |
"is_uval_fun _ = False"

fun uvalfun_to_exprfun :: "('f, 'a, 'l) uval \<Rightarrow> 'f expr"
  where
"uvalfun_to_exprfun (UFunction f ts) = Fun f ts" |
"uvalfun_to_exprfun (UAFunction f ts) = AFun f ts" |
"uvalfun_to_exprfun _ = undefined"

fun is_vval_fun :: "('f, 'a) vval \<Rightarrow> bool"
  where
"is_vval_fun (VFunction _ _) = True" |
"is_vval_fun (VAFunction _ _) = True" |
"is_vval_fun _ = False"

fun vvalfun_to_exprfun :: "('f, 'a) vval \<Rightarrow> 'f expr"
  where
"vvalfun_to_exprfun (VFunction f ts) = Fun f ts" |
"vvalfun_to_exprfun (VAFunction f ts) = AFun f ts" |
"vvalfun_to_exprfun _ = undefined"

section "Helper Frame Lemmas"

lemma valid_ptr_not_in_frame_same:
  "\<lbrakk>frame \<sigma> w \<sigma>' w'; p \<notin> w; \<sigma> p = option.Some x\<rbrakk> \<Longrightarrow> \<sigma>' p = option.Some x"
  apply (clarsimp simp: frame_def)
  apply (erule_tac x = p in allE)
  apply clarsimp
  done

lemma readonly_not_in_frame:
  "\<lbrakk>frame \<sigma> w \<sigma>' w'; \<sigma> p = option.Some v; p \<notin> w\<rbrakk> \<Longrightarrow> p \<notin> w'"
  apply (frule_tac p = p in valid_ptr_not_in_frame_same; simp?)
  by (clarsimp simp: frame_def)

lemma frame_expand:
  "\<lbrakk>frame \<sigma> w \<sigma>' w'; \<sigma> p \<noteq> option.None\<rbrakk> \<Longrightarrow> frame \<sigma> (insert p w) \<sigma>' (insert p w')"
  "\<lbrakk>frame \<sigma> w \<sigma>' w'; \<forall>p\<in>s. \<sigma> p \<noteq> option.None\<rbrakk> \<Longrightarrow> frame \<sigma> (s \<union> w) \<sigma>' (s \<union> w')"
   apply (clarsimp simp: frame_def)
   apply (rule conjI; clarsimp)
  apply (clarsimp simp: frame_def)
  apply (rule conjI; clarsimp)
  done
ML \<open>\<close>
section "WordArray Locale Definition"

text "Embedding of values of abstract types in the Value semantics"
datatype vatyp = VSeed  | VTOther
type_synonym vabstyp = vatyp

locale WordArray = main_pp_inferred begin

  text
  "Maps an abstract type to it type representation."
  definition "wa_abs_repr a \<equiv> case a of
      UWA (TPrim (Num t)) _ _ \<Rightarrow> (''WordArray'', [RPrim (Num t)])
    | _ \<Rightarrow> (''Unknown Abstract Type'', [])"

  text
  "Value typing for word arrays in the Update semantics"
  definition "wa_abs_typing_u a name \<tau>s sig (r :: ptrtyp set) (w :: ptrtyp set) \<sigma> \<equiv>
    (case a of
      UWA (TPrim (Num t)) len arr \<Rightarrow> name = ''WordArray'' \<and> \<tau>s = [TPrim (Num t)] \<and> sig \<noteq> Unboxed \<and>
                      (sigil_perm sig = option.Some ReadOnly \<longrightarrow> w = {} \<and>
                        r = {arr + size_of_num_type t * i | i. i < len}) \<and>
                      (sigil_perm sig = option.Some Writable \<longrightarrow> r = {} \<and>
                        w = {arr + size_of_num_type t * i | i. i < len}) \<and>
                      (\<forall>i < len. \<exists>x. \<sigma>(arr + size_of_num_type t * i) = option.Some (UPrim x) \<and> lit_type x = Num t) \<and>
                      unat (size_of_num_type t)  * unat len \<le> unat (max_word :: ptrtyp)
    | _ \<Rightarrow> name = ''Unknown Abstract Type'' \<and> \<tau>s = [] \<and> r = {} \<and> w = {} \<and> sig = Unboxed)"

  text
  "Value typing for word arrays in the Value semantics "
  definition "wa_abs_typing_v a name \<tau>s \<equiv>
    (case a of
      VWA (TPrim (Num t)) xs \<Rightarrow> name = ''WordArray'' \<and> \<tau>s = [TPrim (Num t)] \<and>
      (\<forall>i < length xs. \<exists>x. xs ! i = VPrim x \<and>  lit_type x = Num t)
    | _ \<Rightarrow> name = ''Unknown Abstract Type'' \<and> \<tau>s = [])"

  text
  "Value relation for word arrays between the Update and Value semantics "
  definition  "wa_abs_upd_val au av name \<tau>s sig (r :: ptrtyp set) (w :: ptrtyp set) \<sigma> \<equiv>
    wa_abs_typing_u au name \<tau>s sig r w \<sigma> \<and> wa_abs_typing_v av name \<tau>s \<and>
    (case au of
      UWA (TPrim (Num t)) len arr \<Rightarrow>
        (case av of
          VWA (TPrim (Num t)) xs \<Rightarrow> unat len = length xs \<and> \<tau>s = [TPrim (Num t)] \<and>
          (\<forall>i < len. \<exists>x. \<sigma> (arr + size_of_num_type t * i) = option.Some (UPrim x) \<and> xs ! unat i = VPrim x \<and> lit_type x = Num t)
          | _ \<Rightarrow> False)
      | _ \<Rightarrow> (case av of
                VTOther _ \<Rightarrow> True
             |  _ \<Rightarrow> False))"

  text "Helper lemma to show that two indexes in an array are distinct"
  lemma distinct_indices:
    "wa_abs_typing_u (UWA (TPrim (Num t)) len arr) n ts s r w \<sigma> \<Longrightarrow>
      \<forall>i < len. \<forall>j < len. i = j \<longleftrightarrow> size_of_num_type t * i = size_of_num_type t * j"
  apply clarsimp
  apply (rule iffI)
   apply clarsimp
  apply (clarsimp simp: wa_abs_typing_u_def)
  apply (cut_tac a = i and b = j and c = "size_of_num_type t" and d = len in word_mult_cancel_left_bounded; simp)
  apply (erule disjE; clarsimp)
  apply (case_tac t; clarsimp)
  done

  lemma wa_abs_typing_u_elims:
    "wa_abs_typing_u a ''WordArray'' \<tau>s s r w \<sigma>
      \<Longrightarrow> \<exists>len arr t. a = UWA (TPrim (Num t)) len arr \<and> \<tau>s = [TPrim (Num t)]"
    "wa_abs_typing_u (UWA (TPrim (Num t)) len arr) n \<tau>s (Boxed ReadOnly ptrl) r w \<sigma>
    \<Longrightarrow> r = {arr + size_of_num_type t * i | i. i < len} \<and> w = {}"
    "wa_abs_typing_u (UWA (TPrim (Num t)) len arr) n \<tau>s (Boxed Writable ptrl) r w \<sigma>
      \<Longrightarrow> r = {} \<and> w = {arr + size_of_num_type t * i | i. i < len}"
    "wa_abs_typing_u a ''WordArray'' \<tau>s s r w \<sigma> \<Longrightarrow> s \<noteq> Unboxed"
    "wa_abs_typing_u (UWA (TPrim (Num t)) len arr) n \<tau>s s r w \<sigma>
      \<Longrightarrow> \<forall>i < len. \<exists>x. \<sigma> (arr + size_of_num_type t * i) = option.Some (UPrim x) \<and> lit_type x = Num t"
    "wa_abs_typing_u (UWA (TPrim (Num t)) len arr) n \<tau>s s r w \<sigma>
      \<Longrightarrow> unat (size_of_num_type t) * unat len \<le> unat (max_word :: ptrtyp)"
    "wa_abs_typing_u (UWA (TPrim (Num t)) len arr) n \<tau>s s r w \<sigma> \<Longrightarrow> n = ''WordArray''"
  by (unfold wa_abs_typing_u_def[abs_def]; clarsimp split: atyp.splits type.splits prim_type.splits)+

lemma wa_abs_typing_v_elims:
  "wa_abs_typing_v a ''WordArray'' \<tau>s \<Longrightarrow> \<exists>t xs. a = VWA (TPrim (Num t)) xs \<and> \<tau>s = [TPrim (Num t)]"
  "wa_abs_typing_v (VWA (TPrim (Num t)) xs) n \<tau>s
    \<Longrightarrow> \<forall>i < length xs. \<exists>x. xs ! i = VPrim x \<and> lit_type x = Num t"
  "wa_abs_typing_v (VWA (TPrim (Num t)) xs) n \<tau>s  \<Longrightarrow> n = ''WordArray''"
  by (unfold wa_abs_typing_v_def[abs_def]; clarsimp split: vatyp.splits type.splits prim_type.splits)+

lemma wa_abs_upd_val_elims:
  "wa_abs_upd_val au av n \<tau>s s r w \<sigma> \<Longrightarrow> wa_abs_typing_u au n \<tau>s s r w \<sigma>"
  "wa_abs_upd_val au av n \<tau>s s r w \<sigma> \<Longrightarrow> wa_abs_typing_v av n \<tau>s"
  "wa_abs_upd_val (UWA \<tau> len arr) (VWA \<tau> xs) n \<tau>s s r w \<sigma>
    \<Longrightarrow> unat len = length xs"
  "wa_abs_upd_val (UWA (TPrim (Num t)) len arr) (VWA (TPrim (Num t)) xs) n \<tau>s s r w \<sigma>
    \<Longrightarrow> \<forall>i < len. \<exists>x. \<sigma> (arr + size_of_num_type t * i) = option.Some (UPrim x) \<and>
      xs ! unat i = VPrim x \<and> lit_type x = Num t"
  by (unfold wa_abs_upd_val_def[abs_def];
      clarsimp split: atyp.splits vatyp.splits type.splits prim_type.splits)+

lemma wa_abs_typing_u_update:
  "\<lbrakk>wa_abs_typing_u (UWA (TPrim (Num t)) len arr) n \<tau>s (Boxed Writable ptrl) r w \<sigma>;
    i < len; lit_type v = Num t\<rbrakk>
    \<Longrightarrow> wa_abs_typing_u (UWA (TPrim (Num t)) len arr) n \<tau>s (Boxed Writable ptrl) r w
      (\<sigma> ((arr + size_of_num_type t * i) \<mapsto> (UPrim v)))"
  by (clarsimp simp: wa_abs_typing_u_def)

lemma wa_abs_typing_v_update:
  "\<lbrakk>wa_abs_typing_v (VWA (TPrim (Num t)) xs) n \<tau>s; i < length xs; lit_type v = Num t\<rbrakk>
    \<Longrightarrow> wa_abs_typing_v (VWA (TPrim (Num t)) (xs[i := VPrim v])) n \<tau>s"
  apply (clarsimp simp: wa_abs_typing_v_def)
  apply (erule_tac x = ia in allE)
  apply (clarsimp simp: nth_list_update)
  done

lemma wa_abs_upd_val_update:
  "\<lbrakk>wa_abs_upd_val (UWA (TPrim (Num t)) len arr) (VWA (TPrim (Num t)) xs) n \<tau>s (Boxed Writable ptrl) r w \<sigma>;
    i < len; lit_type v = Num t\<rbrakk>
    \<Longrightarrow> wa_abs_upd_val (UWA (TPrim (Num t)) len arr) (VWA (TPrim (Num t)) (xs[unat i := VPrim v])) n
      \<tau>s (Boxed Writable ptrl) r w (\<sigma> ((arr + size_of_num_type t * i) \<mapsto> (UPrim v)))"
  apply (clarsimp simp: wa_abs_upd_val_def)
  apply (drule wa_abs_typing_u_update; simp?; clarsimp)
  apply (drule_tac i = "unat i" in wa_abs_typing_v_update; simp add: word_less_nat_alt; clarsimp)
  apply (rule conjI; clarsimp simp: nth_list_update)
  apply (cut_tac a = ia and b = i and c = "size_of_num_type t" and d = len in word_mult_cancel_left_bounded; simp?)
     apply (clarsimp simp: word_less_nat_alt word_le_nat_alt)+
   apply (fastforce dest: wa_abs_typing_u_elims(6))
  apply (case_tac t; clarsimp)
  done

end

section "Sublocale Proof"

text
  "Here we prove that our value typing relations and value relations for word arrays satisfies
   Cogent's FFI constraints."

sublocale WordArray \<subseteq> Generated_cogent_shallow _ wa_abs_repr wa_abs_typing_v wa_abs_typing_u wa_abs_upd_val
  apply (unfold wa_abs_repr_def[abs_def] wa_abs_typing_v_def[abs_def] wa_abs_typing_u_def[abs_def] wa_abs_upd_val_def[abs_def])
  apply (unfold_locales; clarsimp split: vatyp.splits atyp.splits)
               apply (clarsimp split: type.splits prim_type.splits)
              apply (clarsimp split: type.splits prim_type.splits)
              apply (rename_tac s r w \<sigma> len arr t)
              apply (case_tac s; clarsimp; rename_tac perm ptrl; case_tac perm; clarsimp)
             apply (clarsimp split: type.splits prim_type.splits)
             apply (case_tac s; clarsimp; rename_tac perm; case_tac perm; clarsimp)
            apply (clarsimp split: type.splits prim_type.splits)
            apply (case_tac s; clarsimp; rename_tac perm; case_tac perm; clarsimp)
           apply (clarsimp split: type.splits prim_type.splits)
           apply (case_tac s; clarsimp; rename_tac perm; case_tac perm; clarsimp)
          apply (clarsimp split: type.splits prim_type.splits)
          apply (case_tac s; clarsimp; rename_tac perm; case_tac perm; clarsimp; blast)
         apply (clarsimp split: type.splits prim_type.splits)
         apply (case_tac s; clarsimp; rename_tac perm; case_tac perm; clarsimp; case_tac s'; clarsimp)
        apply (clarsimp split: type.splits prim_type.splits)
       apply (clarsimp split: type.splits prim_type.splits)
       apply (rename_tac len arr t i)
       apply (erule_tac x = i in allE; clarsimp)
       apply (rule_tac x = x in exI)
       apply (clarsimp simp: frame_def)
       apply (erule_tac x = "arr + size_of_num_type t * i" in allE; clarsimp)
       apply (case_tac s; clarsimp; rename_tac perm; case_tac perm; clarsimp)
        apply (drule_tac x = "arr + size_of_num_type t * i" in orthD1; clarsimp)
        apply (rule_tac x = i in exI; clarsimp)
       apply (drule_tac x = "arr + size_of_num_type t * i" in orthD1; clarsimp)
       apply (rule_tac x = i in exI; clarsimp)
      apply (clarsimp split: type.splits prim_type.splits)
      apply (case_tac s; clarsimp; rename_tac perm; case_tac perm; clarsimp)
     apply (clarsimp split: type.splits prim_type.splits)
     apply (case_tac s; clarsimp; rename_tac perm ptrl; case_tac perm; clarsimp)
    apply (clarsimp split: type.splits prim_type.splits)
   apply (clarsimp split: type.splits prim_type.splits)
   apply (rename_tac xs len arr t)
   apply (rule conjI; clarsimp)
    apply (erule_tac x = i in allE; clarsimp)+
    apply (rule_tac x = x in exI)
    apply (clarsimp simp: frame_def)
    apply (erule_tac x = "arr + size_of_num_type t * i" in allE; clarsimp)
    apply (case_tac s; clarsimp; rename_tac perm; case_tac perm; clarsimp)
     apply (drule_tac x = "arr + size_of_num_type t * i" in orthD1; clarsimp)
     apply (rule_tac x = i in exI; clarsimp)
    apply (drule_tac x = "arr + size_of_num_type t * i" in orthD1; clarsimp)
    apply (rule_tac x = i in exI; clarsimp)
   apply (erule_tac x = i in allE; clarsimp)+
   apply (clarsimp simp: frame_def)
   apply (erule_tac x = "arr + size_of_num_type t * i" in allE; clarsimp)
   apply (case_tac s; clarsimp; rename_tac perm; case_tac perm; clarsimp)
    apply (drule_tac x = "arr + size_of_num_type t * i" in orthD1; clarsimp)
    apply (rule_tac x = i in exI; clarsimp)
   apply (drule_tac x = "arr + size_of_num_type t * i" in orthD1; clarsimp)
   apply (rule_tac x = i in exI; clarsimp)
  apply (clarsimp split: type.splits prim_type.splits)
  done

section "Helper Elim Lemmas"

context WordArray begin

inductive_cases u_t_primtE: "upd.uval_typing \<Xi>' \<sigma> u (TPrim l) r w"
inductive_cases u_t_unittE: "upd.uval_typing \<Xi>' \<sigma> u TUnit r w"
inductive_cases u_t_funafuntE: "upd.uval_typing \<Xi>' \<sigma> f (TFun a b) r w"
inductive_cases u_t_rectE: "upd.uval_typing \<Xi>' \<sigma> u (TRecord ts s) r w"
inductive_cases u_t_r_contE: "upd.uval_typing_record \<Xi>' \<sigma> us ts r w"
inductive_cases v_t_primtE : "val.vval_typing \<Xi>' v (TPrim l)"
inductive_cases u_v_t_primtE : "upd_val_rel \<Xi>' \<sigma> u v (TPrim l) r w"
inductive_cases u_v_t_funE: "upd_val_rel \<Xi>' \<sigma> (UFunction f ts) v t r w"
inductive_cases u_v_t_afunE: "upd_val_rel \<Xi>' \<sigma> (UAFunction f ts) v t r w"

end (* of context *)

end


section \<open>Quantum instantiation\<close>

theory CatLValue_Axioms_Mat
  imports Jordan_Normal_Form.Matrix_Impl
begin

class domain = enum

instance prod :: (domain,domain) domain ..

typedef (overloaded) ('a::enum) maps =
  \<open>carrier_mat CARD('a) CARD('a) :: complex mat set\<close>
  apply (rule exI[of _ \<open>zero_mat CARD('a) CARD('a)\<close>])
  by (auto simp: Let_def)
setup_lifting type_definition_maps

definition lvalueish where
  \<open>lvalueish F \<longleftrightarrow> undefined F\<close>

typedef (overloaded) ('a::domain,'b::domain) lvalue = "{F::'a maps \<Rightarrow> 'b maps. lvalueish F}"
  morphisms lvalue_app Abs_lvalue
  sorry
setup_lifting type_definition_lvalue
notation lvalue_app (infixr "\<cdot>" 54)

definition is_lvalue_raw :: \<open>('a maps \<Rightarrow> 'b maps) \<Rightarrow> bool\<close> where
  "is_lvalue_raw F = undefined F"

definition "lvalues_exist = (\<lambda>(_::'a::domain itself) (_::'b::domain itself).
  \<exists>(lv::'a maps \<Rightarrow> 'b maps). is_lvalue_raw lv)"

lift_definition maps_comp :: "('a::domain) maps \<Rightarrow> 'a maps \<Rightarrow> 'a maps" (infixl "o\<^sub>m" 55) is
  "times"
  sorry

lift_definition maps_tensor :: "'a::domain maps \<Rightarrow> 'b::domain maps \<Rightarrow> ('a\<times>'b) maps" (infixr "\<otimes>" 70) is
  undefined
  sorry

lift_definition lvalue_id :: "('a::domain,'a) lvalue" ("1\<^sub>l") is id
  sorry

lift_definition is_lvalue :: \<open>('a::domain, 'b::domain) lvalue \<Rightarrow> bool\<close> is
  \<open>\<lambda>F. undefined F\<close>.

lemma lvalues_exist_comp:
  assumes "lvalues_exist TYPE('b::domain) TYPE('c::domain)"
  assumes "lvalues_exist TYPE('a::domain) TYPE('b::domain)"
  shows "lvalues_exist TYPE('a::domain) TYPE('c::domain)"
  sorry

definition "some_lvalue = (SOME lv. is_lvalue_raw lv)"

lemma some_lvalue_is_lvalue: "lvalues_exist TYPE('a::domain) TYPE('b::domain) \<Longrightarrow>
  is_lvalue_raw (some_lvalue :: 'a maps \<Rightarrow> 'b maps)"
  by (metis lvalues_exist_def someI some_lvalue_def)

lift_definition lvalue_comp :: "('b::domain,'c::domain) lvalue
               \<Rightarrow> ('a::domain,'b) lvalue \<Rightarrow> ('a,'c) lvalue" (infixl "o\<^sub>l" 55)
  is comp
  unfolding lvalueish_def sorry

lemma
  comp_is_lvalue: "is_lvalue x \<Longrightarrow> is_lvalue y \<Longrightarrow> is_lvalue (x o\<^sub>l y)"
  sorry

lift_definition lvalue_tensor ::
  "('a::domain,'c::domain) lvalue \<Rightarrow> ('b::domain,'d::domain) lvalue
        \<Rightarrow> ('a\<times>'b,'c\<times>'d) lvalue" is
  "\<lambda>x y f. undefined"
  sorry

lemma lvalue_id: "1\<^sub>l \<cdot> x = x"
  by (transfer, simp)

lemma lvalue_comp_app:
  fixes y :: "('a::domain,'b::domain) lvalue" and x :: "('b,'c::domain) lvalue"
  (* assumes "lvalues_exist TYPE('a) TYPE('b)" *)
  (* assumes "lvalues_exist TYPE('b) TYPE('c)" *)
  shows "(x o\<^sub>l y) \<cdot> f = x \<cdot> y \<cdot> f"
  apply transfer by auto

lemma lvalue_app_mult:
  fixes x :: "('a::domain,'b::domain) lvalue"
  assumes "is_lvalue x"
  shows "x \<cdot> (f o\<^sub>m g) = (x \<cdot> f) o\<^sub>m (x \<cdot> g)"
  using assms apply transfer unfolding is_lvalue_raw_def
  sorry

lemma maps_comp_assoc: "(f o\<^sub>m g) o\<^sub>m h = f o\<^sub>m (g o\<^sub>m h)"
  apply transfer by simp

(* lemma lvalue_tensor_app[simp]: "(lvalue_tensor x y) \<cdot> (f \<otimes> g) = (x \<cdot> f) \<otimes> (y \<cdot> g)"
  apply transfer
  by - *)

lemma tensor_extensionality:
  fixes x y :: "('a::domain\<times>'b::domain, 'c::domain) lvalue"
  shows "(\<And>f g. x \<cdot> (f \<otimes> g) = y \<cdot> (f \<otimes> g)) \<Longrightarrow> x = y"
  sorry

lift_definition pair :: "('a::domain, 'c::domain) lvalue \<Rightarrow> ('b::domain, 'c) lvalue \<Rightarrow> ('a \<times> 'b, 'c) lvalue" is
  "\<lambda>x y. undefined"
  sorry

lemma pair_apply: \<open>pair x y \<cdot> (f \<otimes> g) = (x \<cdot> f) o\<^sub>m (y \<cdot> g)\<close>
  sorry

(* lemma pair_apply0:
  assumes "\<And>f g. (x \<cdot> f) o\<^sub>m (y \<cdot> g) = (y \<cdot> g) o\<^sub>m (x \<cdot> f)"
  shows "pair x y \<cdot> (f \<otimes> g) = (x \<cdot> f) o\<^sub>m (y \<cdot> g)"
  apply transfer
  sorry *)

lemma
  pair_is_lvalue0:
  \<open>\<lbrakk>is_lvalue x; is_lvalue y;
    \<And>f g. (x \<cdot> f) o\<^sub>m (y \<cdot> g) = (y \<cdot> g) o\<^sub>m (x \<cdot> f)\<rbrakk>
     \<Longrightarrow> is_lvalue (pair x y)\<close>
  sorry

lift_definition left_tensor :: "'a::domain maps \<Rightarrow> ('b::domain, 'a \<times> 'b) lvalue" is
  "\<lambda>f g. f \<otimes> g"
  sorry

lemma left_tensor_apply: "left_tensor f \<cdot> g = f \<otimes> g"
  apply (transfer fixing: f g) by simp

lift_definition swap :: "('a::domain\<times>'b::domain, 'b\<times>'a) lvalue" is
  "\<lambda>f. undefined"
  sorry

lemma swap_apply[simp]: "swap \<cdot> (f \<otimes> g) = g \<otimes> f"
  sorry

lift_definition assoc :: "('a::domain \<times> ('b::domain \<times> 'c::domain), ('a \<times> 'b) \<times> 'c) lvalue" is
  "undefined"
  sorry

lemma assoc_apply[simp]: "assoc \<cdot> (f \<otimes> (g \<otimes> h)) = (f \<otimes> g) \<otimes> h"
  sorry

lift_definition assoc' :: "(('a::domain \<times> 'b::domain) \<times> 'c::domain, 'a \<times> ('b \<times> 'c)) lvalue" is
  undefined
  sorry

lemma assoc'_apply[simp]: "assoc' \<cdot> (f \<otimes> g) \<otimes> h = (f \<otimes> (g \<otimes> h))"
  sorry

lemma lvalue_tensor_app: "(lvalue_tensor x y) \<cdot> (f \<otimes> g) = (x \<cdot> f) \<otimes> (y \<cdot> g)"
  sorry

end


(*  Title:      HOL/Auth/n_german_lemma_inv__11_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_german Protocol Case Study*}

theory n_german_lemma_inv__11_on_rules imports n_german_lemma_on_inv__11
begin
section{*All lemmas on causal relation between inv__11*}
lemma lemma_inv__11_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__11  p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_StoreVsinv__11) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqSVsinv__11) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqE__part__0Vsinv__11) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqE__part__1Vsinv__11) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqSVsinv__11) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqE N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqEVsinv__11) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__0Vsinv__11) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__1Vsinv__11) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvAckVsinv__11) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvInvAckVsinv__11) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntSVsinv__11) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntEVsinv__11) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntSVsinv__11) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntEVsinv__11) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


section {* Stack by Array *}
theory Impl_Array_Stack
imports
  "../../../Automatic_Refinement/Automatic_Refinement"
  "../../Lib/Diff_Array"
begin

type_synonym 'a array_stack = "'a array \<times> nat"

term Diff_Array.array_length

definition "as_raw_\<alpha> s \<equiv> take (snd s) (list_of_array (fst s))"
definition "as_raw_invar s \<equiv> snd s \<le> array_length (fst s)"

definition as_rel_def_internal: "as_rel R \<equiv> br as_raw_\<alpha> as_raw_invar O \<langle>R\<rangle>list_rel"
lemma as_rel_def: "\<langle>R\<rangle>as_rel \<equiv> br as_raw_\<alpha> as_raw_invar O \<langle>R\<rangle>list_rel"
  unfolding as_rel_def_internal[abs_def] by (simp add: relAPP_def)

lemma [relator_props]: "single_valued R \<Longrightarrow> single_valued (\<langle>R\<rangle>as_rel)"
  unfolding as_rel_def
  by tagged_solver

lemmas [autoref_rel_intf] = REL_INTFI[of as_rel i_list]

definition "as_empty (_::unit) \<equiv> (array_of_list [],0)"

lemma as_empty_refine[autoref_rules]: "(as_empty (),[]) \<in> \<langle>R\<rangle>as_rel"
  unfolding as_rel_def as_empty_def br_def
  unfolding as_raw_\<alpha>_def as_raw_invar_def
  by auto

definition "as_push s x \<equiv> let
    (a,n)=s;
    a = if n = array_length a then
        array_grow a (max 4 (2*n)) x
      else a;
    a = array_set a n x
  in
    (a,n+1)"

lemma as_push_refine[autoref_rules]:
  "(as_push,op_list_append_elem) \<in> \<langle>R\<rangle>as_rel \<rightarrow> R \<rightarrow> \<langle>R\<rangle>as_rel"
  apply (intro fun_relI)
  apply (simp add: as_push_def op_list_append_elem_def as_rel_def br_def
    as_raw_\<alpha>_def as_raw_invar_def)
  apply clarsimp
  apply safe
  apply (rule)
  apply auto []
  apply (clarsimp simp: array_length_list) []
  apply parametricity

  apply rule
  apply auto []
  apply (auto simp: take_Suc_conv_app_nth array_length_list list_update_append) []
  apply parametricity
  done

term array_shrink

definition "as_shrink s \<equiv> let
    (a,n) = s;
    a = if 128*n \<le> array_length a \<and> n>4 then
        array_shrink a n
      else a
  in
    (a,n)"

lemma as_shrink_id_refine: "(as_shrink,id) \<in> \<langle>R\<rangle>as_rel \<rightarrow> \<langle>R\<rangle>as_rel"
  apply (intro fun_relI)
  apply (simp add: as_shrink_def as_rel_def br_def
    as_raw_\<alpha>_def as_raw_invar_def Let_def)
  apply clarsimp
  apply safe

  apply (rule)
  apply (auto simp: array_length_list)
  done

lemma as_shrinkI:
  assumes [param]: "(s,a)\<in>\<langle>R\<rangle>as_rel"
  shows "(as_shrink s,a)\<in>\<langle>R\<rangle>as_rel"
  apply (subst id_apply[of a,symmetric])
  apply (parametricity add: as_shrink_id_refine)
  done

definition "as_pop s \<equiv> let (a,n)=s in as_shrink (a,n - 1)"

lemma as_pop_refine[autoref_rules]: "(as_pop,butlast) \<in> \<langle>R\<rangle>as_rel \<rightarrow> \<langle>R\<rangle>as_rel"
  apply (intro fun_relI)
  apply (clarsimp simp add: as_pop_def split: prod.split)
  apply (rule as_shrinkI)

  apply (simp add: as_pop_def as_rel_def br_def
    as_raw_\<alpha>_def as_raw_invar_def Let_def)
  apply clarsimp

  apply rule
  apply (auto simp: array_length_list) []
  apply (clarsimp simp: array_length_list take_minus_one_conv_butlast) []
  apply parametricity
  done

definition "as_get s i \<equiv> let (a,_::nat)=s in array_get a i"

lemma as_get_refine:
  assumes 1: "i'<length l"
  assumes 2: "(a,l)\<in>\<langle>R\<rangle>as_rel"
  assumes 3[param]: "(i,i')\<in>nat_rel"
  shows "(as_get a i,l!i')\<in>R"
  using 2
  apply (clarsimp
    simp add: as_get_def as_rel_def br_def as_raw_\<alpha>_def as_raw_invar_def
    split: prod.split)
  apply (rename_tac aa bb)
  apply (case_tac aa, simp)
proof -
  fix n cl
  assume TKR[param]: "(take n cl, l) \<in> \<langle>R\<rangle>list_rel"

  have "(take n cl!i, l!i')\<in>R"
    by parametricity (rule 1)
  also have "take n cl!i = cl!i"
    using 1 3 list_rel_imp_same_length[OF TKR]
    by simp
  finally show "(cl!i,l!i')\<in>R" .
qed

context begin interpretation autoref_syn .
lemma as_get_autoref[autoref_rules]:
  assumes "(l,l')\<in>\<langle>R\<rangle>as_rel"
  assumes "(i,i')\<in>Id"
  assumes "SIDE_PRECOND (i' < length l')"
  shows "(as_get l i,(OP nth ::: \<langle>R\<rangle>as_rel \<rightarrow> nat_rel \<rightarrow> R)$l'$i')\<in>R"
  using assms by (simp add: as_get_refine)

definition "as_set s i x \<equiv> let (a,n::nat)=s in (array_set a i x,n)"

lemma as_set_refine[autoref_rules]:
  "(as_set,list_update)\<in>\<langle>R\<rangle>as_rel \<rightarrow> nat_rel \<rightarrow> R \<rightarrow> \<langle>R\<rangle>as_rel"
  apply (intro fun_relI)
  apply (clarsimp
    simp: as_set_def as_rel_def br_def as_raw_\<alpha>_def as_raw_invar_def
    split: prod.split)
  apply rule
  apply auto []
  apply parametricity
  by simp

definition as_length :: "'a array_stack \<Rightarrow> nat" where
  "as_length = snd"

lemma as_length_refine[autoref_rules]:
  "(as_length,length) \<in> \<langle>R\<rangle>as_rel \<rightarrow> nat_rel"
  by (auto
    simp: as_length_def as_rel_def br_def as_raw_\<alpha>_def as_raw_invar_def
      array_length_list
    dest!: list_rel_imp_same_length
  )

definition "as_top s \<equiv> as_get s (as_length s - 1)"

lemma as_top_code[code]: "as_top s = (let (a,n)=s in array_get a (n - 1))"
  unfolding as_top_def as_get_def as_length_def
  by (auto split: prod.split)

lemma as_top_refine: "\<lbrakk>l\<noteq>[]; (s,l)\<in>\<langle>R\<rangle>as_rel\<rbrakk> \<Longrightarrow> (as_top s,last l)\<in>R"
  unfolding as_top_def
  apply (simp add: last_conv_nth)
  apply (rule as_get_refine)
  apply (auto simp: as_length_def as_rel_def br_def as_raw_\<alpha>_def
    as_raw_invar_def array_length_list
    dest!: list_rel_imp_same_length)
  done

lemma as_top_autoref[autoref_rules]:
  assumes "(l,l')\<in>\<langle>R\<rangle>as_rel"
  assumes "SIDE_PRECOND (l' \<noteq> [])"
  shows "(as_top l,(OP last ::: \<langle>R\<rangle>as_rel \<rightarrow> R)$l')\<in>R"
  using assms by (simp add: as_top_refine)

definition "as_is_empty s \<equiv> as_length s = 0"
lemma as_is_empty_code[code]: "as_is_empty s = (snd s = 0)"
  unfolding as_is_empty_def as_length_def by simp

lemma as_is_empty_refine[autoref_rules]:
  "(as_is_empty,is_Nil) \<in> \<langle>R\<rangle>as_rel \<rightarrow> bool_rel"
proof
  fix s l
  assume [param]: "(s,l)\<in>\<langle>R\<rangle>as_rel"
  have "(as_is_empty s,length l = 0) \<in> bool_rel"
    unfolding as_is_empty_def
    by (parametricity add: as_length_refine)
  also have "length l = 0 \<longleftrightarrow> is_Nil l"
    by (cases l) auto
  finally show "(as_is_empty s, is_Nil l) \<in> bool_rel" .
qed

definition "as_take m s \<equiv> let (a,n) = s in
  if m<n then
    as_shrink (a,m)
  else (a,n)"

lemma as_take_refine[autoref_rules]:
  "(as_take,take)\<in>nat_rel \<rightarrow> \<langle>R\<rangle>as_rel \<rightarrow> \<langle>R\<rangle>as_rel"
  apply (intro fun_relI)
  apply (clarsimp simp add: as_take_def, safe)

  apply (rule as_shrinkI)
  apply (simp add: as_rel_def br_def as_raw_\<alpha>_def as_raw_invar_def)
  apply rule
  apply auto []
  apply clarsimp
  apply (subgoal_tac "take a' (list_of_array a) = take a' (take ba (list_of_array a))")
  apply (simp only: )
  apply (parametricity, rule IdI)
  apply simp

  apply (simp add: as_rel_def br_def as_raw_\<alpha>_def as_raw_invar_def)
  apply rule
  apply auto []
  apply clarsimp
  apply (frule list_rel_imp_same_length)
  apply simp
  done

definition "as_singleton x \<equiv> (array_of_list [x],1)"
lemma as_singleton_refine[autoref_rules]:
  "(as_singleton,op_list_singleton)\<in>R \<rightarrow> \<langle>R\<rangle>as_rel"
  apply (intro fun_relI)
  apply (simp add: as_singleton_def as_rel_def br_def as_raw_\<alpha>_def
    as_raw_invar_def)
  apply rule
  apply (auto simp: array_length_list) []
  apply simp
  done

end

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)
 *)

theory Simple
imports
  "../../AutoCorres"
  GCD
begin

(* Parse the input file. *)
install_C_file "simple.c"

(* Abstract the input file. *)
autocorres [ ts_force pure = max, ts_force nondet = gcd, unsigned_word_abs = gcd ] "simple.c"

(* Generated theorems and proofs. *)
thm simple.max'_def simple.max'_ccorres
thm simple.gcd'_def simple.gcd'_ccorres

context simple begin

(* Show generated "max'" function matches in-built "max". *)
lemma "max' a b = max a b"
  unfolding max'_def max_def
  by (rule refl)

(* Show "gcd'" calculates the gcd. *)
lemma gcd_wp [wp]:
    "\<lbrace> P (gcd a b) \<rbrace> gcd' a b \<lbrace> P \<rbrace>!"
  (* Unfold definition of "gcd'". *)
  apply (unfold gcd'_def)

  (* Annoate the loop with an invariant and measure. *)
  apply (subst whileLoop_add_inv [where
     I="\<lambda>(a', b') s. gcd a b = gcd a' b' \<and> P (gcd a b) s"
     and M="\<lambda>((a', b'), s). a'"])

  (* Solve using weakest-precondition. *)
  apply wp
    apply clarsimp
    apply (metis gcd_commute_nat gcd_red_nat)
   apply clarsimp
  apply clarsimp
  done

lemma monad_to_gets:
    "\<lbrakk> \<And>P. \<lbrace> P \<rbrace> f \<lbrace> \<lambda>r s. P s \<and> r = v s \<rbrace>!; empty_fail f \<rbrakk> \<Longrightarrow> f = gets v"
  apply atomize
  apply (monad_eq simp: validNF_def valid_def no_fail_def empty_fail_def)
  apply (rule conjI)
   apply clarsimp
   apply (drule_tac x="\<lambda>s'. s = s'" in spec)
   apply clarsimp
   apply force
  apply clarsimp
  apply (drule_tac x="\<lambda>s'. s' = t" in spec)
  apply clarsimp
  apply force
  done

lemma gcd_to_return [simp]:
    "gcd' a b = return (gcd a b)"
  apply (subst monad_to_gets [where v="\<lambda>_. gcd a b"])
    apply (wp gcd_wp)
    apply simp
   apply (clarsimp simp: gcd'_def)
   apply (rule empty_fail_bind)
    apply (rule empty_fail_whileLoop)
    apply (clarsimp simp: split_def)
   apply (clarsimp simp: split_def)
  apply (clarsimp simp: split_def)
  done

end

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 Phases
imports
  Global_Invariants_Lemmas
  Local_Invariants_Lemmas
  Tactics
begin

(*>*)
section\<open>Handshake phases\<close>

text\<open>

Reasoning about phases, handshakes.

Tie the garbage collector's control location to the value of @{const
"gc_phase"}.

\<close>

lemma (in gc) phase_invL_eq_imp:
  "eq_imp (\<lambda>(_::unit) s. (AT s gc, s\<down> gc, tso_pending_phase gc s\<down>))
          phase_invL"
by (clarsimp simp: eq_imp_def inv)

lemmas gc_phase_invL_niE[nie] =
  iffD1[OF gc.phase_invL_eq_imp[simplified eq_imp_simps, rule_format, unfolded conj_explode], rotated -1]

lemma (in gc) phase_invL[intro]:
  "\<lbrace> phase_invL \<^bold>\<and> LSTP phase_rel_inv \<rbrace> gc \<lbrace> phase_invL \<rbrace>"
by vcg_jackhammer (fastforce dest!: phase_rel_invD simp: phase_rel_def)

lemma (in sys) gc_phase_invL[intro]:
  notes fun_upd_apply[simp]
  notes if_splits[split]
  shows
  "\<lbrace> gc.phase_invL \<rbrace> sys"
by (vcg_chainsaw gc.phase_invL_def)

lemma (in mut_m) gc_phase_invL[intro]:
  "\<lbrace> gc.phase_invL \<rbrace> mutator m"
by (vcg_chainsaw gc.phase_invL_def[inv])

lemma (in gc) phase_rel_inv[intro]:
  "\<lbrace> handshake_invL \<^bold>\<and> phase_invL \<^bold>\<and> LSTP phase_rel_inv \<rbrace> gc \<lbrace> LSTP phase_rel_inv \<rbrace>"
unfolding phase_rel_inv_def by (vcg_jackhammer (no_thin_post_inv); simp add: phase_rel_def; blast)

lemma (in sys) phase_rel_inv[intro]:
  notes gc.phase_invL_def[inv]
  notes phase_rel_inv_def[inv]
  notes fun_upd_apply[simp]
  shows
  "\<lbrace> LSTP (phase_rel_inv \<^bold>\<and> tso_store_inv) \<rbrace> sys \<lbrace> LSTP phase_rel_inv \<rbrace>"
proof(vcg_jackhammer (no_thin_post_inv), vcg_name_cases)
  case (tso_dequeue_store_buffer s s' p w ws) then show ?case
    apply (simp add: phase_rel_def p_not_sys split: if_splits)
    apply (elim disjE; auto split: if_splits)
    done
qed

lemma (in mut_m) phase_rel_inv[intro]:
  "\<lbrace> handshake_invL \<^bold>\<and> LSTP (handshake_phase_inv \<^bold>\<and> phase_rel_inv) \<rbrace>
     mutator m
   \<lbrace> LSTP phase_rel_inv \<rbrace>"
unfolding phase_rel_inv_def
proof (vcg_jackhammer (no_thin_post_inv), vcg_name_cases)
  case (hs_noop_done s s') then show ?case
    by (auto dest!: handshake_phase_invD
             simp: handshake_phase_rel_def phase_rel_def hp_step_rel_def
            split: hs_phase.splits)
next case (hs_get_roots_done s s') then show ?case
    by (auto dest!: handshake_phase_invD
             simp: handshake_phase_rel_def phase_rel_def hp_step_rel_def
            split: hs_phase.splits)
next case (hs_get_work_done s s') then show ?case
    by (auto dest!: handshake_phase_invD
             simp: handshake_phase_rel_def phase_rel_def hp_step_rel_def
            split: hs_phase.splits)
qed

text\<open>

Connect @{const "sys_ghost_hs_phase"} with locations in the GC.

\<close>

lemma gc_handshake_invL_eq_imp:
  "eq_imp (\<lambda>(_::unit) s. (AT s gc, s\<down> gc, sys_ghost_hs_phase s\<down>, hs_pending (s\<down> sys), ghost_hs_in_sync (s\<down> sys), sys_hs_type s\<down>))
          gc.handshake_invL"
by (simp add: gc.handshake_invL_def eq_imp_def)

lemmas gc_handshake_invL_niE[nie] =
  iffD1[OF gc_handshake_invL_eq_imp[simplified eq_imp_simps, rule_format, unfolded conj_explode], rotated -1]

lemma (in sys) gc_handshake_invL[intro]:
  "\<lbrace> gc.handshake_invL \<rbrace> sys"
by (vcg_chainsaw gc.handshake_invL_def)

lemma (in sys) handshake_phase_inv[intro]:
  "\<lbrace> LSTP handshake_phase_inv \<rbrace> sys"
unfolding handshake_phase_inv_def by (vcg_jackhammer (no_thin_post_inv))

lemma (in gc) handshake_invL[intro]:
  notes fun_upd_apply[simp]
  shows
  "\<lbrace> handshake_invL \<rbrace> gc"
by vcg_jackhammer fastforce+

lemma (in gc) handshake_phase_inv[intro]:
  notes fun_upd_apply[simp]
  shows
  "\<lbrace> handshake_invL \<^bold>\<and> LSTP handshake_phase_inv \<rbrace> gc \<lbrace> LSTP handshake_phase_inv \<rbrace>"
unfolding handshake_phase_inv_def by (vcg_jackhammer (no_thin_post_inv)) (auto simp: handshake_phase_inv_def hp_step_rel_def)

text\<open>

Local handshake phase invariant for the mutators.

\<close>

lemma (in mut_m) handshake_invL_eq_imp:
  "eq_imp (\<lambda>(_::unit) s. (AT s (mutator m), s\<down> (mutator m), sys_hs_type s\<down>, sys_hs_pending m s\<down>, mem_store_buffers (s\<down> sys) (mutator m)))
          handshake_invL"
unfolding eq_imp_def handshake_invL_def by simp

lemmas mut_m_handshake_invL_niE[nie] =
  iffD1[OF mut_m.handshake_invL_eq_imp[simplified eq_imp_simps, rule_format, unfolded conj_explode], rotated -1]

lemma (in mut_m) handshake_invL[intro]:
  "\<lbrace> handshake_invL \<rbrace> mutator m"
by vcg_jackhammer

lemma (in mut_m') handshake_invL[intro]:
  "\<lbrace> handshake_invL \<rbrace> mutator m'"
by vcg_chainsaw

lemma (in gc) mut_handshake_invL[intro]:
  notes fun_upd_apply[simp]
  shows
  "\<lbrace> handshake_invL \<^bold>\<and> mut_m.handshake_invL m \<rbrace> gc \<lbrace> mut_m.handshake_invL m \<rbrace>"
by (vcg_chainsaw mut_m.handshake_invL_def)

lemma (in sys) mut_handshake_invL[intro]:
  notes if_splits[split]
  notes fun_upd_apply[simp]
  shows
  "\<lbrace> mut_m.handshake_invL m \<rbrace> sys"
by (vcg_chainsaw mut_m.handshake_invL_def)

lemma (in mut_m) gc_handshake_invL[intro]:
  notes fun_upd_apply[simp]
  shows
  "\<lbrace> handshake_invL \<^bold>\<and> gc.handshake_invL \<rbrace> mutator m \<lbrace> gc.handshake_invL \<rbrace>"
by (vcg_chainsaw gc.handshake_invL_def)

lemma (in mut_m) handshake_phase_inv[intro]:
  notes fun_upd_apply[simp]
  shows
  "\<lbrace> handshake_invL \<^bold>\<and> LSTP handshake_phase_inv \<rbrace> mutator m \<lbrace> LSTP handshake_phase_inv \<rbrace>"
unfolding handshake_phase_inv_def by (vcg_jackhammer (no_thin_post_inv)) (auto simp: hp_step_rel_def)

text\<open>

Validity of @{const "sys_fM"} wrt @{const "gc_fM"} and the handshake
phase. Effectively we use @{const "gc_fM"} as ghost state. We also
include the TSO lock to rule out the GC having any pending marks
during the @{const "hp_Idle"} handshake phase.

\<close>

lemma gc_fM_fA_invL_eq_imp:
  "eq_imp (\<lambda>(_::unit) s. (AT s gc, s\<down> gc, sys_fA s\<down>, sys_fM s\<down>, sys_mem_store_buffers gc s\<down>))
          gc.fM_fA_invL"
by (simp add: gc.fM_fA_invL_def eq_imp_def)

lemmas gc_fM_fA_invL_niE[nie] =
  iffD1[OF gc_fM_fA_invL_eq_imp[simplified eq_imp_simps, rule_format, unfolded conj_explode], rotated -1]

context gc
begin

lemma fM_fA_invL[intro]:
  "\<lbrace> fM_fA_invL \<rbrace> gc"
by vcg_jackhammer

lemma fM_rel_inv[intro]:
  notes fun_upd_apply[simp]
  shows
  "\<lbrace> fM_fA_invL \<^bold>\<and> handshake_invL \<^bold>\<and> tso_lock_invL \<^bold>\<and> LSTP fM_rel_inv \<rbrace>
     gc
   \<lbrace> LSTP fM_rel_inv \<rbrace>"
by (vcg_jackhammer (no_thin_post_inv); simp add: fM_rel_inv_def fM_rel_def)

lemma fA_rel_inv[intro]:
  notes fun_upd_apply[simp]
  shows
  "\<lbrace> fM_fA_invL \<^bold>\<and> handshake_invL \<^bold>\<and> LSTP fA_rel_inv \<rbrace>
     gc
   \<lbrace> LSTP fA_rel_inv \<rbrace>"
by (vcg_jackhammer (no_thin_post_inv); simp add: fA_rel_inv_def; auto simp: fA_rel_def)

end

context mut_m
begin

lemma gc_fM_fA_invL[intro]:
  "\<lbrace> gc.fM_fA_invL \<rbrace> mutator m"
by (vcg_chainsaw gc.fM_fA_invL_def)

lemma fM_rel_inv[intro]:
  notes fun_upd_apply[simp]
  shows
  "\<lbrace> LSTP fM_rel_inv \<rbrace> mutator m"
unfolding fM_rel_inv_def by (vcg_jackhammer (no_thin_post_inv); simp add: fM_rel_def; elim disjE; auto split: if_splits)

lemma fA_rel_inv[intro]:
  notes fun_upd_apply[simp]
  shows
  "\<lbrace> LSTP fA_rel_inv \<rbrace> mutator m"
unfolding fA_rel_inv_def by (vcg_jackhammer (no_thin_post_inv); simp add: fA_rel_def; elim disjE; auto split: if_splits)

end

context gc
begin

lemma fA_neq_locs_diff_fA_tso_empty_locs:
  "fA_neq_locs - fA_tso_empty_locs = {}"
apply (simp add: fA_neq_locs_def fA_tso_empty_locs_def locset_cache)
apply (simp add: loc_defs)
done

end

context sys
begin

lemma gc_fM_fA_invL[intro]:
  "\<lbrace> gc.fM_fA_invL \<^bold>\<and> LSTP (fA_rel_inv \<^bold>\<and> fM_rel_inv \<^bold>\<and> tso_store_inv) \<rbrace>
     sys
   \<lbrace> gc.fM_fA_invL \<rbrace>"
apply( vcg_chainsaw (no_thin) gc.fM_fA_invL_def
     ; (simp add: p_not_sys)?; (erule disjE)?; clarsimp split: if_splits )
proof(vcg_name_cases sys gc)
     case (tso_dequeue_store_buffer_mark_noop_mfence s s' ws) then show ?case by (clarsimp simp: fA_rel_inv_def fA_rel_def)
next case (tso_dequeue_store_buffer_fA_neq_locs s s' ws) then show ?case
  apply (clarsimp simp: fA_rel_inv_def fA_rel_def fM_rel_inv_def fM_rel_def)
  apply (drule (1) atS_dests(3), fastforce simp: atS_simps gc.fA_neq_locs_diff_fA_tso_empty_locs)
  done
next case (tso_dequeue_store_buffer_fA_eq_locs s s' ws) then show ?case by (clarsimp simp: fA_rel_inv_def fA_rel_def)
next case (tso_dequeue_store_buffer_idle_flip_noop_mfence s s' ws) then show ?case by (clarsimp simp: fM_rel_inv_def fM_rel_def)
next case (tso_dequeue_store_buffer_fM_eq_locs s s' ws) then show ?case by (clarsimp simp: fM_rel_inv_def fM_rel_def)
qed

lemma fM_rel_inv[intro]:
  notes fun_upd_apply[simp]
  shows
  "\<lbrace> LSTP (fM_rel_inv \<^bold>\<and> tso_store_inv) \<rbrace> sys \<lbrace> LSTP fM_rel_inv \<rbrace>"
apply (vcg_jackhammer (no_thin_post_inv))
apply (clarsimp simp: do_store_action_def fM_rel_inv_def fM_rel_def p_not_sys
                split: mem_store_action.splits)
apply (intro allI conjI impI; clarsimp)
done

lemma fA_rel_inv[intro]:
  notes fun_upd_apply[simp]
  shows
  "\<lbrace> LSTP (fA_rel_inv \<^bold>\<and> tso_store_inv) \<rbrace> sys \<lbrace> LSTP fA_rel_inv \<rbrace>"
apply (vcg_jackhammer (no_thin_post_inv))
apply (clarsimp simp: do_store_action_def fA_rel_inv_def fA_rel_def p_not_sys
                split: mem_store_action.splits)
apply (intro allI conjI impI; clarsimp)
done

end

subsubsection\<open>sys phase inv\<close>

context mut_m
begin

lemma sys_phase_inv[intro]:
  notes if_split_asm[split del]
  notes fun_upd_apply[simp]
  shows
  "\<lbrace> handshake_invL
             \<^bold>\<and> mark_object_invL
             \<^bold>\<and> mut_get_roots.mark_object_invL m
             \<^bold>\<and> mut_store_del.mark_object_invL m
             \<^bold>\<and> mut_store_ins.mark_object_invL m
        \<^bold>\<and> LSTP (fA_rel_inv \<^bold>\<and> fM_rel_inv \<^bold>\<and> handshake_phase_inv \<^bold>\<and> mutators_phase_inv \<^bold>\<and> phase_rel_inv \<^bold>\<and> sys_phase_inv \<^bold>\<and> valid_refs_inv) \<rbrace>
     mutator m
   \<lbrace> LSTP sys_phase_inv \<rbrace>"
proof( (vcg_jackhammer (no_thin_post_inv)
       ; clarsimp simp: fA_rel_inv_def fM_rel_inv_def sys_phase_inv_aux_case heap_colours_colours
                 split: hs_phase.splits if_splits )
     , vcg_name_cases )
     case (alloc s s' rb) then show ?case
      by (clarsimp simp: fA_rel_def fM_rel_def no_black_refs_def
                  dest!: handshake_phase_invD phase_rel_invD
                  split: hs_phase.splits)
next case (store_ins_mo_co_mark0 s s' y) then show ?case
      by (fastforce simp: fA_rel_def fM_rel_def hp_step_rel_def
                   dest!: handshake_phase_invD phase_rel_invD)
next case (store_ins_mo_co_mark s s' y) then show ?case
      apply -
      apply (drule spec[where x=m])
      apply (rule conjI)
       apply (clarsimp simp: hp_step_rel_def phase_rel_def conj_disj_distribR[symmetric]
                      dest!: handshake_phase_invD phase_rel_invD)
       apply (elim disjE, simp_all add: no_grey_refs_not_rootD; fail)
      apply (clarsimp simp: hp_step_rel_def phase_rel_def
                     dest!: handshake_phase_invD phase_rel_invD)
      apply (elim disjE, simp_all add: no_grey_refs_not_rootD)[1]
      apply clarsimp
      apply (elim disjE, simp_all add: no_grey_refs_not_rootD filter_empty_conv)[1]
      apply fastforce
      done
next case (store_del_mo_co_mark0 s s' y) then show ?case
      apply (clarsimp simp: hp_step_rel_def dest!: handshake_phase_invD phase_rel_invD)
      apply (metis (no_types, lifting) mut_m.no_grey_refs_not_rootD mutator_phase_inv_aux.simps(5))
      done
next case (store_del_mo_co_mark s s' y) then show ?case
      apply -
      apply (drule spec[where x=m])
      apply (rule conjI)
       apply (clarsimp simp: hp_step_rel_def phase_rel_def conj_disj_distribR[symmetric] no_grey_refs_not_rootD
                      dest!: handshake_phase_invD phase_rel_invD; fail)
      apply (clarsimp simp: hp_step_rel_def phase_rel_def
                     dest!: handshake_phase_invD phase_rel_invD)
      apply (elim disjE, simp_all add: no_grey_refs_not_rootD)
      apply clarsimp
      apply (elim disjE, simp_all add: no_grey_refs_not_rootD filter_empty_conv)
      apply fastforce
      done
next case (hs_get_roots_done s s') then show ?case
      apply (clarsimp simp: hp_step_rel_def phase_rel_def filter_empty_conv
                     dest!: handshake_phase_invD phase_rel_invD)
      apply auto
      done
next case (hs_get_roots_loop_mo_co_mark s s' y) then show ?case
      apply -
      apply (drule spec[where x=m])
      apply (rule conjI)
       apply (clarsimp simp: hp_step_rel_def phase_rel_def conj_disj_distribR[symmetric]
                      dest!: handshake_phase_invD phase_rel_invD; fail)
      apply (clarsimp simp: hp_step_rel_def phase_rel_def
                     dest!: handshake_phase_invD phase_rel_invD)
      apply (elim disjE, simp_all add: no_grey_refs_not_rootD)
      apply clarsimp
      apply (elim disjE, simp_all add: no_grey_refs_not_rootD filter_empty_conv)[1]
      apply fastforce
      done
next case (hs_get_work_done s s') then show ?case
      apply (clarsimp simp: hp_step_rel_def phase_rel_def filter_empty_conv
                     dest!: handshake_phase_invD phase_rel_invD)
      apply auto
      done
qed (clarsimp simp: hp_step_rel_def dest!: handshake_phase_invD phase_rel_invD)+

end

lemma (in gc) sys_phase_inv[intro]:
  notes fun_upd_apply[simp]
  shows
  "\<lbrace> fM_fA_invL \<^bold>\<and> gc_W_empty_invL \<^bold>\<and> handshake_invL \<^bold>\<and> obj_fields_marked_invL
       \<^bold>\<and> phase_invL \<^bold>\<and> sweep_loop_invL
       \<^bold>\<and> LSTP (phase_rel_inv \<^bold>\<and> sys_phase_inv \<^bold>\<and> valid_W_inv \<^bold>\<and> tso_store_inv) \<rbrace>
     gc
   \<lbrace> LSTP sys_phase_inv \<rbrace>"
proof(vcg_jackhammer (no_thin_post_inv), vcg_name_cases)
     case (mark_loop_get_work_load_W s s') then show ?case by (fastforce dest!: phase_rel_invD simp: phase_rel_def no_grey_refsD filter_empty_conv)
next case (mark_loop_blacken s s') then show ?case by (meson no_grey_refsD(1))
next case (mark_loop_mo_co_W s s') then show ?case by (meson no_grey_refsD(1))
next case (mark_loop_mo_co_mark s s') then show ?case by (meson no_grey_refsD(1))
next case (mark_loop_get_roots_load_W s s') then show ?case by (fastforce dest!: phase_rel_invD simp: phase_rel_def no_grey_refsD filter_empty_conv)
next case (mark_loop_get_roots_init_type s s') then show ?case by (fastforce dest!: phase_rel_invD simp: phase_rel_def no_grey_refsD filter_empty_conv)
next case (idle_noop_init_type s s') then show ?case using black_heap_no_greys by blast
qed

lemma no_grey_refs_no_marks[simp]:
  "\<lbrakk> no_grey_refs s; valid_W_inv s \<rbrakk> \<Longrightarrow> \<not>sys_mem_store_buffers p s = mw_Mark r fl # ws"
unfolding no_grey_refs_def by (metis greyI(1) list.set_intros(1) valid_W_invE(5))
(* FIXME suggests redundancy in valid_W_inv rules:  by (meson greyI(1) valid_W_invD(1)) *)

context sys
begin

lemma black_heap_dequeue_mark[iff]:
  "\<lbrakk> sys_mem_store_buffers p s = mw_Mark r fl # ws; black_heap s; valid_W_inv s \<rbrakk>
   \<Longrightarrow> black_heap (s(sys := s sys\<lparr>heap := (sys_heap s)(r := map_option (obj_mark_update (\<lambda>_. fl)) (sys_heap s r)), mem_store_buffers := (mem_store_buffers (s sys))(p := ws)\<rparr>))"
unfolding black_heap_def by (metis colours_distinct(4) valid_W_invD(1) white_valid_ref)

lemma white_heap_dequeue_fM[iff]:
  "black_heap s\<down>
     \<Longrightarrow> white_heap (s\<down>(sys := s\<down> sys\<lparr>fM := \<not> sys_fM s\<down>, mem_store_buffers := (mem_store_buffers (s\<down> sys))(gc := ws)\<rparr>))"
unfolding black_heap_def white_heap_def black_def white_def by clarsimp (* FIXME rules? *)

lemma black_heap_dequeue_fM[iff]:
  "\<lbrakk> white_heap s\<down>; no_grey_refs s\<down> \<rbrakk>
     \<Longrightarrow> black_heap (s\<down>(sys := s\<down> sys\<lparr>fM := \<not> sys_fM s\<down>, mem_store_buffers := (mem_store_buffers (s\<down> sys))(gc := ws)\<rparr>))"
unfolding black_heap_def white_heap_def no_grey_refs_def by auto

lemma sys_phase_inv[intro]:
  notes if_split_asm[split del]
  notes fun_upd_apply[simp]
  shows
  "\<lbrace> LSTP (fA_rel_inv \<^bold>\<and> fM_rel_inv \<^bold>\<and> handshake_phase_inv \<^bold>\<and> mutators_phase_inv \<^bold>\<and> phase_rel_inv \<^bold>\<and> sys_phase_inv \<^bold>\<and> tso_store_inv \<^bold>\<and> valid_W_inv) \<rbrace>
     sys
   \<lbrace> LSTP sys_phase_inv \<rbrace>"
proof(vcg_jackhammer (no_thin_post_inv)
     , clarsimp simp: fA_rel_inv_def fM_rel_inv_def p_not_sys
     , vcg_name_cases)
  case (tso_dequeue_store_buffer s s' p w ws) then show ?case
    apply (clarsimp simp: do_store_action_def sys_phase_inv_aux_case
                   split: mem_store_action.splits hs_phase.splits if_splits)
    apply (clarsimp simp: fA_rel_def fM_rel_def; erule disjE; clarsimp simp: fA_rel_def fM_rel_def)+
     apply (metis (mono_tags, lifting) filter.simps(2) list.discI tso_store_invD(4))
    apply auto
    done
qed

end
(*<*)

end
(*>*)