(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Jacques-Henri Jourdan, INRIA Paris-Rocquencourt            *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

Require Import List.
Require Import Coq.Program.Syntax.
Require Import Equality.

(** A curryfied function with multiple parameters **)
Definition arrows_left: list Type -> Type -> Type :=
  fold_left (fun A B => B -> A).

(** A curryfied function with multiple parameters **)
Definition arrows_right: Type -> list Type -> Type :=
  fold_right (fun A B => A -> B).

(** A tuple is a heterogeneous list. For convenience, we use pairs. **)
Fixpoint tuple (types : list Type) : Type :=
  match types with
  | nil => unit
  | t::q => prod t (tuple q)
  end.

Fixpoint uncurry {args:list Type} {res:Type}:
  arrows_left args res -> tuple args -> res :=
  match args return forall res, arrows_left args res -> tuple args -> res with
    | [] => fun _ f _ => f
    | t::q => fun res f p => let (d, t) := p in
      (@uncurry q _ f t) d
  end res.

Lemma JMeq_eqrect:
  forall (U:Type) (a b:U) (P:U -> Type) (x:P a) (e:a=b),
    eq_rect a P x b e ~= x.
Proof.
destruct e.
reflexivity.
Qed.


(** This file was written by Colm Bhandal, PhD student, Foundations and Methods group,
School of Computer Science and Statistics, Trinity College, Dublin, Ireland.*)

(***************************** Standard Imports *****************************)

(***************************** Specialised Imports *****************************)

Require Import ComhCoq.StandardResults.
Require Import ComhCoq.ComhBasics.
Require Import ComhCoq.LanguageFoundations.
Require Import ComhCoq.SoftwareLanguage.
Require Import ComhCoq.ProcEquiv.

(********************** Single ProcTerm State Predicates **********************)

(******** Simple ********)

(*Broadcast*)

Definition bcWaitState (m : Mode) (x : Time) (p : ProcTerm) : Prop :=
    p ~p~ (bcWait m x).

Definition sleepingState (p : ProcTerm) : Prop :=
  p ~p~ sleeping.

Definition bcReadyState (m : Mode) (l : Position) (p : ProcTerm) : Prop :=
  p ~p~ (bcReady m l).

(*Overlap*)

Definition dormantState (p : ProcTerm) : Prop :=
  p ~p~ dormant.

Definition ovWaitState (m : Mode) (t x y: Time) (p : ProcTerm) : Prop :=
  p ~p~ ovWait m t x y.

Definition ovReadyState (m : Mode) (t : Time) (l : Position) (p : ProcTerm) : Prop :=
  p ~p~ ovReady m t l.

Definition switchBcState (m : Mode) (p : ProcTerm) : Prop :=
  p ~p~ switchBc m.

Definition switchCurrState (p : ProcTerm) : Prop :=
  p ~p~ switchCurr.

Definition switchListenState (p : ProcTerm) : Prop :=
  p ~p~ switchListen.

Definition tfsStartState (p : ProcTerm) : Prop :=
  p ~p~ tfsStart.

Definition tfsNextState (m : Mode) (p : ProcTerm) : Prop :=
  p ~p~ tfsNext m.

Definition tfsCurrState (p : ProcTerm) : Prop :=
  p ~p~ tfsCurr.

Definition tfsBcState (p : ProcTerm) : Prop :=
  p ~p~ tfsBc.

Definition tfsListenState (p : ProcTerm) : Prop :=
  p ~p~ tfsListen.

Definition initState (m : Mode) (p : ProcTerm) : Prop :=
  p ~p~ init m.

Definition ovAbortState (p : ProcTerm) : Prop :=
  p ~p~ ovAbort.

(*Listening*)

(*Note that many of the constructors for listeningState actually take a state
that "evaluates" to listeningState so to speak i.e. it is a conditional branch
whose condition is true and whose then branch is the listeningState.*)
Definition listeningState (p : ProcTerm) : Prop :=
  p ~p~ listening.

Definition rangeBadState (m : Mode) (p : ProcTerm) : Prop :=
  p ~p~ rangeBad m.

Definition currOKState (m' : Mode) (p : ProcTerm) : Prop :=
  p ~p~ currOK m'.

Definition abortOvlpState (p : ProcTerm) : Prop :=
  p ~p~ abortOvlp.

Definition badOvlpState (p : ProcTerm) : Prop :=
  p ~p~ badOvlp.

Definition currCompState (m : Mode) (r : Distance) (p : ProcTerm) : Prop :=
  p ~p~ currComp m r.

Definition pausedState (p : ProcTerm) : Prop :=
  p ~p~ paused.

Definition gotMsgState (m : Mode) (l : Position) (p : ProcTerm) : Prop :=
  p ~p~ gotMsg m l.

Definition gotRangeState (m : Mode) (r : Distance) (p : ProcTerm) : Prop :=
  p ~p~ gotRange m r.

Definition currEqState (m m' : Mode) (p : ProcTerm) : Prop :=
  p ~p~ currEq m m'.

Definition nextEqState (m m' : Mode) (p : ProcTerm) : Prop :=
  p ~p~ nextEq m m'.

Definition currPincCheckState (m m' : Mode) (d : Distance) (p : ProcTerm) : Prop :=
  p ~p~ currPincCheck m m' d.

Definition nextPincCheckState (m m' : Mode) (d : Distance) (p : ProcTerm) : Prop :=
  p ~p~ nextPincCheck m m' d.

(******** Compound ********)

(*Broadcast*)

Inductive broadcastState (p : ProcTerm) : Prop :=
  | broadBcwSt (m : Mode) (x : Time) : bcWaitState m x p -> broadcastState p
  | broadSlpSt : sleepingState p -> broadcastState p
  | broadBcrSt (m : Mode) (l : Position) : bcReadyState m l p -> broadcastState p.

(*Overlap*)

(*INCOMPLETE- Need to add constructors for ALL the overlap states.*)
Inductive overlapState (p : ProcTerm) : Prop :=
  | ovlpDorSt : dormantState p -> overlapState p
  | ovlpWaSt (m : Mode) (t x y : Time) : ovWaitState m t x y p -> overlapState p.

Inductive nextSinceState (p : ProcTerm) : Prop :=
  | nexsOvwSt (m : Mode) (t x y : Time) : ovWaitState m t x y p -> nextSinceState p
  | nexsOvrSt (m : Mode) (t : Time) (l : Position) : ovReadyState m t l p -> nextSinceState p
  | nexsSbcSt (m : Mode) : switchBcState m p -> nextSinceState p
  | nexsScSt (m : Mode) : switchCurrState p -> nextSinceState p.

Inductive tfsState (p : ProcTerm) : Prop :=
  | tfsStaSt : tfsStartState p -> tfsState p
  | tfsNexSt (m : Mode) : tfsNextState m p -> tfsState p
  | tfsCurSt : tfsCurrState p -> tfsState p
  | tfsBcSt : tfsBcState p -> tfsState p
  | tfsLisSt : tfsListenState p -> tfsState p.

Inductive switchState (p : ProcTerm) : Prop :=
  | switBcSt (m : Mode) : switchBcState m p -> switchState p
  | switCurSt : switchCurrState p -> switchState p
  | switLisSt : switchListenState p -> switchState p.

(*Listening*)

Inductive listenerState (p : ProcTerm) : Prop :=
  | listLisSt : listeningState p -> listenerState p
  | listRbSt (m : Mode) : rangeBadState m p -> listenerState p
  | listCokSt (m : Mode) : currOKState m p -> listenerState p
  | listAovSt : abortOvlpState p -> listenerState p
  | listBovSt : badOvlpState p -> listenerState p
  | listCucost (m : Mode) (r : Distance) : currCompState m r p -> listenerState p.

(********************** Protocol Lift State Predicates **********************)

(******** Lifting Functions ********)

Inductive liftBroadcast (X : ProcTerm -> Prop) : ProcTerm -> Prop :=
  | lftbc (p p2 p3 : ProcTerm) : X p -> liftBroadcast X (p $||$ p2 $||$ p3) .

Inductive liftOverlap (X : ProcTerm -> Prop) : ProcTerm -> Prop :=
  | lftOv (p1 p p3 : ProcTerm) : X p -> liftOverlap X (p1 $||$ p $||$ p3) .

Inductive liftListen (X : ProcTerm -> Prop) : ProcTerm -> Prop :=
  | lftlst (p1 p2 p : ProcTerm) : X p -> liftListen X (p1 $||$ p2 $||$ p) .

(******** Simple ********)

(*Broadcast*)

Definition bcWaitStateProt m x := liftBroadcast (bcWaitState m x).
Definition sleepingStateProt := liftBroadcast sleepingState.
Definition bcReadyStateProt m l := liftBroadcast (bcReadyState m l).

(*Overlap*)

Definition dormantStateProt := liftOverlap dormantState.
Definition ovWaitStateProt m' t x y := liftOverlap (ovWaitState m' t x y).
Definition tfsListenStateProt := liftOverlap tfsListenState.
Definition tfsBcStateProt := liftOverlap tfsBcState.
Definition tfsCurrStateProt := liftOverlap tfsCurrState.
Definition ovAbortStateProt := liftOverlap ovAbortState.
Definition switchBcStateProt m := liftOverlap (switchBcState m).
Definition tfsNextStateProt m := liftOverlap (tfsNextState m).
Definition tfsStartStateProt := liftOverlap tfsStartState.
Definition initStateProt m := liftOverlap (initState m).
Definition ovReadyStateProt m t l := liftOverlap (ovReadyState m t l).
Definition switchCurrStateProt := liftOverlap switchCurrState.
Definition switchListenStateProt := liftOverlap switchListenState.

(*Listening*)

Definition listeningStateProt := liftListen listeningState.
Definition currCompStateProt m'' r := liftListen (currCompState m'' r).
Definition abortOvlpStateProt := liftListen abortOvlpState.
Definition badOvlpStateProt := liftListen badOvlpState.
Definition pausedStateProt := liftListen pausedState.
Definition gotMsgStateProt m l := liftListen (gotMsgState m l).
Definition gotRangeStateProt m r := liftListen (gotRangeState m r).
Definition rangeBadStateProt m := liftListen (rangeBadState m).
Definition currOKStateProt m := liftListen (currOKState m).
Definition currEqStateProt m m'' := liftListen (currEqState m m'').
Definition nextEqStateProt m m' := liftListen (nextEqState m m').
Definition currPincCheckStateProt m m'' r := liftListen (currPincCheckState m m'' r).
Definition nextPincCheckStateProt m m'' r := liftListen (nextPincCheckState m m'' r).

(******** Compound ********)

(*Broadcast*)

Definition broadcastStateProt :=  liftBroadcast broadcastState.

(*Overlap*)

Definition overlapStateProt := liftOverlap overlapState.
Definition nextSinceStateProt := liftOverlap nextSinceState.
Definition tfsStateProt := liftOverlap tfsState.
Definition switchStateProt := liftOverlap switchState.

(*Listening*)

Definition listenerStateProt := liftListen listenerState.

(********************** Other **********************)

Inductive protocolState : ProcTerm -> Prop :=
  | protState (p1 p2 p3 : ProcTerm) :
    broadcastState p1 -> overlapState p2 -> listenerState p3 ->
    protocolState (p1 $||$ p2 $||$ p3).

(** Reachability from the protocol process. Any process that is reachable from the
  protocol process via a finite number of steps as per the semantics satisfies this relation.*)
Inductive reachableProt : ProcTerm -> Prop :=
  | reachprBase : reachableProt procProtocol
  | reachprDisc (p p' : ProcTerm) (a : DiscAct) : reachableProt p ->
  p -PA- a -PA> p' -> reachableProt p'
  | reachprDel (p p' : ProcTerm) (d : Delay) : reachableProt p ->
  p -PD- d -PD> p' -> reachableProt p'.

Inductive initialProc : ProcTerm -> Prop :=
  initProcProt : initialProc procProtocol.


(* This program 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 program 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 General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*****************************************************************************)
(*          Projet Formel - Calculus of Inductive Constructions V5.10        *)
(*****************************************************************************)
(*									     *)
(*	            Existence of Right Adjoint                		     *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                     A. SAIBI	  May 95                  		     *)
(*									     *)
(*****************************************************************************)

Require Export Adj_UA.

Set Implicit Arguments.
Unset Strict Implicit.

Section ua_to_radj.

Variables (C D : Category) (F : Functor D C).

Hypothesis UA_of : forall c : C, CoUA c F.

(* construction de l'adj droit *)

Definition CoadjointUA_ob (c : C) := CoUA_ob (UA_of c).

 Section coadjoint_ua_map_def.

 Variable c c' : C.

 Definition CoadjointUA_mor (f : c --> c') :=
   CoUA_diese (UA_of c') (CoUA_mor (UA_of c) o f).

 Lemma CoadjointUA_map_law : Map_law CoadjointUA_mor.
 Proof.
 unfold Map_law, CoadjointUA_mor in |- *; intros f g H.
 apply
  (Codiese_map (UA_of c') (x:=CoUA_mor (UA_of c) o f)
     (y:=CoUA_mor (UA_of c) o g)).
 apply Comp_l; assumption.
 Qed.

 Canonical Structure CoadjointUA_map :
   Map (c --> c') (CoadjointUA_ob c --> CoadjointUA_ob c') :=
   CoadjointUA_map_law.

 End coadjoint_ua_map_def.

Lemma CoadjointUA_id_law : Fid_law CoadjointUA_map.
Proof.
unfold Fid_law in |- *; simpl in |- *.
unfold CoadjointUA_mor, CoadjointUA_ob in |- *.
intro c.
apply CoUA_unic1.
(* *) apply Trans with (Id (F (CoUA_ob (UA_of c))) o CoUA_mor (UA_of c)).
apply Comp_r; apply FId.
(* *) apply Trans with (CoUA_mor (UA_of c)).
apply Idl.
apply Idr.
Qed.

Lemma CoadjointUA_comp_law : Fcomp_law CoadjointUA_map.
Proof.
unfold Fcomp_law in |- *; simpl in |- *.
unfold CoadjointUA_mor, CoadjointUA_ob in |- *; intros c1 c2 c3 f g.
apply CoUA_unic1.
(* *) apply
       Trans
        with
          ((FMor F (CoUA_diese (UA_of c2) (CoUA_mor (UA_of c1) o f))
            o FMor F (CoUA_diese (UA_of c3) (CoUA_mor (UA_of c2) o g)))
           o CoUA_mor (UA_of c3)).
apply Comp_r; apply FComp.
(* *) apply
       Trans
        with
          (FMor F (CoUA_diese (UA_of c2) (CoUA_mor (UA_of c1) o f))
           o FMor F (CoUA_diese (UA_of c3) (CoUA_mor (UA_of c2) o g))
             o CoUA_mor (UA_of c3)).
apply Ass1.
(* *) apply
       Trans
        with
          (FMor F (CoUA_diese (UA_of c2) (CoUA_mor (UA_of c1) o f))
           o CoUA_mor (UA_of c2) o g).
apply Comp_l; apply CoUA_diag.

(* *) apply
       Trans
        with
          ((FMor F (CoUA_diese (UA_of c2) (CoUA_mor (UA_of c1) o f))
            o CoUA_mor (UA_of c2)) o g).
apply Ass.

(* *) apply Trans with ((CoUA_mor (UA_of c1) o f) o g).
apply Comp_r; apply CoUA_diag.
apply Ass1.
Qed.

Canonical Structure CoadjointUA :=
  Build_Functor CoadjointUA_comp_law CoadjointUA_id_law.

(* *)

(* definition de PhiUA':C(F-,-) -> D(-,G-) *)

 Section psi_ua_tau_def.

 Variable dxc : POb (Dual D) C.

 Definition PsiUA_arrow (f : F (Ob_l dxc) --> Ob_r dxc) :=
   CoUA_diese (UA_of (Ob_r dxc)) f.

 Lemma PsiUA_arrow_map_law : Map_law PsiUA_arrow.
 Proof.
 unfold Map_law, PsiUA_arrow in |- *.
 intros f g H.
 apply (Codiese_map (UA_of (Ob_r dxc)) (x:=f) (y:=g)).
 assumption.
 Qed.

 Canonical Structure PsiUA_tau := Build_Map PsiUA_arrow_map_law.

 End psi_ua_tau_def.

Lemma PsiUA_tau_nt_law :
 NT_law (F:=FunSET2_r F) (G:=FunSET2_l CoadjointUA) PsiUA_tau.
Proof.
unfold NT_law, PsiUA_tau, PsiUA_arrow in |- *; simpl in |- *.
unfold Ext in |- *; simpl in |- *.
intros d1xc1 d2xc2 fxg h.
unfold FunSET2_r_mor1, FunSET2_l_mor1, FunSET2_l_ob in |- *; simpl in |- *;
 unfold CoadjointUA_ob in |- *.
apply CoUA_unic1.
(* *) apply
       Trans
        with
          ((FMor F (HOM_l fxg o CoUA_diese (UA_of (Ob_r d1xc1)) h)
            o FMor F (FMor CoadjointUA (Hom_r fxg)))
           o CoUA_mor (UA_of (Ob_r d2xc2))).
apply Comp_r; apply FComp.
(* *) apply
       Trans
        with
          (((FMor F (HOM_l fxg) o FMor F (CoUA_diese (UA_of (Ob_r d1xc1)) h))
            o FMor F (FMor CoadjointUA (Hom_r fxg)))
           o CoUA_mor (UA_of (Ob_r d2xc2))).
apply Comp_r; apply Comp_r; apply FComp.
(* *) apply
       Trans
        with
          ((FMor F (HOM_l fxg) o FMor F (CoUA_diese (UA_of (Ob_r d1xc1)) h))
           o FMor F (FMor CoadjointUA (Hom_r fxg))
             o CoUA_mor (UA_of (Ob_r d2xc2))).
apply Ass1.
(* *) apply
       Trans
        with
          (FMor F (HOM_l fxg)
           o FMor F (CoUA_diese (UA_of (Ob_r d1xc1)) h)
             o FMor F (FMor CoadjointUA (Hom_r fxg))
               o CoUA_mor (UA_of (Ob_r d2xc2))).
apply Ass1.
(* *) apply Trans with (FMor F (HOM_l fxg) o h o Hom_r fxg).
apply Comp_l.
(* *) apply
       Trans
        with
          (FMor F (CoUA_diese (UA_of (Ob_r d1xc1)) h)
           o CoUA_mor (UA_of (Ob_r d1xc1)) o Hom_r fxg).
apply Comp_l.
unfold FMor at 2 in |- *; simpl in |- *;
 unfold CoadjointUA_mor, CoadjointUA_ob in |- *.
apply CoUA_diag.
(* *) apply
       Trans
        with
          ((FMor F (CoUA_diese (UA_of (Ob_r d1xc1)) h)
            o CoUA_mor (UA_of (Ob_r d1xc1))) o Hom_r fxg).
apply Ass.
apply Comp_r; apply CoUA_diag.
apply Ass.
Qed.

Canonical Structure PsiUA := Build_NT PsiUA_tau_nt_law.

(* PsiUA_1 *)

 Section psi_ua_1_tau_def.

 Variable dxc : POb (Dual D) C.

 Definition PsiUA_1_arrow (f : OB_l dxc --> CoadjointUA (Ob_r dxc)) :=
   FMor F f o CoUA_mor (UA_of (Ob_r dxc)).

 Lemma PsiUA_1_arrow_map_law : Map_law PsiUA_1_arrow.
 Proof.
 unfold Map_law, PsiUA_1_arrow in |- *.
 intros f g H.
 apply Comp_r; apply FPres; assumption.
 Qed.

 Canonical Structure PsiUA_1_tau := Build_Map PsiUA_1_arrow_map_law.

 End psi_ua_1_tau_def.

Lemma PsiUA_1_tau_nt_law :
 NT_law (F:=FunSET2_l CoadjointUA) (G:=FunSET2_r F) PsiUA_1_tau.
Proof.
unfold NT_law, PsiUA_1_tau, PsiUA_1_arrow in |- *; simpl in |- *.
unfold Ext in |- *; simpl in |- *.
intros d1xc1 d2xc2 fxg h.
unfold FunSET2_r_mor1, FunSET2_l_mor1 in |- *.
unfold FOb at 1 in |- *; simpl in |- *; unfold FunSET2_r_ob in |- *.
(* *) apply
       Trans
        with
          (((FMor F (HOM_l fxg) o FMor F h)
            o FMor F (FMor CoadjointUA (Hom_r fxg)))
           o CoUA_mor (UA_of (Ob_r d2xc2))).
apply Comp_r.
(* *) apply
       Trans
        with (FMor F (HOM_l fxg o h) o FMor F (FMor CoadjointUA (Hom_r fxg))).
apply FComp.
apply Comp_r; apply FComp.
(* *) apply
       Trans
        with
          ((FMor F (HOM_l fxg) o FMor F h)
           o FMor F (FMor CoadjointUA (Hom_r fxg))
             o CoUA_mor (UA_of (Ob_r d2xc2))).
apply Ass1.
(* *) apply
       Trans
        with
          (FMor F (HOM_l fxg)
           o FMor F h
             o FMor F (FMor CoadjointUA (Hom_r fxg))
               o CoUA_mor (UA_of (Ob_r d2xc2))).
apply Ass1.
(* *) apply
       Trans
        with
          (FMor F (HOM_l fxg)
           o (FMor F h o CoUA_mor (UA_of (Ob_r d1xc1))) o Hom_r fxg).
apply Comp_l.
(* *) apply Trans with (FMor F h o CoUA_mor (UA_of (Ob_r d1xc1)) o Hom_r fxg).
apply Comp_l.
unfold FMor at 2 in |- *; simpl in |- *;
 unfold CoadjointUA_mor, CoadjointUA_ob in |- *.
apply CoUA_diag.
apply Ass.
apply Ass.
Qed.

Canonical Structure PsiUA_1 := Build_NT PsiUA_1_tau_nt_law.

(* PsiUA et PsiUA_1 sont iso *)

 Section psi_ua_iso.

 Variable dxc : POb (Dual D) C.

 Lemma PsiUA_1_o_PsiUA : AreIsos (PsiUA dxc) (PsiUA_1 dxc).
 Proof.
 unfold AreIsos, RIso_law in |- *; simpl in |- *; split.
 unfold Ext in |- *; simpl in |- *.
 unfold PsiUA_arrow, Id_fun, PsiUA_1_arrow in |- *.
 intro f.
 unfold FunSET2_l_ob in |- *; simpl in |- *; unfold CoadjointUA_ob in |- *.
 apply CoUA_unic1; apply Refl.
 (**)
 unfold Ext in |- *; simpl in |- *.
 unfold PsiUA_arrow, Id_fun, PsiUA_1_arrow in |- *.
 intro f.
 unfold FunSET2_r_ob in |- *; apply (CoUA_diag (UA_of (Ob_r dxc))).
 Qed.

 End psi_ua_iso.

Definition CoAdjUA := Build_Adj (NT_Iso PsiUA_1_o_PsiUA).

Canonical Structure RightAdjUA := Build_RightAdj CoAdjUA.

End ua_to_radj.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Arith.

(* Defining variables as nats is basically a convenience because the String_as_OT item
   from the OrderedTypeEx module is broken, so using strings is out *)
Definition var := nat.

Inductive type : Type :=
| Unit
| Arrow (a : type) (b : type)
| Ref (a : type)
.

Inductive const : Type :=
| unit
| cell
| exch
| thread
| handle
.

Inductive expr : Type :=
| evar (x : var)
| econst (c : const)
| lam (x : var) (T : type) (e : expr)
| app (e1 : expr) (e2 : expr)
.

Inductive val : Type :=
| value_var (x : var)
| value_c (c : const)
| value_lam (x : var) (T : type) (e : expr)
| value_exch (v : val).

Inductive config : Type :=
| conc (c1 : config) (c2 : config)
| newplace (x : var) (c : config)
| cellmake (x : var) (v : expr)
| threadval (x : var) (e : expr)
| handledfut (y : var) (x : var)
| usedhandle (y : var)
.

(* Notation and Coercions *)

Notation "t1 '>>' t2" := (Arrow t1 t2) (at level 90, right associativity).
Notation "f @ g" := (app f g) (at level 71, left associativity).

Notation "c1 $$ c2" := (conc c1 c2) (at level 93, left associativity).
Notation "x '<-' e" := (threadval x e) (at level 91).
Notation "h ~ x" := (handledfut h x) (at level 91).
Notation "h ~ 'used'" := (usedhandle h) (at level 91).
Notation "x 'c=' v" := (cellmake x v) (at level 91).
Notation "x ** cfg" := (newplace x cfg) (at level 92, right associativity).

(* Coercions between the various types *)

Definition coerce_const_to_val (c : const) : val :=
  value_c c.
Coercion coerce_const_to_val : const >-> val.

Definition coerce_var_to_val (x : var) : val :=
  value_var x.
Coercion coerce_var_to_val : var >-> val.

Fixpoint coerce_val_to_expr (v : val) : expr :=
  match v with
  | value_var x => (evar x)
  | value_lam x T e => lam x T e
  | value_c c => (econst c)
  | value_exch v => (app (econst exch) (coerce_val_to_expr v))
  end.
Coercion coerce_val_to_expr : val >-> expr.


(* This program 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 program 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 program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(** * Weights of encodings

- Key definitions: [weight]
- Initial author: Laurent.Thery@inria.fr (2003)

*)

From Coq Require Import Sorting.Permutation.
From Huffman Require Export Code Frequency ISort UniqueKey.

Set Default Proof Using "Type".

Section Weight.
Variable A : Type.
Variable A_eq_dec : forall a b : A, {a = b} + {a <> b}.

Theorem fold_plus_split :
 forall (B : Type) (l : list B) (c : nat) (f : B -> nat),
 c + fold_left (fun (a : nat) (b : B) => a + f b) l 0 =
 fold_left (fun (a : nat) (b : B) => a + f b) l c.
Proof.
intros B l; elim l; simpl in |- *; auto.
intros a l0 H c f.
rewrite <- (H (f a)).
rewrite <- (H (c + f a)).
rewrite Nat.add_assoc; auto.
Qed.

Theorem fold_plus_permutation :
 forall (B : Type) (l1 l2 : list B) (c : nat) (f : B -> nat),
 Permutation l1 l2 ->
 fold_left (fun (a : nat) (b : B) => a + f b) l1 c =
 fold_left (fun (a : nat) (b : B) => a + f b) l2 c.
Proof.
intros B l1 l2 c f H; generalize c f; elim H; clear H l1 l2 c f;
 simpl in |- *; auto.
intros a b L c f; repeat rewrite <- Nat.add_assoc; rewrite (Nat.add_comm (f a));
 auto.
intros L1 L2 L3 H H0 H1 H2 c f; apply trans_equal with (1 := H0 c f); auto.
Qed.

Theorem length_encode_nId :
 forall a l1 l n,
 length (encode A_eq_dec ((a, l1) :: l) (id_list a n)) = n * length l1.
Proof.
intros a l1 l n; elim n; simpl in |- *; auto.
intros n0 H; case (A_eq_dec a a); auto.
intros e; rewrite app_length; rewrite H; auto.
intros H1; case H1; auto.
Qed.

Theorem frequency_length :
 forall (m : list A) (c : code A),
 unique_key c ->
 length (encode A_eq_dec c m) =
 fold_left
   (fun a b => a + number_of_occurrences A_eq_dec (fst b) m * length (snd b))
   c 0.
Proof.
intros m c; generalize m; elim c; clear c m; simpl in |- *; auto.
intros m; elim m; simpl in |- *; auto.
intros (a, l1) l Rec m H; simpl in |- *.
case (number_of_occurrences_permutation_ex A A_eq_dec m a);
 intros m1 (Hm1, Hm2).
rewrite
 Permutation_length
                    with
                    (1 :=
                      encode_permutation_val _ A_eq_dec _ _ ((a, l1) :: l) Hm1).
rewrite encode_app; auto.
rewrite app_length; auto.
rewrite length_encode_nId.
rewrite encode_cons_inv; auto.
rewrite Rec; simpl in |- *; auto.
rewrite <-
 fold_plus_split
                 with
                 (f :=
                   fun b : A * list bool =>
                   number_of_occurrences A_eq_dec (fst b) m * length (snd b))
                (c := number_of_occurrences A_eq_dec a m * length l1).
apply f_equal2 with (f := plus); auto.
cut (forall l2, ~ In (a, l2) l).
elim l; simpl in |- *; auto.
intros (a2, l2) l3; simpl in |- *; intros Rec1 H4.
rewrite <-
 fold_plus_split
                 with
                 (c := number_of_occurrences A_eq_dec a2 m1 * length l2)
                (f :=
                  fun b : A * list bool =>
                  number_of_occurrences A_eq_dec (fst b) m1 * length (snd b)).
rewrite <-
 fold_plus_split
                 with
                 (c := number_of_occurrences A_eq_dec a2 m * length l2)
                (f :=
                  fun b : A * list bool =>
                  number_of_occurrences A_eq_dec (fst b) m * length (snd b)).
apply f_equal2 with (f := plus); auto.
2: apply Rec1; auto.
2: intros l0; red in |- *; intros H0; case (H4 l0); auto.
2: intros l2; red in |- *; intros H0;
    case unique_key_in with (1 := H) (a := a) (b2 := l2);
    auto.
2: apply unique_key_inv with (1 := H); auto.
apply f_equal2 with (f := mult); auto.
apply
 trans_equal
  with
    (2 := number_of_occurrences_permutation _ A_eq_dec _ _ a2
            (Permutation_sym Hm1)).
rewrite number_of_occurrences_app.
replace
 (number_of_occurrences A_eq_dec a2
    (id_list a (number_of_occurrences A_eq_dec a m))) with 0;
 auto.
cut (a2 <> a).
elim (number_of_occurrences A_eq_dec a m); simpl in |- *; auto.
intros n H0 H1; case (A_eq_dec a2 a); simpl in |- *; auto.
intros e; case H1; auto.
red in |- *; intros H0; case (H4 l2); left;
 apply f_equal2 with (f := pair (A:=A) (B:=list bool));
 auto.
Qed.

Definition weight m c := length (encode A_eq_dec c m).

Theorem weight_permutation :
 forall m c1 c2,
 unique_prefix c1 -> Permutation c1 c2 -> weight m c1 = weight m c2.
Proof.
intros m c1 c2 H H0; unfold weight in |- *.
apply f_equal with (f := length (A:=bool)).
apply encode_permutation; auto.
Qed.

Definition restrict_code (m : list A) (c : code A) :
  code A :=
  map (fun x => (fst x, find_code A_eq_dec (fst x) c))
    (frequency_list A_eq_dec m).

Theorem NoDup_unique_key :
 forall (A B : Type) (l : list (A * B)),
 NoDup (map (fst (B:=_)) l) -> unique_key l.
Proof.
intros AA BB l; elim l; simpl in |- *; auto.
intros a; case a.
intros a0 b l0 H H0; apply unique_key_cons; auto.
intros b0; red in |- *; intros H1; absurd (In a0 (map (fst (B:=_)) l0)); auto.
inversion H0; auto.
change (In (fst (a0, b0)) (map (fst (B:=_)) l0)) in |- *; auto with datatypes.
apply in_map; auto.
apply H; apply NoDup_cons_iff with (1 := H0); auto.
Qed.

Theorem restrict_code_unique_key :
 forall (m : list A) (c : code A), unique_key (restrict_code m c).
Proof.
intros m c; apply NoDup_unique_key.
unfold restrict_code in |- *.
replace
 (map (fst (B:=_))
    (map (fun x : A * nat => (fst x, find_code A_eq_dec (fst x) c))
       (frequency_list A_eq_dec m))) with
 (map (fst (B:=_)) (frequency_list A_eq_dec m)).
apply unique_key_NoDup; auto.
elim (frequency_list A_eq_dec m); simpl in |- *; auto with datatypes.
intros a l H; apply f_equal2 with (f := cons (A:=A)); auto.
Qed.

Theorem restrict_code_in :
 forall (m : list A) (a : A) (c : code A),
 In a m -> find_code A_eq_dec a c = find_code A_eq_dec a (restrict_code m c).
Proof.
intros m a c H.
apply sym_equal; apply find_code_correct2; auto.
apply restrict_code_unique_key.
generalize (in_frequency_map _ A_eq_dec m a H).
unfold restrict_code in |- *; elim (frequency_list A_eq_dec m); simpl in |- *;
 auto with datatypes.
intros a0; case a0; simpl in |- *; auto with datatypes.
intros a1 n l H0 [H1| H1]; try rewrite H1; auto.
Qed.

Theorem restrict_code_encode_length_inc :
 forall (m m1 : list A) (c : code A),
 incl m1 m -> encode A_eq_dec c m1 = encode A_eq_dec (restrict_code m c) m1.
Proof.
intros m m1 c; elim m1; simpl in |- *; auto.
intros a l H H0.
apply f_equal2 with (f := app (A:=bool)); auto with datatypes.
apply restrict_code_in; auto with datatypes.
apply H; apply incl_tran with (2 := H0); auto with datatypes.
Qed.

Theorem restrict_code_encode_length :
 forall (m : list A) (c : code A),
 encode A_eq_dec c m = encode A_eq_dec (restrict_code m c) m.
Proof.
intros m c; apply restrict_code_encode_length_inc; auto with datatypes.
Qed.

End Weight.
Arguments weight [A].
Arguments restrict_code [A].


(** * Definition of minimal parse trees *)
Require Import Coq.Strings.String Coq.Lists.List Coq.Setoids.Setoid.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.Reachable.All.Reachable.
Require Import Fiat.Parsers.BaseTypes.

Local Coercion is_true : bool >-> Sortclass.

Set Implicit Arguments.
Local Open Scope string_like_scope.

Section cfg.
  Context {Char} {HSLM : StringLikeMin Char} {G : grammar Char}.
  Context {predata : @parser_computational_predataT Char}
          {rdata' : @parser_removal_dataT' _ G predata}.

  Context (ch : Char).

  Inductive minimal_reachable_from_productions : nonterminals_listT -> productions Char -> Type :=
  | MinReachableHead : forall valid pat pats, minimal_reachable_from_production valid pat
                                              -> minimal_reachable_from_productions valid (pat::pats)
  | MinReachableTail : forall valid pat pats, minimal_reachable_from_productions valid pats
                                              -> minimal_reachable_from_productions valid (pat::pats)
  with minimal_reachable_from_production : nonterminals_listT -> production Char -> Type :=
  | MinReachableProductionHead : forall valid it its, minimal_reachable_from_item valid it
                                                      -> minimal_reachable_from_production valid (it::its)
  | MinReachableProductionTail : forall valid it its, minimal_reachable_from_production valid its
                                                      -> minimal_reachable_from_production valid (it::its)
  with minimal_reachable_from_item : nonterminals_listT -> item Char -> Type :=
  | MinReachableTerminal : forall valid P, is_true (P ch) -> minimal_reachable_from_item valid (Terminal P)
  | MinReachableNonTerminal : forall valid nt, is_valid_nonterminal valid (of_nonterminal nt)
                                               -> minimal_reachable_from_productions (remove_nonterminal valid (of_nonterminal nt)) (Lookup G nt)
                                               -> minimal_reachable_from_item valid (NonTerminal nt).

End cfg.


From Relational Require Import OrderEnrichedCategory GenericRulesSimple.

Set Warnings "-notation-overridden,-ambiguous-paths".
From mathcomp Require Import all_ssreflect all_algebra reals distr realsum
  ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice seq.
Set Warnings "notation-overridden,ambiguous-paths".

From Crypt Require Import Axioms ChoiceAsOrd SubDistr Couplings
  UniformDistrLemmas FreeProbProg Theta_dens RulesStateProb UniformStateProb
  pkg_core_definition choice_type pkg_composition pkg_rhl
  Package Prelude.

From Coq Require Import Utf8.
From extructures Require Import ord fset fmap.

Set Bullet Behavior "Strict Subproofs".
Set Default Goal Selector "!".
Set Primitive Projections.

Import Num.Def.
Import Num.Theory.

Import PackageNotation.

Module Type ROParams.

  Parameter Query : finType.
  Parameter Random : finType.

  Parameter Query_pos : Positive #|Query|.
  Parameter Random_pos : Positive #|Random|.

End ROParams.

Module RO (π : ROParams).

  Import π.

  #[local] Existing Instance Query_pos.
  #[local] Existing Instance Random_pos.

  Definition chQuery := 'fin #|Query|.
  Definition chRandom := 'fin #|Random|.
  Notation " 'query " := chQuery (in custom pack_type at level 2).
  Notation " 'random " := chRandom (in custom pack_type at level 2).

  Definition i_random := #|Random|.
  Definition INIT : nat := 0.
  Definition QUERY : nat := 1.

  Definition queries_loc : Location := (chMap chQuery chRandom ; 2).
  Definition RO_locs : {fset Location} := fset [:: queries_loc].

  Definition RO_exports :=
    [interface
      #val #[ INIT ] : 'unit → 'unit ;
      #val #[ QUERY ] : 'query → 'random
    ].

  Definition RO : package RO_locs [interface] RO_exports :=
    [package
      #def #[ INIT ] (_ : 'unit) : 'unit
      {
        #put queries_loc := emptym ;;
        ret Datatypes.tt
      } ;
      #def #[ QUERY ] (q : 'query) : 'random
      {
        queries ← get queries_loc ;;
        match queries q with
        | Some r =>
          ret r
        | None =>
          r ← sample uniform i_random ;;
          #put queries_loc := setm queries q r ;;
          ret r
        end
      }
    ].

End RO.


(** * Definition of a boolean-returning CFG parser-recognizer *)
Require Import Coq.Lists.List.
Require Import Fiat.Parsers.BaseTypes Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.MinimalParse.
Require Import Fiat.Common.

Local Open Scope string_like_scope.

Section general.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {G : grammar Char}.

  Definition split_list_completeT_for {data : @parser_computational_predataT Char}
             {len0 valid}
             (it : item Char) (its : production Char)
             (str : String)
             (pf : length str <= len0)
             (split_list : list nat)
    := ({ n : nat
              & (minimal_parse_of_item (G := G) len0 valid (take n str) it)
                * (minimal_parse_of_production (G := G) len0 valid (drop n str) its) }%type)
       -> ({ n : nat
                 & (In (min (length str) n) (map (min (length str)) split_list))
                   * (minimal_parse_of_item (G := G) len0 valid (take n str) it)
                   * (minimal_parse_of_production (G := G) len0 valid (drop n str) its) }%type).

  Definition split_list_completeT {data : @parser_computational_predataT Char}
             (splits : production_carrierT -> String -> nat -> nat -> list nat)
    := forall len0 valid str offset len (pf : length (substring offset len str) <= len0) nt,
         is_valid_nonterminal initial_nonterminals_data (of_nonterminal nt)
         -> len = 0 \/ offset + len <= length str
         -> ForallT
              (Forall_tails
                 (fun prod
                  => match prod return Type with
                       | nil => True
                       | it::its
                         => forall idx,
                              production_carrier_valid idx
                              -> to_production idx = it::its
                              -> @split_list_completeT_for data len0 valid it its (substring offset len str) pf (splits idx str offset len)
                     end))
              (Lookup G nt).

  Class boolean_parser_completeness_dataT' {data : boolean_parser_dataT} :=
    { split_string_for_production_complete
      : split_list_completeT split_string_for_production }.

  Class boolean_parser_correctness_dataT :=
    { data :> boolean_parser_dataT;
      rdata' :> @parser_removal_dataT' _ G _;
      cdata' :> boolean_parser_completeness_dataT' }.
End general.


(* This file is an automatic translation, the licence of the source can be found here: *)
(* https://github.com/herd/herdtools7/blob/master/LICENSE.txt *)
(* Translation of model MIPS-TSO *)
From Coq Require Import Relations Ensembles String.
From RelationAlgebra Require Import lattice prop monoid rel kat.
From Catincoq.lib Require Import Cat proprel.
Section Model.
Variable c : candidate.
Definition events := events c.
Definition R := R c.
Definition W := W c.
Definition IW := IW c.
Definition FW := FW c.
Definition B := B c.
Definition RMW := RMW c.
Definition F := F c.
Definition rf := rf c.
Definition po := po c.
Definition int := int c.
Definition ext := ext c.
Definition loc := loc c.
Definition addr := addr c.
Definition data := data c.
Definition ctrl := ctrl c.
Definition amo := amo c.
Definition rmw := rmw c.
Definition unknown_set := unknown_set c.
Definition unknown_relation := unknown_relation c.
Definition M := R ⊔ W.
Definition emptyset : set events := empty.
Definition classes_loc : set events -> Ensemble (Ensemble events) := partition loc.
Definition tag2events := unknown_relation "tag2events".
Definition emptyset_0 : set events := domain 0.
Definition partition := classes_loc.
Definition tag2instrs := tag2events.
Definition po_loc := po ⊓ loc.
Definition rfe := rf ⊓ ext.
Definition rfi := rf ⊓ int.
Definition co0 := loc ⊓ ([IW] ⋅ top ⋅ [(W ⊓ !IW)] ⊔ [(W ⊓ !FW)] ⋅ top ⋅ [FW]).
Definition toid (s : set events) : relation events := [s].
Definition fencerel (B : set events) := (po ⊓ [top] ⋅ top ⋅ [B]) ⋅ po.
Definition ctrlcfence (CFENCE : set events) := (ctrl ⊓ [top] ⋅ top ⋅ [CFENCE]) ⋅ po.
Definition imply (A : relation events) (B : relation events) := !A ⊔ B.
Definition nodetour (R1 : relation events) (R2 : relation events) (R3 : relation events) := R1 ⊓ !(R2 ⋅ R3).
Definition singlestep (R : relation events) := nodetour R R R.
(* Definition of map already included in the prelude *)
Definition LKW := (*failed: try LKW with emptyset_0*) emptyset_0.
Definition A := ((*failed: try X with emptyset_0*) emptyset_0) ⊔ ((*failed: try A with emptyset_0*) emptyset_0).
Definition P := M ⊓ !A.
Definition WW r := r ⊓ [W] ⋅ top ⋅ [W].
Definition WR r := r ⊓ [W] ⋅ top ⋅ [R].
Definition RW r := r ⊓ [R] ⋅ top ⋅ [W].
Definition RR r := r ⊓ [R] ⋅ top ⋅ [R].
Definition RM r := r ⊓ [R] ⋅ top ⋅ [M].
Definition MR r := r ⊓ [M] ⋅ top ⋅ [R].
Definition WM r := r ⊓ [W] ⋅ top ⋅ [M].
Definition MW r := r ⊓ [M] ⋅ top ⋅ [W].
Definition MM r := r ⊓ [M] ⋅ top ⋅ [M].
Definition AA r := r ⊓ [A] ⋅ top ⋅ [A].
Definition AP r := r ⊓ [A] ⋅ top ⋅ [P].
Definition PA r := r ⊓ [P] ⋅ top ⋅ [A].
Definition PP r := r ⊓ [P] ⋅ top ⋅ [P].
Definition AM r := r ⊓ [A] ⋅ top ⋅ [M].
Definition MA r := r ⊓ [M] ⋅ top ⋅ [A].
Definition noid r : relation events := r ⊓ !id.
Definition atom := [A].
(* Definition of co_locs already included in the prelude *)
(* Definition of cross already included in the prelude *)
Definition generate_orders s pco := cross (co_locs pco (partition s)).
Definition generate_cos pco := generate_orders W pco.
Definition cobase := co0.
Variable co : relation events.
Definition coi := co ⊓ int.
Definition coe := co ⊓ !coi.
Definition fr := rf° ⋅ co ⊓ !id.
Definition fri := fr ⊓ int.
Definition fre := fr ⊓ !fri.
Definition com := rf ⊔ (fr ⊔ co).
Definition uniproc := acyclic (po_loc ⊔ com).
Definition atomic := is_empty (rmw ⊓ fre ⋅ coe).
Definition sync : relation events := (*failed: try fencerel SYNC with 0*) 0.
Definition ppo := po ⊓ !([W] ⋅ top ⋅ [R]) ⊔ sync.
Definition ghb := ppo ⊔ (rfe ⊔ (fr ⊔ co)).
Definition tso := acyclic ghb.
Definition witness_conditions := generate_cos cobase co.
Definition model_conditions := uniproc /\ (atomic /\ tso).
End Model.

Hint Unfold events R W IW FW B RMW F rf po int ext loc addr data ctrl amo rmw unknown_set unknown_relation M emptyset classes_loc tag2events emptyset_0 partition tag2instrs po_loc rfe rfi co0 toid fencerel ctrlcfence imply nodetour singlestep LKW A P WW WR RW RR RM MR WM MW MM AA AP PA PP AM MA noid atom generate_orders generate_cos cobase coi coe fr fri fre com uniproc atomic sync ppo ghb tso witness_conditions model_conditions : cat.

Definition valid (c : candidate) :=
  exists co : relation (events c),
    witness_conditions c co /\
    model_conditions c co.

(* End of translation of model MIPS-TSO *)


Require Export VST.concurrency.paco.src.paconotation VST.concurrency.paco.src.pacotac VST.concurrency.paco.src.pacodef VST.concurrency.paco.src.pacotacuser.
Set Implicit Arguments.

(** ** Predicates of Arity 5
*)

(** 1 Mutual Coinduction *)

Section Arg5_1.

Definition monotone5 T0 T1 T2 T3 T4 (gf: rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4) :=
  forall x0 x1 x2 x3 x4 r r' (IN: gf r x0 x1 x2 x3 x4) (LE: r <5= r'), gf r' x0 x1 x2 x3 x4.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.
Variable gf : rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4.
Implicit Arguments gf [].

Theorem paco5_acc: forall
  l r (OBG: forall rr (INC: r <5= rr) (CIH: l <_paco_5= rr), l <_paco_5= paco5 gf rr),
  l <5= paco5 gf r.
Proof.
  intros; assert (SIM: paco5 gf (r \5/ l) x0 x1 x2 x3 x4) by eauto.
  clear PR; repeat (try left; do 6 paco_revert; paco_cofix_auto).
Qed.

Theorem paco5_mon: monotone5 (paco5 gf).
Proof. paco_cofix_auto; repeat (left; do 6 paco_revert; paco_cofix_auto). Qed.

Theorem paco5_mult_strong: forall r,
  paco5 gf (upaco5 gf r) <5= paco5 gf r.
Proof. paco_cofix_auto; repeat (left; do 6 paco_revert; paco_cofix_auto). Qed.

Corollary paco5_mult: forall r,
  paco5 gf (paco5 gf r) <5= paco5 gf r.
Proof. intros; eapply paco5_mult_strong, paco5_mon; eauto. Qed.

Theorem paco5_fold: forall r,
  gf (upaco5 gf r) <5= paco5 gf r.
Proof. intros; econstructor; [ |eauto]; eauto. Qed.

Theorem paco5_unfold: forall (MON: monotone5 gf) r,
  paco5 gf r <5= gf (upaco5 gf r).
Proof. unfold monotone5; intros; destruct PR; eauto. Qed.

End Arg5_1.

Hint Unfold monotone5.
Hint Resolve paco5_fold.

Implicit Arguments paco5_acc            [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_mon            [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_mult_strong    [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_mult           [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_fold           [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_unfold         [ T0 T1 T2 T3 T4 ].

Instance paco5_inst  T0 T1 T2 T3 T4 (gf : rel5 T0 T1 T2 T3 T4->_) r x0 x1 x2 x3 x4 : paco_class (paco5 gf r x0 x1 x2 x3 x4) :=
{ pacoacc    := paco5_acc gf;
  pacomult   := paco5_mult gf;
  pacofold   := paco5_fold gf;
  pacounfold := paco5_unfold gf }.

(** 2 Mutual Coinduction *)

Section Arg5_2.

Definition monotone5_2 T0 T1 T2 T3 T4 (gf: rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4) :=
  forall x0 x1 x2 x3 x4 r_0 r_1 r'_0 r'_1 (IN: gf r_0 r_1 x0 x1 x2 x3 x4) (LE_0: r_0 <5= r'_0)(LE_1: r_1 <5= r'_1), gf r'_0 r'_1 x0 x1 x2 x3 x4.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.
Variable gf_0 gf_1 : rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4.
Implicit Arguments gf_0 [].
Implicit Arguments gf_1 [].

Theorem paco5_2_0_acc: forall
  l r_0 r_1 (OBG: forall rr (INC: r_0 <5= rr) (CIH: l <_paco_5= rr), l <_paco_5= paco5_2_0 gf_0 gf_1 rr r_1),
  l <5= paco5_2_0 gf_0 gf_1 r_0 r_1.
Proof.
  intros; assert (SIM: paco5_2_0 gf_0 gf_1 (r_0 \5/ l) r_1 x0 x1 x2 x3 x4) by eauto.
  clear PR; repeat (try left; do 6 paco_revert; paco_cofix_auto).
Qed.

Theorem paco5_2_1_acc: forall
  l r_0 r_1 (OBG: forall rr (INC: r_1 <5= rr) (CIH: l <_paco_5= rr), l <_paco_5= paco5_2_1 gf_0 gf_1 r_0 rr),
  l <5= paco5_2_1 gf_0 gf_1 r_0 r_1.
Proof.
  intros; assert (SIM: paco5_2_1 gf_0 gf_1 r_0 (r_1 \5/ l) x0 x1 x2 x3 x4) by eauto.
  clear PR; repeat (try left; do 6 paco_revert; paco_cofix_auto).
Qed.

Theorem paco5_2_0_mon: monotone5_2 (paco5_2_0 gf_0 gf_1).
Proof. paco_cofix_auto; repeat (left; do 6 paco_revert; paco_cofix_auto). Qed.

Theorem paco5_2_1_mon: monotone5_2 (paco5_2_1 gf_0 gf_1).
Proof. paco_cofix_auto; repeat (left; do 6 paco_revert; paco_cofix_auto). Qed.

Theorem paco5_2_0_mult_strong: forall r_0 r_1,
  paco5_2_0 gf_0 gf_1 (upaco5_2_0 gf_0 gf_1 r_0 r_1) (upaco5_2_1 gf_0 gf_1 r_0 r_1) <5= paco5_2_0 gf_0 gf_1 r_0 r_1.
Proof. paco_cofix_auto; repeat (left; do 6 paco_revert; paco_cofix_auto). Qed.

Theorem paco5_2_1_mult_strong: forall r_0 r_1,
  paco5_2_1 gf_0 gf_1 (upaco5_2_0 gf_0 gf_1 r_0 r_1) (upaco5_2_1 gf_0 gf_1 r_0 r_1) <5= paco5_2_1 gf_0 gf_1 r_0 r_1.
Proof. paco_cofix_auto; repeat (left; do 6 paco_revert; paco_cofix_auto). Qed.

Corollary paco5_2_0_mult: forall r_0 r_1,
  paco5_2_0 gf_0 gf_1 (paco5_2_0 gf_0 gf_1 r_0 r_1) (paco5_2_1 gf_0 gf_1 r_0 r_1) <5= paco5_2_0 gf_0 gf_1 r_0 r_1.
Proof. intros; eapply paco5_2_0_mult_strong, paco5_2_0_mon; eauto. Qed.

Corollary paco5_2_1_mult: forall r_0 r_1,
  paco5_2_1 gf_0 gf_1 (paco5_2_0 gf_0 gf_1 r_0 r_1) (paco5_2_1 gf_0 gf_1 r_0 r_1) <5= paco5_2_1 gf_0 gf_1 r_0 r_1.
Proof. intros; eapply paco5_2_1_mult_strong, paco5_2_1_mon; eauto. Qed.

Theorem paco5_2_0_fold: forall r_0 r_1,
  gf_0 (upaco5_2_0 gf_0 gf_1 r_0 r_1) (upaco5_2_1 gf_0 gf_1 r_0 r_1) <5= paco5_2_0 gf_0 gf_1 r_0 r_1.
Proof. intros; econstructor; [ | |eauto]; eauto. Qed.

Theorem paco5_2_1_fold: forall r_0 r_1,
  gf_1 (upaco5_2_0 gf_0 gf_1 r_0 r_1) (upaco5_2_1 gf_0 gf_1 r_0 r_1) <5= paco5_2_1 gf_0 gf_1 r_0 r_1.
Proof. intros; econstructor; [ | |eauto]; eauto. Qed.

Theorem paco5_2_0_unfold: forall (MON: monotone5_2 gf_0) (MON: monotone5_2 gf_1) r_0 r_1,
  paco5_2_0 gf_0 gf_1 r_0 r_1 <5= gf_0 (upaco5_2_0 gf_0 gf_1 r_0 r_1) (upaco5_2_1 gf_0 gf_1 r_0 r_1).
Proof. unfold monotone5_2; intros; destruct PR; eauto. Qed.

Theorem paco5_2_1_unfold: forall (MON: monotone5_2 gf_0) (MON: monotone5_2 gf_1) r_0 r_1,
  paco5_2_1 gf_0 gf_1 r_0 r_1 <5= gf_1 (upaco5_2_0 gf_0 gf_1 r_0 r_1) (upaco5_2_1 gf_0 gf_1 r_0 r_1).
Proof. unfold monotone5_2; intros; destruct PR; eauto. Qed.

End Arg5_2.

Hint Unfold monotone5_2.
Hint Resolve paco5_2_0_fold.
Hint Resolve paco5_2_1_fold.

Implicit Arguments paco5_2_0_acc            [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_2_1_acc            [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_2_0_mon            [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_2_1_mon            [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_2_0_mult_strong    [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_2_1_mult_strong    [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_2_0_mult           [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_2_1_mult           [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_2_0_fold           [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_2_1_fold           [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_2_0_unfold         [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_2_1_unfold         [ T0 T1 T2 T3 T4 ].

Instance paco5_2_0_inst  T0 T1 T2 T3 T4 (gf_0 gf_1 : rel5 T0 T1 T2 T3 T4->_) r_0 r_1 x0 x1 x2 x3 x4 : paco_class (paco5_2_0 gf_0 gf_1 r_0 r_1 x0 x1 x2 x3 x4) :=
{ pacoacc    := paco5_2_0_acc gf_0 gf_1;
  pacomult   := paco5_2_0_mult gf_0 gf_1;
  pacofold   := paco5_2_0_fold gf_0 gf_1;
  pacounfold := paco5_2_0_unfold gf_0 gf_1 }.

Instance paco5_2_1_inst  T0 T1 T2 T3 T4 (gf_0 gf_1 : rel5 T0 T1 T2 T3 T4->_) r_0 r_1 x0 x1 x2 x3 x4 : paco_class (paco5_2_1 gf_0 gf_1 r_0 r_1 x0 x1 x2 x3 x4) :=
{ pacoacc    := paco5_2_1_acc gf_0 gf_1;
  pacomult   := paco5_2_1_mult gf_0 gf_1;
  pacofold   := paco5_2_1_fold gf_0 gf_1;
  pacounfold := paco5_2_1_unfold gf_0 gf_1 }.

(** 3 Mutual Coinduction *)

Section Arg5_3.

Definition monotone5_3 T0 T1 T2 T3 T4 (gf: rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4) :=
  forall x0 x1 x2 x3 x4 r_0 r_1 r_2 r'_0 r'_1 r'_2 (IN: gf r_0 r_1 r_2 x0 x1 x2 x3 x4) (LE_0: r_0 <5= r'_0)(LE_1: r_1 <5= r'_1)(LE_2: r_2 <5= r'_2), gf r'_0 r'_1 r'_2 x0 x1 x2 x3 x4.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.
Variable gf_0 gf_1 gf_2 : rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4.
Implicit Arguments gf_0 [].
Implicit Arguments gf_1 [].
Implicit Arguments gf_2 [].

Theorem paco5_3_0_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_0 <5= rr) (CIH: l <_paco_5= rr), l <_paco_5= paco5_3_0 gf_0 gf_1 gf_2 rr r_1 r_2),
  l <5= paco5_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco5_3_0 gf_0 gf_1 gf_2 (r_0 \5/ l) r_1 r_2 x0 x1 x2 x3 x4) by eauto.
  clear PR; repeat (try left; do 6 paco_revert; paco_cofix_auto).
Qed.

Theorem paco5_3_1_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_1 <5= rr) (CIH: l <_paco_5= rr), l <_paco_5= paco5_3_1 gf_0 gf_1 gf_2 r_0 rr r_2),
  l <5= paco5_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco5_3_1 gf_0 gf_1 gf_2 r_0 (r_1 \5/ l) r_2 x0 x1 x2 x3 x4) by eauto.
  clear PR; repeat (try left; do 6 paco_revert; paco_cofix_auto).
Qed.

Theorem paco5_3_2_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_2 <5= rr) (CIH: l <_paco_5= rr), l <_paco_5= paco5_3_2 gf_0 gf_1 gf_2 r_0 r_1 rr),
  l <5= paco5_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco5_3_2 gf_0 gf_1 gf_2 r_0 r_1 (r_2 \5/ l) x0 x1 x2 x3 x4) by eauto.
  clear PR; repeat (try left; do 6 paco_revert; paco_cofix_auto).
Qed.

Theorem paco5_3_0_mon: monotone5_3 (paco5_3_0 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 6 paco_revert; paco_cofix_auto). Qed.

Theorem paco5_3_1_mon: monotone5_3 (paco5_3_1 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 6 paco_revert; paco_cofix_auto). Qed.

Theorem paco5_3_2_mon: monotone5_3 (paco5_3_2 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 6 paco_revert; paco_cofix_auto). Qed.

Theorem paco5_3_0_mult_strong: forall r_0 r_1 r_2,
  paco5_3_0 gf_0 gf_1 gf_2 (upaco5_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco5_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco5_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <5= paco5_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 6 paco_revert; paco_cofix_auto). Qed.

Theorem paco5_3_1_mult_strong: forall r_0 r_1 r_2,
  paco5_3_1 gf_0 gf_1 gf_2 (upaco5_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco5_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco5_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <5= paco5_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 6 paco_revert; paco_cofix_auto). Qed.

Theorem paco5_3_2_mult_strong: forall r_0 r_1 r_2,
  paco5_3_2 gf_0 gf_1 gf_2 (upaco5_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco5_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco5_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <5= paco5_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 6 paco_revert; paco_cofix_auto). Qed.

Corollary paco5_3_0_mult: forall r_0 r_1 r_2,
  paco5_3_0 gf_0 gf_1 gf_2 (paco5_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco5_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco5_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <5= paco5_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco5_3_0_mult_strong, paco5_3_0_mon; eauto. Qed.

Corollary paco5_3_1_mult: forall r_0 r_1 r_2,
  paco5_3_1 gf_0 gf_1 gf_2 (paco5_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco5_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco5_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <5= paco5_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco5_3_1_mult_strong, paco5_3_1_mon; eauto. Qed.

Corollary paco5_3_2_mult: forall r_0 r_1 r_2,
  paco5_3_2 gf_0 gf_1 gf_2 (paco5_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco5_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco5_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <5= paco5_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco5_3_2_mult_strong, paco5_3_2_mon; eauto. Qed.

Theorem paco5_3_0_fold: forall r_0 r_1 r_2,
  gf_0 (upaco5_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco5_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco5_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <5= paco5_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco5_3_1_fold: forall r_0 r_1 r_2,
  gf_1 (upaco5_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco5_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco5_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <5= paco5_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco5_3_2_fold: forall r_0 r_1 r_2,
  gf_2 (upaco5_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco5_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco5_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <5= paco5_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco5_3_0_unfold: forall (MON: monotone5_3 gf_0) (MON: monotone5_3 gf_1) (MON: monotone5_3 gf_2) r_0 r_1 r_2,
  paco5_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 <5= gf_0 (upaco5_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco5_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco5_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2).
Proof. unfold monotone5_3; intros; destruct PR; eauto. Qed.

Theorem paco5_3_1_unfold: forall (MON: monotone5_3 gf_0) (MON: monotone5_3 gf_1) (MON: monotone5_3 gf_2) r_0 r_1 r_2,
  paco5_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 <5= gf_1 (upaco5_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco5_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco5_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2).
Proof. unfold monotone5_3; intros; destruct PR; eauto. Qed.

Theorem paco5_3_2_unfold: forall (MON: monotone5_3 gf_0) (MON: monotone5_3 gf_1) (MON: monotone5_3 gf_2) r_0 r_1 r_2,
  paco5_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 <5= gf_2 (upaco5_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco5_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco5_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2).
Proof. unfold monotone5_3; intros; destruct PR; eauto. Qed.

End Arg5_3.

Hint Unfold monotone5_3.
Hint Resolve paco5_3_0_fold.
Hint Resolve paco5_3_1_fold.
Hint Resolve paco5_3_2_fold.

Implicit Arguments paco5_3_0_acc            [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_3_1_acc            [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_3_2_acc            [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_3_0_mon            [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_3_1_mon            [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_3_2_mon            [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_3_0_mult_strong    [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_3_1_mult_strong    [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_3_2_mult_strong    [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_3_0_mult           [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_3_1_mult           [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_3_2_mult           [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_3_0_fold           [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_3_1_fold           [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_3_2_fold           [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_3_0_unfold         [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_3_1_unfold         [ T0 T1 T2 T3 T4 ].
Implicit Arguments paco5_3_2_unfold         [ T0 T1 T2 T3 T4 ].

Instance paco5_3_0_inst  T0 T1 T2 T3 T4 (gf_0 gf_1 gf_2 : rel5 T0 T1 T2 T3 T4->_) r_0 r_1 r_2 x0 x1 x2 x3 x4 : paco_class (paco5_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2 x3 x4) :=
{ pacoacc    := paco5_3_0_acc gf_0 gf_1 gf_2;
  pacomult   := paco5_3_0_mult gf_0 gf_1 gf_2;
  pacofold   := paco5_3_0_fold gf_0 gf_1 gf_2;
  pacounfold := paco5_3_0_unfold gf_0 gf_1 gf_2 }.

Instance paco5_3_1_inst  T0 T1 T2 T3 T4 (gf_0 gf_1 gf_2 : rel5 T0 T1 T2 T3 T4->_) r_0 r_1 r_2 x0 x1 x2 x3 x4 : paco_class (paco5_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2 x3 x4) :=
{ pacoacc    := paco5_3_1_acc gf_0 gf_1 gf_2;
  pacomult   := paco5_3_1_mult gf_0 gf_1 gf_2;
  pacofold   := paco5_3_1_fold gf_0 gf_1 gf_2;
  pacounfold := paco5_3_1_unfold gf_0 gf_1 gf_2 }.

Instance paco5_3_2_inst  T0 T1 T2 T3 T4 (gf_0 gf_1 gf_2 : rel5 T0 T1 T2 T3 T4->_) r_0 r_1 r_2 x0 x1 x2 x3 x4 : paco_class (paco5_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2 x3 x4) :=
{ pacoacc    := paco5_3_2_acc gf_0 gf_1 gf_2;
  pacomult   := paco5_3_2_mult gf_0 gf_1 gf_2;
  pacofold   := paco5_3_2_fold gf_0 gf_1 gf_2;
  pacounfold := paco5_3_2_unfold gf_0 gf_1 gf_2 }.


Require Import Raft.
Require Import RaftRefinementInterface.

Section AllEntriesLeaderLogs.

  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition leader_without_missing_entry net :=
    forall t e h,
      In (t, e) (allEntries (fst (nwState net h))) ->
      In e (log (snd (nwState  net h))) \/
      exists t' log' leader,
        t' > t /\
        In (t', log') (leaderLogs (fst (nwState net leader))) /\
        ~ In e log'.

  Definition appendEntriesRequest_exists_leaderLog net :=
    forall p t leaderId prevLogIndex prevLogTerm entries leaderCommit,
      In p (nwPackets net) ->
      pBody p = AppendEntries t leaderId prevLogIndex prevLogTerm
                              entries leaderCommit ->
      exists log,
        In (t, log) (leaderLogs (fst (nwState net (pSrc p)))).

  Definition appendEntriesRequest_leaderLog_not_in net :=
    forall p t leaderId prevLogIndex prevLogTerm entries leaderCommit log e,
      In p (nwPackets net) ->
      pBody p = AppendEntries t leaderId prevLogIndex prevLogTerm
                              entries leaderCommit ->
      eIndex e > prevLogIndex ->
      ~ In e entries ->
      In (t, log) (leaderLogs (fst (nwState net (pSrc p)))) ->
      ~ In e log.

  Definition leaderLogs_leader net :=
    forall h,
      type (snd (nwState net h)) = Leader ->
      exists log' es,
        In (currentTerm (snd (nwState net h)), log') (leaderLogs (fst (nwState net h))) /\
        log (snd (nwState net h)) = es ++ log'.

  Definition all_entries_leader_logs net :=
    leader_without_missing_entry net /\ appendEntriesRequest_exists_leaderLog net /\
    appendEntriesRequest_leaderLog_not_in net /\
    leaderLogs_leader net.

  Class all_entries_leader_logs_interface : Prop :=
    {
      all_entries_leader_logs_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          all_entries_leader_logs net
    }.
End AllEntriesLeaderLogs.


Require Import CertiGraph.lib.Ensembles_ext.
Require Import Coq.Lists.List.
Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.
Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.EquivDec_ext.
Require Import CertiGraph.msl_ext.log_normalize.
Require Import CertiGraph.msl_ext.iter_sepcon.
Require Import CertiGraph.msl_ext.seplog.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.path_lemmas.
Require Import CertiGraph.graph.reachable_computable.
Require Import CertiGraph.graph.reachable_ind.
Require Import CertiGraph.graph.subgraph2.
Require Import CertiGraph.graph.graph_gen.
Require Export CertiGraph.graph.BiGraph.
Require Export CertiGraph.graph.MathGraph.
Require Export CertiGraph.graph.FiniteGraph.
Require Import CertiGraph.msl_application.Graph.
Require Import Coq.Logic.Classical.
Import OconNotation.

Local Open Scope logic.

Inductive LR :=
  | L
  | R.

Class pPointwiseGraph_Graph_Bi: Type := {
  addr: Type;
  null: addr;
  SGBA: PointwiseGraphBasicAssum addr (addr * LR)
}.

Existing Instance SGBA.

Definition is_null_SGBA {pSGGB: pPointwiseGraph_Graph_Bi} : DecidablePred addr := (existT (fun P => forall a, {P a} + {~ P a}) (fun x => x = null) (fun x => SGBA_VE x null)).

Class sPointwiseGraph_Graph_Bi {pSGG_Bi: pPointwiseGraph_Graph_Bi} (DV DE: Type): Type := {
  pred: Type;
  SGP: PointwiseGraphPred addr (addr * LR) (DV * addr * addr) unit pred;
  SGA: PointwiseGraphAssum SGP;
  SGAvs: PointwiseGraphAssum_vs SGP;
  SGAvn: PointwiseGraphAssum_vn SGP null
}.

Existing Instances SGP SGA SGAvs.

Section GRAPH_BI.

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

Pure Facts Part

*********************************************************)

Context {pSGG_Bi: pPointwiseGraph_Graph_Bi}.
Context {DV DE DG: Type}.

Class BiMaFin (g: PreGraph addr (addr * LR)) := {
  bi: BiGraph g (fun x => (x, L)) (fun x => (x, R));
  ma: MathGraph g is_null_SGBA;
  fin: FiniteGraph g
}.

Class BiMaFin' (g: PreGraph addr (addr * LR)) := {
  bi': BiGraph g (fun x => (x, L)) (fun x => (x, R));
  ma': MathGraph' g is_null_SGBA;
  fin': FiniteGraph g
}.

Definition Graph := (GeneralGraph addr (addr * LR) DV DE DG (fun g => BiMaFin (pg_lg g))).
Definition Graph' := (GeneralGraph addr (addr * LR) DV DE DG (fun g => BiMaFin' (pg_lg g))).
Definition LGraph := (LabeledGraph addr (addr * LR) DV DE DG).
Definition SGraph := (PointwiseGraph addr (addr * LR) (DV * addr * addr) unit).

Instance SGC_Bi: PointwiseGraphConstructor addr (addr * LR) DV DE DG (DV * addr * addr) unit.
Proof.
  refine (Build_PointwiseGraphConstructor _ _ _ _ _ _ _ SGBA _ _).
  + exact (fun G v => (vlabel G v, dst (pg_lg G) (v, L), dst (pg_lg G) (v, R))).
  + exact (fun _ _ => tt).
Defined.

Instance L_SGC_Bi: Local_PointwiseGraphConstructor addr (addr * LR) DV DE DG (DV * addr * addr) unit.
Proof.
  refine (Build_Local_PointwiseGraphConstructor _ _ _ _ _ _ _ SGBA SGC_Bi
    (fun G v => evalid (pg_lg G) (v, L) /\ evalid (pg_lg G) (v, R) /\
                src (pg_lg G) (v, L) = v /\ src (pg_lg G) (v, R) = v) _
    (fun _ _ => True) _).
  + intros.
    simpl.
    destruct H as [? [? [? ?]]], H0 as [? [? [? ?]]].
    f_equal; [f_equal |]; auto.
  + intros; simpl.
    auto.
Defined.

Global Existing Instances SGC_Bi L_SGC_Bi.

Definition Graph_LGraph (G: Graph): LGraph := lg_gg G.
Definition Graph'_LGraph (G: Graph'): LGraph := lg_gg G.
Definition LGraph_SGraph (G: LGraph): SGraph := Graph_PointwiseGraph G.

Local Coercion Graph_LGraph: Graph >-> LGraph.
Local Coercion Graph'_LGraph: Graph' >-> LGraph.
Local Coercion LGraph_SGraph: LGraph >-> SGraph.
Local Identity Coercion Graph_GeneralGraph: Graph >-> GeneralGraph.
Local Identity Coercion Graph'_GeneralGraph: Graph' >-> GeneralGraph.
Local Identity Coercion LGraph_LabeledGraph: LGraph >-> LabeledGraph.
Local Identity Coercion SGraph_PointwiseGraph: SGraph >-> PointwiseGraph.
Local Coercion pg_lg: LabeledGraph >-> PreGraph.

Instance biGraph (G: Graph): BiGraph G (fun x => (x, L)) (fun x => (x, R)) :=
  @bi G (@sound_gg _ _ _ _ _ _ _ _ G).

Instance biGraph' (G: Graph'): BiGraph G (fun x => (x, L)) (fun x => (x, R)) :=
  @bi' G (@sound_gg _ _ _ _ _ _ _ _ G).

Instance maGraph(G: Graph): MathGraph G is_null_SGBA :=
  @ma G (@sound_gg _ _ _ _ _ _ _ _ G).

Instance maGraph'(G: Graph'): MathGraph' G is_null_SGBA :=
  @ma' G (@sound_gg _ _ _ _ _ _ _ _ G).

Instance finGraph (G: Graph): FiniteGraph G :=
  @fin G (@sound_gg _ _ _ _ _ _ _ _ G).

Instance finGraph' (G: Graph'): FiniteGraph G :=
  @fin' G (@sound_gg _ _ _ _ _ _ _ _ G).

Instance RGF (G: Graph): ReachableFiniteGraph G.
  apply Build_ReachableFiniteGraph.
  intros.
  apply finite_reachable_computable with (is_null := is_null_SGBA) in H.
  + destruct H as [l [? ?]].
    exists l; auto.
  + apply maGraph.
  + apply (LocalFiniteGraph_FiniteGraph G), finGraph.
  + apply (FiniteGraph_EnumCovered G), finGraph.
Defined.

Definition Graph_vgen (G: Graph) (x: addr) (d: DV) : Graph :=
  generalgraph_vgen G x d (sound_gg G).

Definition Graph_egen (G: Graph) (e: addr * LR) (d: DE) : Graph :=
  generalgraph_egen G e d (sound_gg G).

Definition empty_BiGraph: BiGraph (empty_pregraph (fun e => fst e) (fun e => null)) (fun x => (x, L)) (fun x => (x, R)).
  constructor.
  + intros ? [].
  + intros ? ? [].
Defined.

Definition empty_MathGraph: MathGraph (empty_pregraph (fun e => fst e) (fun e => null)) is_null_SGBA.
  apply (Build_MathGraph _ is_null_SGBA).
  + intros ? [].
  + intros ? [].
Defined.

Definition empty_MathGraph': MathGraph' (empty_pregraph (fun e => fst e) (fun e => null)) is_null_SGBA.
  apply (Build_MathGraph' _ is_null_SGBA).
  + intros ? [].
  + intros ? [].
Defined.

Definition empty_FiniteGraph: FiniteGraph (empty_pregraph (fun e => fst e) (fun e => null)).
  constructor.
  + exists nil.
    split; [constructor | intros].
    simpl.
    unfold Ensembles.In; reflexivity.
  + exists nil.
    split; [constructor | intros].
    simpl.
    unfold Ensembles.In; reflexivity.
Defined.

Definition empty_sound: BiMaFin (empty_pregraph (fun e => fst e) (fun e => null)) :=
  Build_BiMaFin _ empty_BiGraph empty_MathGraph empty_FiniteGraph.

Definition empty_sound': BiMaFin' (empty_pregraph (fun e => fst e) (fun e => null)) :=
  Build_BiMaFin' _ empty_BiGraph empty_MathGraph' empty_FiniteGraph.

Definition empty_Graph (default_v: DV) (default_e: DE) (default_g : DG) : Graph :=
  Build_GeneralGraph _ _ _ _ (empty_labeledgraph (fun e => fst e) (fun e => null) default_v default_e default_g) empty_sound.

Definition empty_Graph' (default_v: DV) (default_e: DE) (default_g : DG) : Graph' :=
  Build_GeneralGraph _ _ _ _ (empty_labeledgraph (fun e => fst e) (fun e => null) default_v default_e default_g) empty_sound'.

Definition is_BiMaFin (g: LGraph): Prop := exists X: BiMaFin (pg_lg g), True.

Definition is_BiMaFin' (g: LGraph): Prop := exists X: BiMaFin' (pg_lg g), True.

Definition is_guarded_BiMaFin (PV: addr -> Prop) (PE: addr * LR -> Prop) (g: LGraph): Prop := is_BiMaFin (gpredicate_sub_labeledgraph PV PE g).

Definition is_guarded_BiMaFin' (PV: addr -> Prop) (PE: addr * LR -> Prop) (g: LGraph): Prop := is_BiMaFin' (gpredicate_sub_labeledgraph PV PE g).

Definition left_right_sound: forall (g: Graph) (x: addr) lr,
  vvalid g x ->
  src g (x, lr) = x.
Proof.
  intros.
  destruct lr.
  + apply (@left_sound _ _ _ _ _ _ g (biGraph _) x); auto.
  + apply (@right_sound _ _ _ _ _ _ g (biGraph _) x); auto.
Qed.

Definition left_right_sound0: forall (g: Graph) (x: addr) lr,
  evalid g (x, lr) ->
  src g (x, lr) = x.
Proof.
  intros.
  destruct lr.
  + destruct (@valid_graph _ _ _ _ g _ (maGraph _) (x, L) H) as [? _].
    pose proof (@only_two_edges _ _ _ _ g _ _ (biGraph _) _ (x, L) H0).
    simpl in H1.
    destruct H1 as [? _].
    specialize (H1 (conj eq_refl H)).
    destruct H1; inversion H1.
    rewrite <- ! H3; auto.
  + destruct (@valid_graph _ _ _ _ g _ (maGraph _) (x, R) H) as [? _].
    pose proof (@only_two_edges _ _ _ _ g _ _ (biGraph _) _ (x, R) H0).
    simpl in H1.
    destruct H1 as [? _].
    specialize (H1 (conj eq_refl H)).
    destruct H1; inversion H1.
    rewrite <- ! H3; auto.
Qed.

Definition left_right_sound': forall (g: Graph') (x: addr) lr,
  vvalid g x ->
  src g (x, lr) = x.
Proof.
  intros.
  destruct lr.
  + apply (@left_sound _ _ _ _ _ _ g (biGraph' _) x); auto.
  + apply (@right_sound _ _ _ _ _ _ g (biGraph' _) x); auto.
Qed.

Definition left_right_sound0': forall (g: Graph') (x: addr) lr,
  evalid g (x, lr) ->
  src g (x, lr) = x.
Proof.
  intros.
  destruct lr.
  + pose proof @valid_graph' _ _ _ _ g _ (maGraph' _) (x, L) H.
    pose proof (@only_two_edges _ _ _ _ g _ _ (biGraph' _) _ (x, L) H0).
    simpl in H1.
    destruct H1 as [? _].
    specialize (H1 (conj eq_refl H)).
    destruct H1; inversion H1.
    rewrite <- ! H3; auto.
  + pose proof @valid_graph' _ _ _ _ g _ (maGraph' _) (x, R) H.
    pose proof (@only_two_edges _ _ _ _ g _ _ (biGraph' _) _ (x, R) H0).
    simpl in H1.
    destruct H1 as [? _].
    specialize (H1 (conj eq_refl H)).
    destruct H1; inversion H1.
    rewrite <- ! H3; auto.
Qed.

Lemma weak_valid_vvalid_dec: forall (g : Graph) (x: addr),
  weak_valid g x -> Decidable (vvalid g x).
Proof.
  intros.
  apply null_or_valid in H.
  destruct H; [right | left]; auto.
  pose proof valid_not_null g x; tauto.
Qed.
Hint Resolve weak_valid_vvalid_dec : GraphDec.

Lemma invalid_null: forall (g: Graph), ~ vvalid g null.
Proof.
  intros.
  pose proof @valid_not_null _ _ _ _ g _ (maGraph g) null.
  cbv beta delta [is_null_SGBA] in H; simpl in H.
  tauto.
Qed.

Lemma vvalid_vguard: forall (g: Graph) x,
  vvalid g x ->
  vguard g x.
Proof.
  intros.
  pose proof biGraph g.
  simpl.
  split; [| split; [| split]].
  + apply left_valid with (x0 := x) in H0; auto.
  + apply right_valid with (x0 := x) in H0; auto.
  + pose proof (proj2 (only_two_edges x (x, L) H)).
    specialize (H1 (or_introl eq_refl)).
    tauto.
  + pose proof (proj2 (only_two_edges x (x, R) H)).
    specialize (H1 (or_intror eq_refl)).
    tauto.
Qed.

Lemma vvalid_vguard': forall (g: Graph') x,
  vvalid g x ->
  vguard g x.
Proof.
  intros.
  pose proof biGraph' g.
  simpl.
  split; [| split; [| split]].
  + apply left_valid with (x0 := x) in H0; auto.
  + apply right_valid with (x0 := x) in H0; auto.
  + pose proof (proj2 (only_two_edges x (x, L) H)).
    specialize (H1 (or_introl eq_refl)).
    tauto.
  + pose proof (proj2 (only_two_edges x (x, R) H)).
    specialize (H1 (or_intror eq_refl)).
    tauto.
Qed.

Definition Graph_gen_left_null (G : Graph) (x : addr) : Graph.
Proof.
  refine (generalgraph_gen_dst G (x, L) null _).
  assert (weak_valid G null) by (left; reflexivity).
  refine (Build_BiMaFin _ (gen_dst_preserve_bi G (x, L) null _)
                        (gen_dst_preserve_math G (x, L) null ma H)
                        (gen_dst_preserve_finite G (x, L) null (finGraph G))).
Defined.

Definition Graph_gen_right_null (G : Graph) (x : addr) : Graph.
Proof.
  refine (generalgraph_gen_dst G (x, R) null _).
  assert (weak_valid G null) by (left; reflexivity).
  refine (Build_BiMaFin _ (gen_dst_preserve_bi G (x, R) null _)
                        (gen_dst_preserve_math G (x, R) null ma H)
                        (gen_dst_preserve_finite G (x, R) null (finGraph G))).
Defined.

Ltac s_rewrite p :=
  let H := fresh "H" in
  pose proof p as H;
  simpl in H;
  rewrite H;
  clear H.

Lemma Graph_vgen_vgamma: forall (G: Graph) (x: addr) (d d': DV) l r,
  vgamma G x = (d, l, r) ->
  vgamma (Graph_vgen G x d') x = (d', l, r).
Proof.
  intros.
  simpl in H |- *.
  inversion H; subst.
  f_equal.
  f_equal.
  unfold update_vlabel.
  destruct_eq_dec x x; [| congruence].
  auto.
Qed.

(*
Lemma Graph_gen_spatial_spec: forall (G: Graph) (x: addr) (d d': DV) l r,
  vgamma G x = (d, l, r) ->
  (Graph_gen G x d') -=- (spatialgraph_vgen G x (d', l, r)).
Proof.
  intros.
  split; [reflexivity | split; [| auto]].
  simpl in *; intros.
  simpl in *; unfold update_vlabel.
  destruct_eq_dec x v; subst.
  + inversion H; subst; f_equal; f_equal.
  + auto.
Qed.

(* TODO: This lemma is not true. They are not even structural identical.
   But we should change the definition of validly identical or some how fix this. *)
Lemma Graph_gen_left_null_spatial_spec: forall (G: Graph) (x: addr) (d : DV) l r,
    vgamma G x = (d, l, r) ->
    (Graph_gen_left_null G x) -=- (spatialgraph_vgen G x (d, null, r)).
Proof.
  intros.
  split; [|split; [| auto]].
  + split; [|split; [|split]]; intros; simpl; intuition.
    unfold Graph_gen_left_null in H0. simpl in H0. unfold spatialgraph_vgen in H1. simpl in H1.
  + intros. simpl. unfold Graph_gen_left_null. unfold generalgraph_gen_dst. simpl.
    unfold update_dst. destruct_eq_dec (x, L) (v, L).
    - destruct_eq_dec (x, L) (v, R). inversion H3. inversion H2. destruct_eq_dec v v. 2: exfalso; auto.
      simpl in H. inversion H; subst; auto.
    - destruct_eq_dec (x, L) (v, R). inversion H3. destruct_eq_dec x v.
      * subst. exfalso; auto.
      * auto.
Qed.
*)

Lemma weak_valid_si: forall (g1 g2: Graph) n, g1 ~=~ g2 -> (weak_valid g1 n <-> weak_valid g2 n).
Proof.
  intros.
  unfold weak_valid.
  destruct H as [? _].
  rewrite H.
  reflexivity.
Qed.

Lemma gamma_step: forall (g : Graph) x (d: DV) (l r: addr), vvalid g x -> vgamma g x = (d, l, r) -> forall y, step g x y <-> y = l \/ y = r.
Proof.
  intros. simpl in H0; inversion H0; subst.
  rewrite step_spec; split; intros.
  + destruct H1 as [e [? [? ?]]].
    pose proof (only_two_edges x e H).
    cbv beta in H4.
    pose proof (proj1 H4 (conj H2 H1)).
    destruct H5; subst e; auto.
  + destruct H1.
    - exists (x, L).
      s_rewrite (left_sound g); auto.
      apply (left_valid g) in H.
      auto.
    - exists (x, R).
      s_rewrite (right_sound g); auto.
      apply (right_valid g) in H.
      auto.
Qed.

Lemma gamma_left_weak_valid: forall (g : Graph) x d l r, vvalid g x -> vgamma g x = (d, l, r) -> weak_valid g l.
Proof.
  intros.
  simpl in H0.
  inversion H0.
  pose proof valid_graph g (x, L).
  spec H1; [pose proof (left_valid g); auto |].
  tauto.
Qed.
Hint Resolve gamma_left_weak_valid : GraphDec.

Lemma gamma_right_weak_valid: forall (g : Graph) x d l r, vvalid g x -> vgamma g x = (d, l, r) -> weak_valid g r.
Proof.
  intros.
  simpl in H0.
  inversion H0.
  pose proof valid_graph g (x, R).
  spec H1; [pose proof (right_valid g); auto |].
  tauto.
Qed.
Hint Resolve gamma_right_weak_valid : GraphDec.

Lemma gamma_step_list: forall (g : Graph) x d l r, vvalid g x -> vgamma g x = (d, l, r) -> step_list g x (l :: r :: nil).
Proof.
  intros.
  unfold step_list.
  intros y.
  rewrite gamma_step by eauto.
  simpl.
  pose proof (@eq_sym _ l y).
  pose proof (@eq_sym _ r y).
  pose proof (@eq_sym _ y l).
  pose proof (@eq_sym _ y r).
  tauto.
Qed.

Lemma gamma_step_list': forall (g : Graph) x d l r, vvalid g x -> vgamma g x = (d, l, r) -> step_list g x (r :: l :: nil).
Proof.
  intros.
  unfold step_list.
  intros y.
  rewrite gamma_step by eauto.
  simpl.
  pose proof (@eq_sym _ l y).
  pose proof (@eq_sym _ r y).
  pose proof (@eq_sym _ y l).
  pose proof (@eq_sym _ y r).
  tauto.
Qed.

Lemma Graph_reachable_dec: forall (G: Graph) x,
    Decidable (vvalid G x) -> forall y, Decidable (reachable G x y).
Proof.
  intros.
  apply reachable_decidable with (is_null := is_null_SGBA); auto.
  + apply maGraph.
  + apply LocalFiniteGraph_FiniteGraph, finGraph.
  + apply FiniteGraph_EnumCovered, finGraph.
Qed.
Hint Resolve Graph_reachable_dec : GraphDec.

Lemma Graph_reachable_by_dec: forall (G: Graph) x (P: NodePred addr),
    Decidable (vvalid G x) -> ReachDecidable G x P.
Proof.
  intros.
  intro y.
  apply reachable_by_decidable with (is_null := is_null_SGBA); auto.
  + apply maGraph.
  + apply LocalFiniteGraph_FiniteGraph, finGraph.
  + apply FiniteGraph_EnumCovered, finGraph.
Qed.
(*
Lemma Graph_partialgraph_vi_spec: forall (G G': Graph) (P P': addr -> Prop),
  (predicate_partialgraph G P) ~=~ (predicate_partialgraph G' P') ->
  (forall v, vvalid G v -> P v -> vvalid G' v -> P' v -> vlabel G v = vlabel G' v) ->
  (predicate_partial_spatialgraph G P) -=- (predicate_partial_spatialgraph G' P').
Proof.
  intros.
  split; [auto |].
  split; [| intros; simpl; auto].
  simpl; unfold predicate_vvalid.
  intros.
  f_equal; [f_equal |].
  + apply H0; tauto.
  + destruct H as [_ [_ [_ ?]]].
    generalize (left_sound G v); intro.
    generalize (left_sound G' v); intro.
    apply H; simpl; unfold predicate_weak_evalid.
    - destruct H1. apply (left_valid G) in H1. change (pg_lg G) with (G: PGraph). rewrite H3. auto.
    - destruct H2. apply (left_valid G') in H2. change (pg_lg G') with (G': PGraph). rewrite H4. auto.
  + destruct H as [_ [_ [_ ?]]].
    generalize (right_sound G v); intro.
    generalize (right_sound G' v); intro.
    apply H; simpl; unfold predicate_weak_evalid.
    - destruct H1. apply (right_valid G) in H1. change (pg_lg G) with (G: PGraph). rewrite H3. auto.
    - destruct H2. apply (right_valid G') in H2. change (pg_lg G') with (G': PGraph). rewrite H4. auto.
Qed.
*)
Lemma gamma_left_reachable_included: forall (g: Graph) x d l r,
                                       vvalid g x -> vgamma g x = (d, l, r) -> Included (reachable g l) (reachable g x).
Proof.
  intros. intro y; intros. apply edge_reachable_by with l; auto. split; auto. split.
  + apply reachable_head_valid in H1; auto.
  + rewrite (gamma_step _ _ _ _ _ H H0). auto.
Qed.

Lemma gamma_right_reachable_included: forall (g: Graph) x d l r,
                                        vvalid g x -> vgamma g x = (d, l, r) -> Included (reachable g r) (reachable g x).
Proof.
  intros. intro y; intros. apply edge_reachable_by with r; auto. split; auto. split.
  + apply reachable_head_valid in H1; auto.
  + rewrite (gamma_step _ _ _ _ _ H H0). auto.
Qed.

Lemma Prop_join_reachable_left: forall (g: Graph) x d l r,
  vvalid g x ->
  vgamma g x = (d, l, r) ->
  Prop_join
    (reachable g l)
    (Intersection _ (reachable g x) (Complement addr (reachable g l)))
    (reachable g x).
Proof.
  intros.
  apply Ensemble_join_Intersection_Complement.
  - eapply gamma_left_reachable_included; eauto.
  - intros.
    apply gamma_left_weak_valid in H0; [| auto].
    apply decidable_prop_decidable, Graph_reachable_dec, weak_valid_vvalid_dec; auto.
Qed.

Lemma Prop_join_reachable_right: forall (g: Graph) x d l r,
  vvalid g x ->
  vgamma g x = (d, l, r) ->
  Prop_join
    (reachable g r)
    (Intersection _ (reachable g x) (Complement addr (reachable g r)))
    (reachable g x).
Proof.
  intros.
  apply Ensemble_join_Intersection_Complement.
  - eapply gamma_right_reachable_included; eauto.
  - intros.
    apply gamma_right_weak_valid in H0; [| auto].
    apply decidable_prop_decidable, Graph_reachable_dec, weak_valid_vvalid_dec; auto.
Qed.

Lemma dst_L_eq: forall (g1 g2: Graph) x,
  vvalid g1 x ->
  g1 ~=~ g2 ->
  dst g1 (x, L) = dst g2 (x, L).
Proof.
  intros.
  destruct H0 as [? [? [? ?]]].
  assert (vvalid g2 x) by (clear - H H0; firstorder).
  apply H3.
  + eapply left_valid in H; [| apply biGraph].
    auto.
  + eapply left_valid in H4; [| apply biGraph].
    auto.
Qed.

Lemma dst_R_eq: forall (g1 g2: Graph) x,
  vvalid g1 x ->
  g1 ~=~ g2 ->
  dst g1 (x, R) = dst g2 (x, R).
Proof.
  intros.
  destruct H0 as [? [? [? ?]]].
  assert (vvalid g2 x) by (clear - H H0; firstorder).
  apply H3.
  + eapply right_valid in H; [| apply biGraph].
    auto.
  + eapply right_valid in H4; [| apply biGraph].
    auto.
Qed.

Instance BiMaFin_Normal: NormalGeneralGraph (fun g: LGraph => BiMaFin g).
Proof.
  constructor.
  + intros.
    destruct X as [?H ?H ?H].
    apply (bi_graph_si _ _ (proj1 H)) in H0.
    apply (math_graph_si _ _ (proj1 H)) in H1.
    apply (finite_graph_si _ _ (proj1 H)) in H2.
    constructor; auto.
  + intros.
    destruct X as [?H ?H ?H].
    destruct X0 as [?H ?H ?H].
    constructor.
    - eapply bi_graph_join; eauto.
    - eapply math_graph_join; eauto.
    - eapply finite_graph_join; eauto.
Qed.

Instance BiMaFin'_Normal: NormalGeneralGraph (fun g: LGraph => BiMaFin' g).
Proof.
  constructor.
  + intros.
    destruct X as [?H ?H ?H].
    apply (bi_graph_si _ _ (proj1 H)) in H0.
    apply (math_graph_si' _ _ (proj1 H)) in H1.
    apply (finite_graph_si _ _ (proj1 H)) in H2.
    constructor; auto.
  + intros.
    destruct X as [?H ?H ?H].
    destruct X0 as [?H ?H ?H].
    constructor.
    - eapply bi_graph_join'; eauto.
    - eapply math_graph_join'; eauto.
    - eapply finite_graph_join; eauto.
Qed.

Lemma Graph_is_BiMaFin: forall (g: Graph), is_BiMaFin g.
Proof.
  intros.
  destruct g.
  exists sound_gg; auto.
Qed.

Lemma Graph'_is_BiMaFin': forall (g: Graph'), is_BiMaFin' g.
Proof.
  intros.
  destruct g.
  exists sound_gg; auto.
Qed.

Lemma single_vertex_guarded_BiMaFin: forall (x0: addr) dv de dg,
  is_guarded_BiMaFin (fun v : addr => x0 <> v) (fun _ : addr * LR => ~ False)
    (single_vertex_labeledgraph x0 dv de dg).
Proof.
  intros.
  constructor; auto.
  simpl.
  constructor.
  + constructor; simpl; intros.
    - congruence.
    - rewrite Intersection_spec in H; destruct H; congruence.
  + constructor; simpl; intros.
    - rewrite Intersection_spec in H; destruct H; tauto.
    - rewrite Intersection_spec in H; destruct H; congruence.
  + constructor; exists nil; repeat constructor.
    - inversion H.
    - inversion H.
    - simpl; intros.
      unfold Ensembles.In in H; rewrite Intersection_spec in H; destruct H; congruence.
    - inversion H.
    - inversion H.
    - simpl; intros.
      unfold Ensembles.In in H; rewrite Intersection_spec in H; destruct H; congruence.
Qed.

Lemma single_vertex_guarded_BiMaFin': forall (x0: addr) dv de dg,
  is_guarded_BiMaFin' (fun v : addr => x0 <> v) (fun _ : addr * LR => ~ False)
    (single_vertex_labeledgraph x0 dv de dg).
Proof.
  intros.
  constructor; auto.
  simpl.
  constructor.
  + constructor; simpl; intros.
    - congruence.
    - rewrite Intersection_spec in H; destruct H; congruence.
  + constructor; simpl; intros.
    - rewrite Intersection_spec in H; destruct H; tauto.
    - rewrite Intersection_spec in H; destruct H; congruence.
  + constructor; exists nil; repeat constructor.
    - inversion H.
    - inversion H.
    - simpl; intros.
      unfold Ensembles.In in H; rewrite Intersection_spec in H; destruct H; congruence.
    - inversion H.
    - inversion H.
    - simpl; intros.
      unfold Ensembles.In in H; rewrite Intersection_spec in H; destruct H; congruence.
Qed.

Lemma is_BiMaFin_si: forall (g1 g2: LGraph),
  g1 ~=~ g2 ->
  is_BiMaFin g1 ->
  is_BiMaFin g2.
Proof.
  intros.
  destruct H0 as [[?H ?H ?H] _].
  apply (bi_graph_si _ _ H) in H0.
  apply (math_graph_si _ _ H) in H1.
  apply (finite_graph_si _ _ H) in H2.
  constructor; constructor; auto.
Qed.

Lemma is_BiMaFin_si': forall (g1 g2: LGraph),
  g1 ~=~ g2 ->
  is_BiMaFin' g1 ->
  is_BiMaFin' g2.
Proof.
  intros.
  destruct H0 as [[?H ?H ?H] _].
  apply (bi_graph_si _ _ H) in H0.
  apply (math_graph_si' _ _ H) in H1.
  apply (finite_graph_si _ _ H) in H2.
  constructor; constructor; auto.
Qed.

Lemma is_guarded_BiMaFin_labeledgraph_add_edge: forall (g: LGraph) PV PE PE' e s d data_e,
  ~ evalid g e ->
  Same_set PE' (Intersection _ PE (fun e0 => e0 <> e)) ->
  is_guarded_BiMaFin PV PE g ->
  is_guarded_BiMaFin PV PE' (labeledgraph_add_edge g e s d data_e).
Proof.
  unfold is_guarded_BiMaFin.
  intros.
  eapply is_BiMaFin_si; [| eassumption].
  simpl.
  rewrite Same_set_spec in H0.
  split; [| split; [| split]].
  + intros; simpl; reflexivity.
  + intros; simpl.
    specialize (H0 e0).
    rewrite !Intersection_spec in *.
    unfold addValidFunc.
    rewrite H0.
    destruct_eq_dec e0 e; [subst |]; try tauto.
  + simpl; intros.
    unfold updateEdgeFunc.
    destruct_eq_dec e e0; auto; subst.
    specialize (H0 e0).
    rewrite Intersection_spec in *.
    destruct H3.
    tauto.
  + simpl; intros.
    unfold updateEdgeFunc.
    destruct_eq_dec e e0; auto; subst.
    specialize (H0 e0).
    rewrite Intersection_spec in *.
    destruct H3.
    tauto.
Qed.

Lemma is_guarded_BiMaFin'_labeledgraph_add_edge: forall (g: LGraph) PV PE PE' e s d data_e,
  ~ evalid g e ->
  Same_set PE' (Intersection _ PE (fun e0 => e0 <> e)) ->
  is_guarded_BiMaFin' PV PE g ->
  is_guarded_BiMaFin' PV PE' (labeledgraph_add_edge g e s d data_e).
Proof.
  unfold is_guarded_BiMaFin'.
  intros.
  eapply is_BiMaFin_si'; [| eassumption].
  simpl.
  rewrite Same_set_spec in H0.
  split; [| split; [| split]].
  + intros; simpl; reflexivity.
  + intros; simpl.
    specialize (H0 e0).
    rewrite !Intersection_spec in *.
    unfold addValidFunc.
    rewrite H0.
    destruct_eq_dec e0 e; [subst |]; try tauto.
  + simpl; intros.
    unfold updateEdgeFunc.
    destruct_eq_dec e e0; auto; subst.
    specialize (H0 e0).
    rewrite Intersection_spec in *.
    destruct H3.
    tauto.
  + simpl; intros.
    unfold updateEdgeFunc.
    destruct_eq_dec e e0; auto; subst.
    specialize (H0 e0).
    rewrite Intersection_spec in *.
    destruct H3.
    tauto.
Qed.

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

Spatial Facts Part

*********************************************************)

Context {sSGG_Bi: sPointwiseGraph_Graph_Bi DV DE}.

Lemma va_reachable_dag_unfold: forall (g: Graph) x d l r,
  vvalid g x ->
  vgamma g x = (d, l, r) ->
  reachable_dag_vertices_at x g = vertex_at x (d, l, r) * reachable_through_dag_vertices_at (l :: r :: nil) g.
Proof.
  intros.
  apply va_reachable_dag_unfold; auto.
  eapply gamma_step_list; eauto.
Qed.

Lemma va_reachable_dag_update_unfold: forall (g: Graph) x d l r v,
  vvalid g x ->
  vgamma g x = (d, l, r) ->
  reachable_dag_vertices_at x (Graph_vgen g x v) = vertex_at x (v, l, r) * reachable_through_dag_vertices_at (l :: r :: nil) g.
Proof.
  intros.
  apply va_reachable_dag_update_unfold; auto.
  + eapply gamma_step_list; eauto.
  + eapply Graph_vgen_vgamma; eauto.
  + unfold Included, Ensembles.In; intros.
    apply vvalid_vguard.
    apply reachable_through_set_foot_valid in H1; auto.
  + unfold Included, Ensembles.In; intros.
    apply vvalid_vguard.
    apply reachable_through_set_foot_valid in H1; auto.
Qed.

Lemma va_reachable_root_stable_ramify: forall (g: Graph) (x: addr) (gx: DV * addr * addr),
  vgamma g x = gx ->
  vvalid g x ->
  @derives pred _
    (reachable_vertices_at x g)
    (vertex_at x gx * (vertex_at x gx -* reachable_vertices_at x g)).
Proof. intros; apply va_reachable_root_stable_ramify; auto. Qed.

Lemma va_reachable_root_update_ramify: forall (g: Graph) (x: addr) (lx: DV) (gx gx': DV * addr * addr),
  vvalid g x ->
  vgamma g x = gx ->
  vgamma (Graph_vgen g x lx) x = gx' ->
  @derives pred _
    (reachable_vertices_at x g)
    (vertex_at x gx *
      (vertex_at x gx' -* reachable_vertices_at x (Graph_vgen g x lx))).
Proof.
  intros.
  apply va_reachable_root_update_ramify; auto.
  + unfold Included, Ensembles.In; intros.
    apply vvalid_vguard.
    rewrite Intersection_spec in H2.
    destruct H2 as [? _].
    apply reachable_foot_valid in H2; auto.
  + unfold Included, Ensembles.In; intros.
    apply vvalid_vguard.
    rewrite Intersection_spec in H2.
    destruct H2 as [? _].
    apply reachable_foot_valid in H2; auto.
Qed.

Lemma va_reachable_internal_stable_ramify: forall (g: Graph) (x y: addr) (gy: DV * addr * addr),
  vvalid g y ->
  vgamma g y = gy ->
  reachable g x y ->
  @derives pred _
    (reachable_vertices_at x g)
    (vertex_at y gy *
      (vertex_at y gy -* reachable_vertices_at x g)).
Proof. intros. apply va_reachable_internal_stable_ramify; auto. Qed.

(*
TODO: maybe as a general lemma for normal_general_graph
Lemma is_guarded_BiMaFin_si: forall (g1 g2: LGraph),
*)

Lemma is_BiMaFin_LGraph_Graph: forall (g: LGraph) (P: LGraph -> pred),
  is_BiMaFin g ->
  P g |-- EX g: Graph, P g.
Proof.
  intros.
  destruct H as [X _].
  apply (exp_right (Build_GeneralGraph _ _ _ BiMaFin g X)).
  simpl.
  auto.
Qed.

Lemma va_labeledgraph_add_edge_eq: forall (g: LGraph) es e s d data,
  ~ evalid g e ->
  is_guarded_BiMaFin (fun x => s <> x) (fun e => ~ In e es) g ->
  let g' := labeledgraph_add_edge g e s d data in
  @vertices_at _ _ _ _ _ _ SGP _
   (Intersection _ (vvalid g) (fun x => s <> x)) (Graph_PointwiseGraph g) =
  @vertices_at _ _ _ _ _ _ SGP _
   (Intersection _ (vvalid g') (fun x => s <> x)) (Graph_PointwiseGraph g').
Proof.
  intros.
  apply va_labeledgraph_add_edge_eq; auto.
  + unfold Included, Ensembles.In.
    intros x0 ?.
    destruct H0 as [X _].
    pose (g0 := Build_GeneralGraph _ _ _ (fun g => BiMaFin (pg_lg g)) _ X: Graph).
    assert (vvalid g0 x0) by auto.
    apply vvalid_vguard in H0.
    simpl in H0 |- *.
    rewrite !Intersection_spec in H0.
    tauto.
  + unfold Included, Ensembles.In.
    intros x0 ?.
    destruct H0 as [X _].
    pose (g0 := Build_GeneralGraph _ _ _ (fun g => BiMaFin (pg_lg g)) _ X: Graph).
    assert (vvalid g0 x0) by auto.
    apply vvalid_vguard in H0.
    simpl in H0 |- *.
    rewrite !Intersection_spec in H0.
    unfold addValidFunc, updateEdgeFunc.
    split; [| split]; [tauto | tauto |].
    destruct_eq_dec e (x0, L); subst; [tauto |].
    destruct_eq_dec e (x0, R); subst; [tauto |].
    tauto.
Qed.

Lemma va_labeledgraph_add_edge_eq': forall (g: LGraph) es e s d data,
  ~ evalid g e ->
  is_guarded_BiMaFin' (fun x => s <> x) (fun e => ~ In e es) g ->
  let g' := labeledgraph_add_edge g e s d data in
  @vertices_at _ _ _ _ _ _ SGP _
   (Intersection _ (vvalid g) (fun x => s <> x)) (Graph_PointwiseGraph g) =
  @vertices_at _ _ _ _ _ _ SGP _
   (Intersection _ (vvalid g') (fun x => s <> x)) (Graph_PointwiseGraph g').
Proof.
  intros.
  apply Graph.va_labeledgraph_add_edge_eq; auto.
  + unfold Included, Ensembles.In.
    intros x0 ?.
    destruct H0 as [X _].
    pose (g0 := Build_GeneralGraph _ _ _ (fun g => BiMaFin' (pg_lg g)) _ X: Graph').
    assert (vvalid g0 x0) by auto.
    apply vvalid_vguard' in H0.
    simpl in H0 |- *.
    rewrite !Intersection_spec in H0.
    tauto.
  + unfold Included, Ensembles.In.
    intros x0 ?.
    destruct H0 as [X _].
    pose (g0 := Build_GeneralGraph _ _ _ (fun g => BiMaFin' (pg_lg g)) _ X: Graph').
    assert (vvalid g0 x0) by auto.
    apply vvalid_vguard' in H0.
    simpl in H0 |- *.
    rewrite !Intersection_spec in H0.
    unfold addValidFunc, updateEdgeFunc.
    split; [| split]; [tauto | tauto |].
    destruct_eq_dec e (x0, L); subst; [tauto |].
    destruct_eq_dec e (x0, R); subst; [tauto |].
    tauto.
Qed.

Lemma va_labeledgraph_egen_eq: forall (g: LGraph) e data P,
  @vertices_at _ _ _ _ _ _ SGP _
   P (Graph_PointwiseGraph g) =
  @vertices_at _ _ _ _ _ _ SGP _
   P (Graph_PointwiseGraph (labeledgraph_egen g e data)).
Proof.
  intros.
  apply vertices_at_vertices_identical.
  rewrite vertices_identical_spec; intros.
  simpl; auto.
Qed.

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

Spatial Facts (with Strong Assumption) Part

*********************************************************)

  Context {SGSA: PointwiseGraphStrongAssum SGP}.

  Notation graph x g := (@reachable_vertices_at _ _ _ _ _ _ _ _ (_) _ (@SGP pSGG_Bi DV DE sSGG_Bi) _ x g).

  Lemma bi_graph_unfold: forall (g: Graph) x d l r,
      vvalid g x -> vgamma g x = (d, l, r) ->
      graph x g = vertex_at x (d, l, r) ⊗ graph l g ⊗ graph r g.
  Proof.
    intros. rewrite graph_unfold with (S := (l :: r :: nil)); auto.
    + change (Graph_PointwiseGraph g) with (LGraph_SGraph g).
      rewrite H0. simpl. rewrite ocon_emp. rewrite <- ocon_assoc. auto.
    + apply RGF.
    + intros. apply weak_valid_vvalid_dec. simpl in H1.
      destruct H1; [|destruct H1]; [subst x0 ..|exfalso; auto].
      - apply (gamma_left_weak_valid _ x d l r); auto.
      - apply (gamma_right_weak_valid _ x d l r); auto.
    + apply (gamma_step_list _ _ d l r); auto.
  Qed.

  Lemma bi_graph_precise_left: forall (g: Graph) x l,
      vvalid g x -> dst g (x, L) = l -> precise (graph l g).
  Proof.
    intros. apply precise_graph. 1: apply RGF.
    apply weak_valid_vvalid_dec.
    pose proof (left_valid g x H). simpl in H1.
    destruct (@valid_graph _ _ _ _ g _ (maGraph g) (x, L) H1).
    rewrite H0 in H3. apply H3.
  Qed.

  Lemma bi_graph_precise_right: forall (g: Graph) x r,
      vvalid g x -> dst g (x, R) = r -> precise (graph r g).
  Proof.
    intros. apply precise_graph. 1: apply RGF.
    apply weak_valid_vvalid_dec.
    pose proof (right_valid g x H). simpl in H1.
    destruct (@valid_graph _ _ _ _ g _ (maGraph g) (x, R) H1).
    rewrite H0 in H3. apply H3.
  Qed.

  Lemma reachable_through_set_unreachable: forall (g: Graph) (S1 S2: list addr) (v: addr),
      reachable_through_set (predicate_partialgraph g (Intersection addr (vvalid g) (Complement addr (reachable_through_set g S1)))) S2 v ->
      Complement addr (reachable_through_set g S1) v.
  Proof.
    intros. hnf in H. destruct H as [s [? ?]]. unfold Complement. unfold Ensembles.In . rewrite <- reachable_by_eq_partialgraph_reachable in H0.
    apply reachable_by_foot_prop in H0. rewrite Intersection_spec in H0. destruct H0. unfold Complement, Ensembles.In in H1. auto.
  Qed.

  Lemma unreachable_partialgraph_si_vertices_identical: forall (g g': Graph) (S1 S1' S2: list addr),
      (predicate_partial_labeledgraph g (Complement addr (reachable_through_set g S1)))
        ~=~
        (predicate_partial_labeledgraph g' (Complement addr (reachable_through_set g' S1')))%LabeledGraph ->
      vertices_identical2 (reachable_through_set (predicate_partialgraph g (Intersection addr (vvalid g) (Complement addr (reachable_through_set g S1)))) S2)
                          (reachable_through_set (predicate_partialgraph g' (Intersection addr (vvalid g') (Complement addr (reachable_through_set g' S1')))) S2)
                          (Graph_PointwiseGraph g) (Graph_PointwiseGraph g').
  Proof.
  intros.
  apply GSG_PartialGraphPreserve2.
  - unfold Included, Ensembles.In.
    intros.
    apply vvalid_vguard.
    apply reachable_through_set_foot_valid in H0.
    destruct H0; auto.
  - unfold Included, Ensembles.In.
    intros.
    apply vvalid_vguard.
    apply reachable_through_set_foot_valid in H0.
    destruct H0; auto.
  - unfold Included, Ensembles.In.
    intros.
    apply reachable_through_set_foot_valid in H0.
    destruct H0; auto.
  - unfold Included, Ensembles.In.
    intros.
    apply reachable_through_set_foot_valid in H0.
    destruct H0; auto.
  - assert ((predicate_partialgraph g (Intersection addr (vvalid g) (Complement addr (reachable_through_set g S1))))
              ~=~
              (predicate_partialgraph g' (Intersection addr (vvalid g') (Complement addr (reachable_through_set g' S1'))))). {
      destruct H as [[? [? [? ?]]] _]. hnf. simpl in *. unfold predicate_vvalid in *. unfold predicate_weak_evalid in *.
      split; [|split; [|split]]; intros; rewrite !Intersection_spec in *.
      - clear -H. specialize (H v). intuition.
      - clear H2. specialize (H0 e). specialize (H1 e). intuition.
        + rewrite <- H2 in *. specialize (H (src g e)). intuition.
        + rewrite H2 in *. specialize (H (src g' e)). intuition.
      - apply H1; intuition.
      - apply H2; intuition.
    } rewrite <- H0. destruct H as [[? [? [? ?]]] [? ?]]. hnf. unfold structurally_identical. simpl in *. unfold predicate_vvalid in *. unfold predicate_weak_evalid in *.
    split; [split; [|split; [|split]] |split]; intros.
    + clear -H H0. intuition.
      * apply reachable_through_set_unreachable in H3. specialize (H v). intuition.
      * rewrite H0 in H3. apply reachable_through_set_unreachable in H3. specialize (H v). intuition.
    + clear -H1 H2 H0. specialize (H1 e). specialize (H2 e). intuition.
      * apply reachable_through_set_unreachable in H5. apply H1 in H5. intuition.
      * pose proof H5. apply reachable_through_set_unreachable in H5. specialize (H3 H5). specialize (H1 H5). specialize (H3 H1). rewrite <- H3. auto.
      * rewrite H0 in H5. apply reachable_through_set_unreachable in H5. specialize (H3 H5). intuition.
      * pose proof H5. rewrite H0 in H5. apply reachable_through_set_unreachable in H5. specialize (H3 H5). destruct H3. specialize (H1 H3 H6).
        assert (src g e = src g' e) by (apply H1; auto). rewrite H7. auto.
    + destruct H6, H7. rewrite H0 in H9. apply reachable_through_set_unreachable in H8. apply reachable_through_set_unreachable in H9. apply H2; auto.
    + destruct H6, H7. rewrite H0 in H9. apply reachable_through_set_unreachable in H8. apply reachable_through_set_unreachable in H9. apply H3; auto.
    + destruct H6, H7. rewrite H0 in H9. apply reachable_through_set_unreachable in H8. apply reachable_through_set_unreachable in H9. apply H4; auto.
    + destruct H6, H7. rewrite H0 in H9. apply reachable_through_set_unreachable in H8. apply reachable_through_set_unreachable in H9. apply H5; auto.
  Qed.

  Lemma subgraph_update:
    forall (g g': Graph) (S1 S1' S2: list addr),
      (forall x : addr, In x (S1 ++ S2) -> Decidable (vvalid g x)) ->
      (forall x : addr, In x (S1' ++ S2) -> Decidable (vvalid g' x)) ->
      (predicate_partial_labeledgraph g (Complement addr (reachable_through_set g S1))) ~=~
      (predicate_partial_labeledgraph g' (Complement addr (reachable_through_set g' S1')))%LabeledGraph ->
      @derives pred _ (graphs S1 g ⊗ graphs S2 g) (graphs S1 g * (graphs S1' g' -* graphs S1' g' ⊗ graphs S2 g')).
  Proof.
    intros.
    apply subgraph_update; auto.
    + apply RGF.
    + apply RGF.
    + apply unreachable_partialgraph_si_vertices_identical; auto.
    + apply Included_trans with (vvalid g).
      - hnf; intros.
        apply reachable_through_set_foot_valid in H0.
        destruct H0; auto.
      - intro v; apply vvalid_vguard.
    + apply Included_trans with (vvalid g').
      - hnf; intros.
        apply reachable_through_set_foot_valid in H0.
        destruct H0; auto.
      - intro v; apply vvalid_vguard.
  Qed.

End GRAPH_BI.


(*! Understanding conflicts and forwarding !*)
Require Import Koika.Frontend.

Inductive reg_t :=
| in0_empty | in0_data
| in1_empty | in1_data
| fifo_empty | fifo_data
| out_empty | out_data.

Inductive rule_name_t := deq0 | deq1 | process.

Definition R (reg: reg_t) : type :=
  match reg with
  | in0_empty | in1_empty | fifo_empty | out_empty => bits_t 1
  | in0_data | in1_data | fifo_data | out_data => bits_t 32
  end.

Definition urules (rl: rule_name_t) : uaction reg_t empty_ext_fn_t :=
  match rl with
  | deq0 =>
    {{ guard(!read0(in0_empty) && read0(fifo_empty));
       write0(fifo_data, read0(in0_data));
       write0(fifo_empty, Ob~0);
       write0(in0_empty, Ob~1) }}
  | deq1 =>
    {{ guard(!read0(in1_empty) && read0(fifo_empty));
       write0(fifo_data, read0(in1_data));
       write0(fifo_empty, Ob~0);
       write0(in1_empty, Ob~1) }}
  | process =>
    {{ guard(!read1(fifo_empty) && read0(out_empty));
       write0(out_data, read1(fifo_data) + |32`d412|);
       write1(fifo_empty, Ob~1);
       write0(out_empty, Ob~0) }}
  end.

Definition rules : rule_name_t -> rule R empty_Sigma :=
  tc_rules R empty_Sigma urules.

Definition pipeline : scheduler :=
  deq0 |> deq1 |> process |> done.

Definition external (r: rule_name_t) := false.

Definition r (reg: reg_t) : R reg :=
  match reg with
  | in0_empty => Ob~0
  | in0_data => Bits.of_nat _ 42
  | in1_empty => Ob~0
  | in1_data => Bits.of_nat _ 73
  | fifo_empty => Ob~1
  | fifo_data => Bits.zero
  | out_empty => Ob~1
  | out_data => Bits.zero
  end.

Definition cr := ContextEnv.(create) r.

Definition interp_result :=
  tc_compute (commit_update cr (interp_scheduler cr empty_sigma rules pipeline)).

Definition circuits :=
  compile_scheduler rules external pipeline.

Definition circuits_result :=
  tc_compute (interp_circuits empty_sigma circuits (lower_r cr)).

Definition package :=
  {| ip_koika := {| koika_reg_types := R;
                   koika_reg_init reg := r reg;
                   koika_ext_fn_types := empty_Sigma;
                   koika_rules := rules;
                   koika_rule_external := external;
                   koika_scheduler := pipeline;
                   koika_module_name := "conflicts" |};

     ip_sim := {| sp_ext_fn_specs := empty_ext_fn_props;
                 sp_prelude := None |};

     ip_verilog := {| vp_ext_fn_specs := empty_ext_fn_props |} |}.

Definition prog := Interop.Backends.register package.
Extraction "conflicts.ml" prog.