Require Import msl.msl_standard.
Require Import msl.Coqlib2.
Require Import veric.shares.

Module Type ADR_VAL.
Parameter address : Type.
Parameter some_address:address.

(* Validity of traces.  The "valid" predicate ensures that related addresses don't get
    split apart from each other.  *)
Parameter kind: Type.
Parameter valid : (address -> option (rshare * kind)) -> Prop.
Parameter valid_empty: valid (fun _ => None).
Parameter valid_join: forall f g h : address -> option (rshare * kind),
   @join _ (Join_fun address (option (rshare * kind))
                   (Join_lower (Join_prod rshare Join_rshare kind (Join_equiv kind))))
      f g h  ->
 valid f -> valid g -> valid h.
End ADR_VAL.

Module Type ADR_VAL0.
Parameter address : Type.
Parameter some_address:address.
Parameter kind: Type.
End ADR_VAL0.

Module SimpleAdrVal (AV0: ADR_VAL0) <:
   ADR_VAL with Definition address := AV0.address
                   with Definition kind := AV0.kind.
  Import AV0.
  Definition address := address.
  Definition some_address := some_address.
  Definition kind := kind.
  Definition valid (_: address -> option (rshare * kind)) := True.
  Lemma valid_empty: valid (fun _ => None).
  Proof. unfold valid; auto. Qed.
  Lemma valid_join: forall f g h : address -> option (rshare * kind),
   @join _ (Join_fun address (option (rshare * kind))
                   (Join_lower (Join_prod rshare Join_rshare kind (Join_equiv kind))))
      f g h  ->
    valid f -> valid g -> valid h.
  Proof.  intros; unfold valid; auto. Qed.
End SimpleAdrVal.

Inductive TypeTree: Type :=
  | ConstType: Type -> TypeTree
  | Mpred: TypeTree
  | DependentType: nat -> TypeTree
  | ProdType: TypeTree -> TypeTree -> TypeTree
  | ArrowType: TypeTree -> TypeTree -> TypeTree.

Definition dependent_type_functor_rec (ts: list Type): TypeTree -> functor :=
  fix dtfr (T: TypeTree): functor :=
  match T with
  | ConstType A => fconst A
  | Mpred => fidentity
  | DependentType n => fconst (nth n ts unit)
  | ProdType T1 T2 => fpair (dtfr T1) (dtfr T2)
  | ArrowType T1 T2 => ffunc (dtfr T1) (dtfr T2)
  end.
Opaque dependent_type_functor_rec.

Definition dependent_type_function_rec (ts: list Type) (mpred': Type): TypeTree -> Type :=
  fix dtfr (T: TypeTree): Type :=
  match T with
  | ConstType A => A
  | Mpred => mpred'
  | DependentType n => nth n ts unit
  | ProdType T1 T2 => (dtfr T1 * dtfr T2)%type
  | ArrowType T1 T2 => dtfr T1 -> dtfr T2
  end.

Module Type STRAT_MODEL.
  Declare Module AV : ADR_VAL.
  Import AV.

  Definition preds: functor :=
    fsig (fun T: TypeTree =>
      fpi (fun ts: list Type => dependent_type_functor_rec ts T)).

  Inductive res (PRED : Type) : Type :=
    | NO':  forall sh: Share.t, ~(readable_share sh) -> res PRED
    | YES': forall sh: Share.t, readable_share sh -> kind -> preds PRED -> res PRED
    | PURE': kind -> preds PRED -> res PRED.

  Definition res_fmap (A B:Type) (f:A->B) (g:B->A)(x:res A) : res B :=
    match x with
      | NO' rsh nsh => NO' B rsh nsh
      | YES' sh rsh k pds => YES' B sh rsh k (fmap preds f g pds)
      | PURE' k pds => PURE' B k (fmap preds f g pds)
    end.
  Axiom ff_res : functorFacts res res_fmap.
  Definition f_res : functor := Functor ff_res.

  Inductive res_join (PRED : Type) : f_res PRED -> f_res PRED -> f_res PRED -> Prop :=
    | res_join_NO1 : forall sh1 nsh1 sh2 nsh2 sh3 nsh3,
                               join sh1 sh2 sh3 ->
                               res_join PRED (NO' PRED sh1 nsh1) (NO' PRED sh2 nsh2)
                                     (NO' PRED sh3 nsh3)
    | res_join_NO2 : forall sh1 nsh1 sh2 rsh2 sh3 rsh3 k p,
                               join sh1 sh2 sh3 ->
                               res_join PRED (NO' PRED sh1 nsh1) (YES' PRED sh2 rsh2 k p)
                                   (YES' PRED sh3 rsh3 k p)
    | res_join_NO3 : forall sh1 rsh1 sh2 nsh2 sh3 rsh3 k p,
                               join sh1 sh2 sh3 ->
                               res_join PRED (YES' PRED sh1 rsh1 k p) (NO' PRED sh2 nsh2)
                                   (YES' PRED sh3 rsh3 k p)
    | res_join_YES : forall sh1 rsh1 sh2 rsh2 sh3 rsh3 k p,
                              join sh1 sh2 sh3 ->
              res_join PRED (YES' PRED sh1 rsh1 k p) (YES' PRED sh2 rsh2 k p) (YES' PRED sh3 rsh3 k p)
    | res_join_PURE : forall k p, res_join PRED (PURE' PRED k p) (PURE' PRED k p) (PURE' PRED k p).
  Axiom pa_rj : forall PRED, @Perm_alg _ (res_join PRED).
  Axiom sa_rj : forall PRED, @Sep_alg _ (res_join PRED).
  Axiom ca_rj : forall PRED, @Canc_alg _ (res_join PRED).
  Axiom da_rj : forall PRED, @Disj_alg _ (res_join PRED).
  Axiom paf_res : @pafunctor f_res res_join.

  Definition res_option (PRED : Type) (r: res PRED) : option (rshare * kind):=
    match r with
      | NO' _ _ => None
      | YES' sh rsh k _ => Some (readable_part rsh,k)
      | PURE' _ _ => None (* PUREs cannot be split in any interesting way, which is what valid is about. *)
    end.

  Definition valid' A (w: address -> res A) : Prop :=
    AV.valid (fun l => res_option A (w l)).

  Axiom valid'_res_map : forall A B f g m,
    valid' A m -> valid' B (fmap f_res f g oo m).

  (* Definition pre_rmap (A:Type) := { m:address -> res A | valid' A m }. *)
  Definition f_pre_rmap : functor :=
    fsubset (ffunc (fconst address) f_res) _ valid'_res_map.

  (* TODO: this one not used? *)
  Axiom valid'_res_map2 : forall A B f g m, valid' B (res_fmap A B f g oo m) -> valid' A m.

  Instance Join_pre_rmap (A: Type) : Join (f_pre_rmap A) :=
            Join_prop _ (Join_fun address (res A) (res_join A)) (valid' A).

  Parameter Perm_pre_rmap: forall (A: Type), Perm_alg (f_pre_rmap A).
  Parameter Sep_pre_rmap: forall (A: Type), Sep_alg (f_pre_rmap A).
  Parameter Canc_pre_rmap: forall (A: Type), Canc_alg (f_pre_rmap A).
  Parameter Disj_pre_rmap: forall (A: Type), Disj_alg (f_pre_rmap A).
  Parameter paf_pre_rmap : @pafunctor f_pre_rmap Join_pre_rmap.

End STRAT_MODEL.

Module StratModel (AV' : ADR_VAL) : STRAT_MODEL with Module AV:=AV'.
  Module AV := AV'.
  Import AV.

  Definition preds: functor :=
    fsig (fun T: TypeTree =>
      fpi (fun ts: list Type => dependent_type_functor_rec ts T)).

  Inductive res (PRED : Type) : Type :=
    | NO':  forall sh: Share.t, ~(readable_share sh) -> res PRED
    | YES': forall sh: Share.t, readable_share sh -> kind -> preds PRED -> res PRED
    | PURE': kind -> preds PRED -> res PRED.

  Definition res_fmap (A B:Type) (f:A->B) (g:B->A)(x:res A) : res B :=
    match x with
      | NO' rsh nsh => NO' B rsh nsh
      | YES' sh rsh k pds => YES' B sh rsh k (fmap preds f g pds)
      | PURE' k pds => PURE' B k (fmap preds f g pds)
    end.

  Lemma ff_res : functorFacts res res_fmap.
  Proof with auto.
    constructor; intros; extensionality rs; icase rs; unfold res_fmap.
    rewrite fmap_id... rewrite fmap_id...
    rewrite <- fmap_comp... rewrite <- fmap_comp...
  Qed.

  Definition f_res : functor := Functor ff_res.

  Inductive res_join (PRED : Type) : f_res PRED -> f_res PRED -> f_res PRED -> Prop :=
    | res_join_NO1 : forall sh1 nsh1 sh2 nsh2 sh3 nsh3,
                               join sh1 sh2 sh3 ->
                               res_join PRED (NO' PRED sh1 nsh1) (NO' PRED sh2 nsh2)
                                     (NO' PRED sh3 nsh3)
    | res_join_NO2 : forall sh1 nsh1 sh2 rsh2 sh3 rsh3 k p,
                               join sh1 sh2 sh3 ->
                               res_join PRED (NO' PRED sh1 nsh1) (YES' PRED sh2 rsh2 k p)
                                   (YES' PRED sh3 rsh3 k p)
    | res_join_NO3 : forall sh1 rsh1 sh2 nsh2 sh3 rsh3 k p,
                               join sh1 sh2 sh3 ->
                               res_join PRED (YES' PRED sh1 rsh1 k p) (NO' PRED sh2 nsh2)
                                   (YES' PRED sh3 rsh3 k p)
    | res_join_YES : forall sh1 rsh1 sh2 rsh2 sh3 rsh3 k p,
                              join sh1 sh2 sh3 ->
              res_join PRED (YES' PRED sh1 rsh1 k p) (YES' PRED sh2 rsh2 k p) (YES' PRED sh3 rsh3 k p)
    | res_join_PURE : forall k p, res_join PRED (PURE' PRED k p) (PURE' PRED k p) (PURE' PRED k p).

  Instance Join_res (PRED: Type) : Join (res PRED) := res_join PRED.

  Instance pa_rj : forall PRED, @Perm_alg _ (res_join PRED).
  Proof. intros. constructor.
*      (* saf_eq *)
      intros x y z z' H1 H2; inv H1; inv H2;
      repeat match goal with H: join ?A ?B _, H': join ?A ?B ?C |- _ => pose proof (join_eq H H'); subst C end;
      repeat proof_irr; auto.
*     (* saf_assoc *)
      intros a b c d e H1 H2.
      destruct d as [rd | rd sd kd pd | kd pd].
      destruct a as [ra | | ]; try solve [elimtype False; inv H1].
      destruct b as [rb| | ]; try solve [elimtype False; inv H1].
      assert (join ra rb rd) by (inv H1; auto).
      destruct c as [rc | rc sc kc pc | kc pc]; try solve [elimtype False; inv H2].
      destruct e as [re | re se ke pe | ke pe]; try solve [elimtype False; inv H2].
      assert (join rd rc re) by (inv H2; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (NO' _ rf (join_unreadable_shares H3 n1 n2)); split; constructor; auto.
      destruct e as [re | re se ke pe | ke pe]; try solve [elimtype False; inv H2].
      assert (join rd rc re) by (inv H2; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES' _ rf (join_readable2 H3 sc) kc pc).
      inv H2. split; constructor; auto.
      destruct c as [rc | rc sc kc pc | kc pc]; try solve [elimtype False; inv H2].
      destruct e as [re | re se ke pe | ke pe]; try solve [elimtype False; inv H2].
      assert (H0: join rd rc re) by (inv H2; auto).
      destruct a as [ra | ra sa ka pa | ka pa ]; try solve [elimtype False; inv H1].
      destruct b as [ | rb sb kb pb | ]; try solve [elimtype False; inv H1].
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES' _ rf (join_readable1 H3 sb) kd pd).  inv H1; inv H2; split; constructor; auto.
      destruct b as [ rb | rb sb kb pb | ]; try solve [elimtype False; inv H1].
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (NO' _ rf (join_unreadable_shares H3 n0 n)).  inv H1; inv H2; split; constructor; auto.
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES' _ rf (join_readable1 H3 sb) kb pb).  inv H1; inv H2; split; constructor; auto.
      destruct e as [re | re se ke pe | ke pe]; try solve [elimtype False; inv H2].
      assert (H0: join rd rc re) by (inv H2; auto).
      destruct b as [ rb | rb sb kb pb | ]; try solve [elimtype False; inv H1].
      destruct a as [ra | ra sa ka pa | ka pa ]; try solve [elimtype False; inv H1].
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES' _ rf (join_readable2 H3 sc) kc pc).  inv H1; inv H2; split; constructor; auto.
      destruct a as [ra | ra sa ka pa | ka pa ]; try solve [elimtype False; inv H1].
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES' _ rf (join_readable1 H3 sb) kb pb).  inv H1; inv H2; split; try constructor; auto.
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES' _ rf (join_readable1 H3 sb) kb pb).  inv H1; inv H2; split; try constructor; auto.
      exists (PURE' _ kd pd). inv H1; inv H2; split; constructor.

*      (* saf_com *)
      intros a b c H; inv H; econstructor;  apply join_comm; auto.

*     (* saf_positivity *)
     intros; inv H; inv H0;
      repeat match goal with H: join ?A ?B ?C, H': join ?C ?D ?A |- _ =>
                    pose proof (join_positivity H H'); subst C
      end;
      repeat proof_irr; auto.
 Qed.

  Instance sa_rj : forall PRED, @Sep_alg _ (res_join PRED).
  Proof. intros.
            apply mkSep
             with (fun x => match x
                             with NO' _ _ => NO' _ Share.bot bot_unreadable
                               | YES' _ _ _ _ => NO' _ Share.bot bot_unreadable
                               | PURE' k pds => PURE' _ k pds end).
            intro. destruct t; constructor; try apply join_unit1; auto.
            intros. inversion H; auto.
  Defined.

  Instance ca_rj : forall PRED, @Canc_alg _ (res_join PRED).
  Proof. repeat intro. inv H; inv H0; auto;
    repeat match goal with H: join ?A ?B ?C, H': join ?D ?B ?C |- _ => pose proof (join_canc H H'); subst D end;
    repeat proof_irr; auto; try contradiction.
  Qed.

  Instance da_rj : forall PRED, @Disj_alg _ (res_join PRED).
  Proof.  repeat intro.
    inv H;
    repeat match goal with H: join ?A ?A ?B |- _ =>
              apply join_self in H; subst B end;
    repeat proof_irr; auto.
  Qed.

  Definition paf_res : @pafunctor f_res res_join.
  Proof. constructor; repeat intro.
  (* This is a little painful because of the way res_join is defined, but
      whatever... *)
   inv H; simpl; constructor; trivial.
   destruct z as [ rz | rz sz kz pz | kz pz ].
   destruct x' as [ rx' | rx' sx' kx' px' | kx' px' ]; try solve [elimtype False; inv H].
   destruct y as [ ry | ry sy ky py | ky py ]; try solve [elimtype False; inv H].
   exists (NO' _ rx' n0); exists (NO' _ ry n1); inv H; split; constructor; tauto.
   destruct x' as [ rx' | rx' sx' kx' px' | kx' px' ]; try solve [elimtype False; inv H].
   destruct y as [ ry | ry sy ky py | ky py ]; try solve [elimtype False; inv H].
   exists (NO' _ rx' n); exists (YES' _ ry sy kz pz); inv H; split; constructor; auto. simpl in *; f_equal; auto.
   destruct y as [ ry | ry sy ky py | ky py ]; try solve [elimtype False; inv H].
   exists (YES' _ rx' sx' kx' pz); exists (NO' _ ry n); inv H; split; constructor; auto.
   exists (YES' _ rx' sx' kx' pz); exists (YES' _ ry sy ky pz); inv H; split; constructor; auto; simpl; f_equal; auto.
   exists (PURE' _ kz pz); exists (PURE' _ kz pz); simpl in *; inv H; split; [constructor | tauto].

   destruct x as [ rx | rx sx kx px | kx px ]; try solve [elimtype False; inv H].
   destruct y as [ ry | ry sy ky py | ky py ]; try solve [elimtype False; inv H].
   destruct z' as [ rz | rz sz kz pz | kz pz ]; try solve [elimtype False; inv H].
   exists (NO' _ ry n0); exists (NO' _ rz n1); inv H; split; constructor; auto.
   destruct z' as [ rz | rz sz kz pz | kz pz ]; try solve [elimtype False; inv H].
   exists (YES' _ ry sy ky py); exists (YES' _ rz sz ky py); inv H; split; constructor; auto.
   destruct y as [ ry | ry sy ky py | ky py ]; try solve [elimtype False; inv H].
   destruct z' as [ rz | rz sz kz pz | kz pz ]; try solve [elimtype False; inv H].
   exists (NO' _ ry n); exists (YES' _ rz sz kx px); inv H; split; constructor; auto.
   destruct z' as [ rz | rz sz kz pz | kz pz ]; try solve [elimtype False; inv H].
   exists (YES' _ ry sy kx px); exists (YES' _ rz sz kx px); inv H; split; constructor; auto. simpl; f_equal; auto.
   exists (PURE' _ kx px); exists (PURE' _ kx px); inv H; split; constructor; auto.
  Qed.

  Definition res_option (PRED : Type) (r: res PRED) : option (rshare * kind):=
    match r with
      | NO' _ _ => None
      | YES' sh rsh k _ => Some (readable_part rsh,k)
      | PURE' _ _ => None (* PUREs cannot be split in any interesting way, which is what valid is about. *)
    end.

  Definition valid' A (w: address -> res A) : Prop :=
    AV.valid (fun l => res_option A (w l)).

  Lemma same_valid : forall f1 f2, (forall x, f1 x = f2 x) -> AV.valid f1 -> AV.valid f2.
  Proof.
    intros; replace f2 with f1; trivial.
    apply extensionality; auto.
  Qed.

  Lemma valid'_res_map : forall A B f g m,
    valid' A m -> valid' B (fmap f_res f g oo m).
  Proof.
    unfold valid'; intros A B f g m.
    apply same_valid; intro l.
    unfold compose.
    destruct (m l); simpl; auto.
  Qed.

  Lemma valid'_res_map2 : forall A B f g m,
    valid' B (fmap f_res f g oo m) -> valid' A m.
  Proof.
    unfold valid'; intros A B f g m.
    apply same_valid; intro l.
    unfold compose.
    destruct (m l); simpl; auto.
  Qed.

  Definition pre_rmap (A:Type) := { m:address -> res A | valid' A m }.
  Definition f_pre_rmap : functor :=
    fsubset (ffunc (fconst address) f_res) _ valid'_res_map.

  Instance Join_pre_rmap (A: Type) : Join (pre_rmap A) :=
            Join_prop _ (Join_fun address (res A) (res_join A)) (valid' A).

  Definition paf_pre_rmap : @pafunctor f_pre_rmap Join_pre_rmap :=
    paf_subset (paf_fun address paf_res) valid' valid'_res_map valid'_res_map2.

  Lemma pre_rmap_sa_valid_core (A: Type):
        forall x : address -> res A,
       valid' A x ->
       valid' A  (@core (address -> res A) (Join_fun address (res A) (res_join A))
                     (Sep_fun address (res A) (res_join A) (sa_rj A)) x).
  Proof.
    intros. red. red.
    replace (fun l => res_option A (core x l)) with (fun l : address => @None (rshare * kind)).
    apply AV.valid_empty.
    extensionality a. simpl. icase (x a).
  Qed.

  Lemma pre_rmap_sa_valid_join : forall A (x y z : address -> res A),
    @join _ (Join_fun address (res A) (res_join A)) x y z ->
    valid' A x -> valid' A y -> valid' A z.
  Proof.
     intros.
     simpl in H.
     unfold valid' in *.
     apply AV.valid_join with (fun l => res_option A (x l)) (fun l => res_option A (y l)); auto.
     intro l. spec H l. inv H; try constructor; simpl.
     apply join_comm in H5.
     rewrite (join_readable_part_eq rsh2 nsh1 rsh3 H5). constructor.
     rewrite (join_readable_part_eq rsh1 nsh2 rsh3 H5). constructor.
     constructor.
     red. red. simpl.
     clear - H5. destruct H5. split.
     rewrite Share.glb_assoc. rewrite <- (Share.glb_assoc sh1).
     rewrite (Share.glb_commute sh1). rewrite Share.glb_assoc.
     rewrite <- (Share.glb_assoc Share.Rsh).
     rewrite H. rewrite Share.glb_bot. auto.
     rewrite <- Share.distrib1. rewrite H0. auto.
     constructor. reflexivity. reflexivity.
  Qed.

  Definition Perm_pre_rmap (A: Type): Perm_alg (pre_rmap A) :=
    Perm_prop _ _ (Perm_fun address _ _ _) _ (pre_rmap_sa_valid_join _).

  Definition Sep_pre_rmap (A: Type): Sep_alg (pre_rmap A) :=
    Sep_prop _ _ (Perm_fun address _ _ _) _ (pre_rmap_sa_valid_join _)  _ (pre_rmap_sa_valid_core _).

  Definition Canc_pre_rmap (A: Type): Canc_alg (pre_rmap A) :=
    @Canc_prop _ _ _ (Canc_fun address _ _ _).

  Definition Disj_pre_rmap (A: Type): Disj_alg (pre_rmap A) :=
    @Disj_prop _ _ _ (Disj_fun address _ _ _).

End StratModel.

Local Open Scope nat_scope.

Module Type RMAPS.
  Declare Module AV:ADR_VAL.
  Import AV.

  Parameter rmap : Type.
  Axiom Join_rmap: Join rmap. Existing Instance Join_rmap.
  Axiom Perm_rmap: Perm_alg rmap. Existing Instance Perm_rmap.
  Axiom Sep_rmap: Sep_alg rmap. Existing Instance Sep_rmap.
  Axiom Canc_rmap: Canc_alg rmap.  Existing Instance Canc_rmap.
  Axiom Disj_rmap: Disj_alg rmap.  Existing Instance Disj_rmap.
  Axiom ag_rmap: ageable rmap.  Existing Instance ag_rmap.
  Axiom Age_rmap: Age_alg rmap.  Existing Instance Age_rmap.

  Inductive preds : Type :=
    SomeP : forall A : TypeTree,
      (forall ts: list Type, dependent_type_functor_rec ts A (pred rmap)) -> preds.

  Definition NoneP := SomeP (ConstType unit) (fun _ => tt).

  Inductive resource : Type :=
    | NO: forall sh: Share.t, ~(readable_share sh) -> resource
    | YES: forall sh: Share.t, readable_share sh -> kind -> preds -> resource
    | PURE: kind -> preds -> resource.

  Definition res_option (r:resource) : option (rshare * kind) :=
    match r with
      | NO _ _ => None
      | YES sh rsh k _ => Some (readable_part rsh,k)
      | PURE k _ => None
    end.

  Inductive res_join : resource -> resource -> resource -> Prop :=
   | res_join_NO1 : forall sh1 nsh1 sh2 nsh2 sh3 nsh3
                 (RJ: join sh1 sh2 sh3),
                 res_join (NO sh1 nsh1) (NO sh2 nsh2) (NO sh3 nsh3)
   | res_join_NO2 : forall sh1 rsh1 sh2 nsh2 sh3 rsh3 k p
                 (RJ: join sh1 sh2 sh3),
                 res_join (YES sh1 rsh1 k p) (NO sh2 nsh2) (YES sh3 rsh3 k p)
   | res_join_NO3 : forall sh1 nsh1 sh2 rsh2 sh3 rsh3 k p
                 (RJ: join sh1 sh2 sh3),
                 res_join (NO sh1 nsh1) (YES sh2 rsh2 k p) (YES sh3 rsh3 k p)
   | res_join_YES : forall sh1 rsh1 sh2 rsh2 sh3 rsh3 k p
                 (RJ: join sh1 sh2 sh3),
        res_join (YES sh1 rsh1 k p) (YES sh2 rsh2 k p) (YES sh3 rsh3 k p)
   | res_join_PURE : forall k p, res_join (PURE k p) (PURE k p) (PURE k p).

  Instance Join_resource: Join resource := res_join.
  Axiom Perm_resource: Perm_alg resource. Existing Instance Perm_resource.
  Axiom Sep_resource: Sep_alg resource. Existing Instance Sep_resource.
  Axiom Canc_resource: Canc_alg resource. Existing Instance Canc_resource.
  Axiom Disj_resource: Disj_alg resource. Existing Instance Disj_resource.

  Definition preds_fmap (f g: pred rmap -> pred rmap) (x:preds) : preds :=
    match x with SomeP A Q => SomeP A (fmap (fpi _) f g Q)
    end.
  (* Check whether the following two can be erased. *)
  Axiom preds_fmap_id : preds_fmap (id _) (id _) = id preds.
  Axiom preds_fmap_comp : forall f1 f2 g1 g2,
    preds_fmap g1 g2 oo preds_fmap f1 f2 = preds_fmap (g1 oo f1) (f2 oo g2).

  Definition resource_fmap (f g:pred rmap -> pred rmap) (x:resource) : resource :=
    match x with
    | NO sh nsh => NO sh nsh
    | YES sh rsh k p => YES sh rsh k (preds_fmap f g p)
    | PURE k p => PURE k (preds_fmap f g p)
    end.
  Axiom resource_fmap_id : resource_fmap (id _) (id _) = id resource.
  Axiom resource_fmap_comp : forall f1 f2 g1 g2,
    resource_fmap g1 g2 oo resource_fmap f1 f2 = resource_fmap (g1 oo f1) (f2 oo g2).

  Definition valid (m: address -> resource) : Prop :=
    AV.valid  (res_option oo m).

  Axiom valid_res_map : forall f g m, valid m -> valid (resource_fmap f g oo m).
  Axiom rmapj_valid_join : forall (x y z : address -> resource),
    join x y z -> valid x -> valid y -> valid z.
  Axiom rmapj_valid_core: forall x: address -> resource, valid x -> valid (core x).

  Definition rmap' := sig valid.

  Definition rmap_fmap (f g: pred rmap -> pred rmap) (x:rmap') : rmap' :=
    match x with exist m H => exist (fun m => valid m) (resource_fmap f g oo m) (valid_res_map f g m H) end.
  Axiom rmap_fmap_id : rmap_fmap (id _) (id _) = id rmap'.
  Axiom rmap_fmap_comp : forall f1 f2 g1 g2,
   rmap_fmap g1 g2 oo rmap_fmap f1 f2 = rmap_fmap (g1 oo f1) (f2 oo g2).

  Parameter squash : (nat * rmap') -> rmap.
  Parameter unsquash : rmap -> (nat * rmap').

  Axiom rmap_level_eq: @level rmap _ = fun x => fst (unsquash x).
  Axiom rmap_age1_eq: @age1 _ _ =
     fun k => match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.

  Definition resource_at (phi:rmap) : address -> resource := proj1_sig (snd (unsquash phi)).
  Infix "@" := resource_at (at level 50, no associativity).

  Instance Join_nat_rmap': Join (nat * rmap') := Join_prod _ (Join_equiv nat) _ _.

  Axiom join_unsquash : forall phi1 phi2 phi3,
    join phi1 phi2 phi3 <->
    join (unsquash phi1) (unsquash phi2) (unsquash phi3).

  Definition rmap_unage (k:rmap) : rmap :=
    match unsquash k with
    | (n,x) => squash (S n, x)
    end.

  Program Definition approx (n:nat) (p: pred rmap) : pred rmap :=
    fun w => level w < n /\ p w.
  Next Obligation.
  destruct H0.
  split.
  apply age_level in H. omega.
  apply pred_hereditary with a; auto.
  Qed.

  Axiom squash_unsquash : forall phi, squash (unsquash phi) = phi.
  Axiom unsquash_squash : forall n rm, unsquash (squash (n,rm)) = (n,rmap_fmap (approx n) (approx n) rm).

End RMAPS.

Module Rmaps (AV':ADR_VAL) : RMAPS with Module AV:=AV'.
  Module AV:=AV'.
  Import AV.

  Module SM := StratModel(AV).
  Import SM.

  Module TyF. (* <: TY_FUNCTOR_PROP. *)
    Definition F := f_pre_rmap.
  End TyF.

  Module TyFSA <: KNOT_FULL_SA_INPUT with Module KI:=TyF.
    Module KI := TyF.
    Import KI.

    Instance Join_F: forall A, Join (F A) := _.
    Definition Perm_F : forall A, Perm_alg (F A) := Perm_pre_rmap.
    Definition Sep_F := Sep_pre_rmap.
    Definition Canc_F := Canc_pre_rmap.
    Definition Disj_F := Disj_pre_rmap.
    Definition paf_F := paf_pre_rmap.
  End TyFSA.

  Module K := Knot_MixVariantHeredProp(TyF).
  Module KL := KnotLemmas_MixVariantHeredProp(K).
  Module KSa := KnotFullSa(TyFSA)(K)(KL).

  Definition rmap := K.knot.
  Instance Join_rmap: Join rmap := KSa.Join_knot.
  Instance Perm_rmap : Perm_alg rmap:= KSa.Perm_knot.
  Instance Sep_rmap : Sep_alg rmap:= KSa.Sep_knot.
  Instance Canc_rmap : Canc_alg rmap:= KSa.Canc_knot.
  Instance Disj_rmap : Disj_alg rmap:= KSa.Disj_knot.
  Instance ag_rmap : ageable rmap := K.ageable_knot.
  Instance Age_rmap: Age_alg rmap := KSa.asa_knot.

  Inductive preds : Type :=
    SomeP : forall A : TypeTree,
    (forall ts: list Type, dependent_type_functor_rec ts A (pred rmap)) -> preds.

  Definition NoneP := SomeP (ConstType unit) (fun _ => tt).

  Inductive resource : Type :=
    | NO: forall sh: Share.t, ~ readable_share sh -> resource
    | YES: forall sh: Share.t, readable_share sh -> kind -> preds -> resource
    | PURE: kind -> preds -> resource.

  Definition resource2res (r: resource): res (pred rmap) :=
    match r with
      | NO sh nsh => NO' (pred rmap) sh nsh
      | YES sh rsh k (SomeP A l) => YES' (pred rmap) sh rsh k (existT _ A l)
      | PURE k (SomeP A l) => PURE' (pred rmap) k (existT _ A l)
    end.

  Definition res2resource (r: res (pred rmap)) : resource :=
    match r with
      | NO' sh nsh => NO sh nsh
      | YES' sh rsh k (existT A l) => YES sh rsh k (SomeP A l)
      | PURE' k (existT A l) => PURE k (SomeP A l)
    end.

  Lemma res2resource2res: forall x, resource2res (res2resource x) = x.
  Proof. unfold resource2res, res2resource; destruct x as [? | ? ? ? [? ?] | ? [? ?]]; auto. Qed.

  Lemma resource2res2resource: forall x, res2resource (resource2res x) = x.
  Proof. unfold resource2res, res2resource; destruct x; try destruct p0; try destruct p; auto. Qed.

  Definition res_option (r:resource) : option (rshare * kind) :=
    match r with
      | NO _ _ => None
      | YES sh rsh k _ => Some (readable_part rsh,k)
      | PURE k _ => None
    end.

  Lemma res_option_rewrite: res_option = SM.res_option (pred rmap) oo resource2res.
  Proof.
    unfold SM.res_option, res_option, compose.
    extensionality r; destruct r; simpl; auto; destruct p; auto.
  Qed.

  Definition valid (m: address -> resource) : Prop :=
    AV.valid (res_option oo m).

  Inductive res_join : resource -> resource -> resource -> Prop :=
   | res_join_NO1 : forall sh1 nsh1 sh2 nsh2 sh3 nsh3
                 (RJ: join sh1 sh2 sh3),
                 res_join (NO sh1 nsh1) (NO sh2 nsh2) (NO sh3 nsh3)
   | res_join_NO2 : forall sh1 rsh1 sh2 nsh2 sh3 rsh3 k p
                 (RJ: join sh1 sh2 sh3),
                 res_join (YES sh1 rsh1 k p) (NO sh2 nsh2) (YES sh3 rsh3 k p)
   | res_join_NO3 : forall sh1 nsh1 sh2 rsh2 sh3 rsh3 k p
                 (RJ: join sh1 sh2 sh3),
                 res_join (NO sh1 nsh1) (YES sh2 rsh2 k p) (YES sh3 rsh3 k p)
   | res_join_YES : forall sh1 rsh1 sh2 rsh2 sh3 rsh3 k p
                 (RJ: join sh1 sh2 sh3),
        res_join (YES sh1 rsh1 k p) (YES sh2 rsh2 k p) (YES sh3 rsh3 k p)
   | res_join_PURE : forall k p, res_join (PURE k p) (PURE k p) (PURE k p).

  Instance Join_resource: Join resource := res_join.
  Instance Perm_resource: Perm_alg resource.
  Proof. constructor.
  * (*saf_eq *)
      intros x y z z' H1 H2; inv H1; inv H2;
      repeat match goal with H: join ?A ?B _, H': join ?A ?B ?C |- _ => pose proof (join_eq H H'); subst C end;
      repeat proof_irr; auto.
  * (* saf_assoc *)
      intros a b c d e H1 H2.
      destruct d as [rd | rd sd kd pd | kd pd].
      destruct a as [ra | | ]; try solve [elimtype False; inv H1].
      destruct b as [rb| | ]; try solve [elimtype False; inv H1].
      assert (join ra rb rd) by (inv H1; auto).
      destruct c as [rc | rc sc kc pc | kc pc]; try solve [elimtype False; inv H2].
      destruct e as [re | re se ke pe | ke pe]; try solve [elimtype False; inv H2].
      assert (join rd rc re) by (inv H2; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (NO rf (join_unreadable_shares H3 n1 n2)); split; constructor; auto.
      destruct e as [re | re se ke pe | ke pe]; try solve [elimtype False; inv H2].
      assert (join rd rc re) by (inv H2; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES rf (join_readable2 H3 sc) kc pc).
      inv H2. split; constructor; auto.
      destruct c as [rc | rc sc kc pc | kc pc]; try solve [elimtype False; inv H2].
      destruct e as [re | re se ke pe | ke pe]; try solve [elimtype False; inv H2].
      assert (H0: join rd rc re) by (inv H2; auto).
      destruct a as [ra | ra sa ka pa | ka pa ]; try solve [elimtype False; inv H1].
      destruct b as [ | rb sb kb pb | ]; try solve [elimtype False; inv H1].
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES rf (join_readable1 H3 sb) kd pd).  inv H1; inv H2; split; constructor; auto.
      destruct b as [ rb | rb sb kb pb | ]; try solve [elimtype False; inv H1].
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (NO rf (join_unreadable_shares H3 n0 n)).  inv H1; inv H2; split; constructor; auto.
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES rf (join_readable1 H3 sb) kb pb).  inv H1; inv H2; split; constructor; auto.
      destruct e as [re | re se ke pe | ke pe]; try solve [elimtype False; inv H2].
      assert (H0: join rd rc re) by (inv H2; auto).
      destruct b as [ rb | rb sb kb pb | ]; try solve [elimtype False; inv H1].
      destruct a as [ra | ra sa ka pa | ka pa ]; try solve [elimtype False; inv H1].
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES rf (join_readable2 H3 sc) kc pc).  inv H1; inv H2; split; constructor; auto.
      destruct a as [ra | ra sa ka pa | ka pa ]; try solve [elimtype False; inv H1].
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES rf (join_readable1 H3 sb) kb pb).  inv H1; inv H2; split; try constructor; auto.
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES rf (join_readable1 H3 sb) kb pb).  inv H1; inv H2; split; try constructor; auto.
      exists (PURE kd pd). inv H1; inv H2; split; constructor.

*      (* saf_com *)
      intros a b c H; inv H; econstructor;  apply join_comm; auto.

*     (* saf_positivity *)
     intros; inv H; inv H0;
      repeat match goal with H: join ?A ?B ?C, H': join ?C ?D ?A |- _ =>
                    pose proof (join_positivity H H'); subst C
      end;
      repeat proof_irr; auto.
 Qed.

  Instance Sep_resource: Sep_alg resource.
  Proof.
  apply mkSep
    with (fun x => match x
                   with NO _ _ => NO Share.bot bot_unreadable
                      | YES _ _ _ _ => NO Share.bot bot_unreadable
                      | PURE k pds => PURE k pds end).
  intro. destruct t; constructor; try apply join_unit1; auto.
  intros. inversion H; auto.
  Defined.

  Instance Canc_resource: Canc_alg resource.
  Proof. repeat intro. inv H; inv H0; auto;
    repeat match goal with H: join ?A ?B ?C, H': join ?D ?B ?C |- _ => pose proof (join_canc H H'); subst D end;
    repeat proof_irr; auto; try contradiction.
  Qed.

  Instance Disj_resource: Disj_alg resource.
  Proof.
    repeat intro.
    inv H;
    repeat match goal with H: join ?A ?A ?B |- _ =>
              apply join_self in H; subst B end;
    repeat proof_irr; auto.
  Qed.

  Lemma same_valid : forall f1 f2, (forall x, f1 x = f2 x) -> AV.valid f1 -> AV.valid f2.
  Proof.
    intros; replace f2 with f1; trivial.
    apply extensionality; auto.
  Qed.

  Lemma rmapj_valid_core: forall x : address -> resource, valid x -> valid (core x).
  Proof.
     unfold valid, compose; intros. red. red.
     replace (fun x0 => res_option (core x x0)) with (fun _ : address => @None (rshare * kind)).

     apply AV.valid_empty.
     extensionality a. simpl. icase (x a).
  Qed.

  Lemma rmapj_valid_join : forall (x y z : address -> resource),
    join x y z ->
    valid x -> valid y -> valid z.
  Proof.
     intros.
     simpl in H.
     unfold valid, compose in *.
     apply AV.valid_join with (fun l => res_option (x l)) (fun l => res_option (y l)); auto.
     intro l. specialize (H l). inv  H; eauto. constructor.
     simpl.
     rewrite (join_readable_part_eq rsh1 nsh2 rsh3 RJ). constructor.
     apply join_comm in RJ.
     simpl.
     rewrite (join_readable_part_eq rsh2 nsh1 rsh3 RJ). constructor.
     constructor. constructor. simpl.
     red. red. simpl.
     clear - RJ. destruct RJ. split.
     rewrite Share.glb_assoc. rewrite <- (Share.glb_assoc sh1).
     rewrite (Share.glb_commute sh1). rewrite Share.glb_assoc.
     rewrite <- (Share.glb_assoc Share.Rsh).
     rewrite H. rewrite Share.glb_bot. auto.
     rewrite <- Share.distrib1. rewrite H0. auto.
     constructor. reflexivity. reflexivity.
     constructor.
  Qed.

  Definition rmap' := sig valid.
  Definition preds_fmap (f g:(pred rmap)->(pred rmap)) (x:preds) : preds :=
    match x with SomeP A ls => SomeP A (fmap (fpi _) f g ls) end.

  Lemma preds_fmap_id : preds_fmap (id (pred rmap)) (id (pred rmap)) = id preds.
  Proof.
    intros; apply extensionality; intro x; destruct x; simpl; auto.
    unfold id at 3.
    f_equal.
    extensionality i.
    rewrite fmap_id; auto.
  Qed.

  Lemma preds_fmap_comp : forall f1 f2 g1 g2,
    preds_fmap g1 g2 oo preds_fmap f1 f2 = preds_fmap (g1 oo f1) (f2 oo g2).
  Proof.
    intros; apply extensionality; intro x; destruct x; simpl.
    unfold preds_fmap, compose at 1; simpl.
    f_equal.
    extensionality i.
    rewrite <- fmap_comp; auto.
  Qed.

  Definition resource_fmap (f g:pred rmap -> pred rmap) (x:resource) : resource :=
    match x with
    | NO sh nsh => NO sh nsh
    | YES sh rsh k p => YES sh rsh k (preds_fmap f g p)
    | PURE k p => PURE k (preds_fmap f g p)
    end.

  Lemma valid_res_map : forall f g m, valid m -> valid (resource_fmap f g oo m).
  Proof.
    unfold valid, compose; intros.
    replace (fun l : address => res_option (resource_fmap f g (m l)))
       with (fun l : address => res_option (m l)); auto.
    extensionality l.
    unfold res_option, resource_fmap.
    case (m l); auto.
  Qed.

  Lemma resource_fmap_id :
    resource_fmap (id (pred rmap)) (id (pred rmap)) = id resource.
  Proof.
    intros; apply extensionality; intro x.
    unfold resource_fmap.
    destruct x; simpl; auto.
    rewrite preds_fmap_id; auto.
    rewrite preds_fmap_id; auto.
  Qed.

  Lemma resource_fmap_comp : forall f1 f2 g1 g2,
    resource_fmap g1 g2 oo resource_fmap f1 f2 = resource_fmap (g1 oo f1) (f2 oo g2).
  Proof.
    intros f1 f2 g1 g2.
    apply extensionality; intro x; destruct x; simpl; auto.
    unfold compose at 1; simpl.
    rewrite <- preds_fmap_comp; auto.
    rewrite <- preds_fmap_comp; auto.
  Qed.

  Definition rmap_fmap (f g:(pred rmap)->(pred rmap)) (x:rmap') : rmap' :=
    match x with exist m H => exist (fun m => valid m) (resource_fmap f g oo m) (valid_res_map f g m H) end.

  Lemma rmap_fmap_id : rmap_fmap (id (pred rmap)) (id (pred rmap)) = id rmap'.
  Proof.
    intros; apply extensionality; intro x.
    unfold rmap_fmap; destruct x.
    unfold id at 5.
    generalize (valid_res_map (id _) (id _) x v).
    rewrite (resource_fmap_id).
    simpl.
    rewrite (id_unit2 _ (resource) x).
    intro v0. f_equal; auto. apply proof_irr.
  Qed.

  Lemma rmap_fmap_comp : forall f1 f2 g1 g2,
    rmap_fmap g1 g2 oo rmap_fmap f1 f2 = rmap_fmap (g1 oo f1) (f2 oo g2).
  Proof.
    intros f1 f2 g1 g2.
    unfold rmap_fmap.
    apply extensionality; intro x.
    unfold compose at 1.
    destruct x.
    generalize (valid_res_map g1 g2 (resource_fmap f1 f2 oo x) (valid_res_map f1 f2 x v)).
    generalize (valid_res_map (g1 oo f1) (f2 oo g2) x v).
    clear.
    assert (resource_fmap g1 g2 oo resource_fmap f1 f2 oo x = resource_fmap (g1 oo f1) (f2 oo g2) oo x).
    rewrite <- compose_assoc.
    rewrite resource_fmap_comp; auto.
    rewrite H.
    intros.
    intros; f_equal; proof_irr; auto.
  Qed.

  Definition rmap'2pre_rmap (r: rmap') : f_pre_rmap (pred rmap).
    destruct r as [f ?].
    unfold f_pre_rmap.
    assert (valid' _ (fun x: address => resource2res (f x))).
    unfold valid'. unfold valid, compose in v.
    eapply same_valid; try apply v.
    intros. simpl.
    destruct (f x); simpl; auto; destruct p; simpl; auto.
    eexists. exact H.
  Defined.

  Definition pre_rmap2rmap' (r: f_pre_rmap (pred rmap)) : rmap'.
    destruct r as [f ?].
    unfold rmap', valid' in *.
    assert (valid (fun l: address => res2resource (f l))).
    unfold valid, compose.
    replace (fun l : address => res_option (res2resource (f l))) with (fun l : address => SM.res_option (pred rmap) (f l)); auto.
    extensionality l. rewrite res_option_rewrite.
    unfold compose; simpl. rewrite res2resource2res. auto.
    eauto.
  Defined.

  Lemma rmap'2pre_rmap2rmap' :
    forall x, rmap'2pre_rmap (pre_rmap2rmap' x) = x.
  Proof.
    intro. destruct x as [f V]. unfold rmap'2pre_rmap, pre_rmap2rmap'. simpl.
    match goal with |- exist _ _ ?p = _ => generalize p; intro p1 end.
    apply exist_ext.
    extensionality x; rewrite res2resource2res; auto.
  Qed.

  Lemma pre_rmap2rmap'2pre_rmap :
    forall x,  pre_rmap2rmap' (rmap'2pre_rmap x) = x.
  Proof.
    intro.
    destruct x as [f V].
    unfold rmap'2pre_rmap, pre_rmap2rmap'. simpl.
    match goal with |- exist _ _ ?p = _ => generalize p; intro p1 end.
    apply exist_ext.
    extensionality x; rewrite resource2res2resource; auto.
  Qed.
(*
  Program Definition p2p (p:(pred rmap)) : K.predicate :=
    fun phi_e => p phi_e.
  Next Obligation.
    unfold age, age1 in H. simpl in H. simpl in *.
    eapply pred_hereditary; eauto.
 Qed.

  Program Definition p2p' (p:K.predicate) : (pred rmap) :=
    fun (v:rmap) => p v.
  Next Obligation.
  unfold age in H; simpl in H.
  unfold rmap in *.
  eapply pred_hereditary; eauto.
 Qed.
*)
  Definition squash (n_rm:nat * rmap') : rmap :=
    match n_rm with (n,rm) => K.squash (n, rmap'2pre_rmap rm) end.

  Definition unsquash (phi:rmap) : (nat * rmap') :=
    match K.unsquash phi with (n,rm) => (n, pre_rmap2rmap' rm) end.

  Definition rmap_level (phi:rmap) : nat := fst (unsquash phi).
  Definition resource_at (phi:rmap) : address -> resource := proj1_sig (snd (unsquash phi)).
  Infix "@" := resource_at (at level 50, no associativity).

  Lemma pred_ext': forall {A} `{agA: ageable A} P Q,
                (forall x, app_pred P x <-> app_pred Q x) -> P = Q.
  Proof. intros; apply pred_ext; intro; apply H; auto. Qed.

  Lemma squash_unsquash : forall phi, squash (unsquash phi) = phi.
  Proof.
    intros.
    unfold squash, unsquash; simpl.
    destruct (K.unsquash phi) eqn:?H; simpl; intros.
    rewrite rmap'2pre_rmap2rmap'.
    unfold K.KI.F in *.
    unfold f_pre_rmap in H.
    match goal with
    | |- K.squash ?A = _ => replace A with (K.unsquash phi)
    end.
    rewrite K.squash_unsquash; auto.
  Qed.

  Program Definition approx (n:nat) (p: (pred rmap)) : (pred rmap) :=
    fun w => level w < n /\ p w.
  Next Obligation.
  destruct H0.
  split.
  apply age_level in H.
  simpl in *. omega.
  apply pred_hereditary with a; auto.
  Qed.

  Lemma approx_K_approx: approx = K.approx.
  Proof.
    extensionality n p.
    apply pred_ext'; intros w.
    unfold approx, compose; simpl.
    rewrite K.approx_spec.
    unfold rmap_level, unsquash; simpl;
    repeat rewrite K.knot_level;
    repeat rewrite setset, setget;     intuition.
  Qed.

  Lemma unsquash_squash : forall n rm, (unsquash (squash (n,rm))) = (n,rmap_fmap (approx n) (approx n) rm).
  Proof.
    intros.
    unfold unsquash, squash.
    rewrite K.unsquash_squash. unfold K.KI.F, f_pre_rmap.
    match goal with [|- (_,?X) = (_,?Y) ] =>
      replace Y with X; auto
    end.
    match goal with [|- pre_rmap2rmap' ?X = _ ] =>
      replace X with
        (fmap f_pre_rmap (K.approx n) (K.approx n) (rmap'2pre_rmap rm))
    end.
    2: repeat rewrite <- fmap_comp.
    2: unfold compose; auto.
    destruct rm; simpl.
    apply exist_ext.
    extensionality l.
    unfold compose.
    destruct (x l); simpl; auto.
    (* YES *)
    destruct p; simpl.
    rewrite approx_K_approx; auto.
    (* PURE *)
    destruct p; simpl.
    rewrite approx_K_approx; auto.
  Qed.

  Instance Join_nat_rmap': Join (nat * rmap') := Join_prod _ (Join_equiv nat) _ _.
(*
Lemma fmap_p2p'_inj:
  forall p q,
        fmap SM.preds K.predicate K.predicate (@pred rmap ag_rmap) p =
        fmap SM.preds K.predicate K.predicate (@pred rmap ag_rmap) q ->
        p=q.
Proof.
  intros.
  destruct p as [p Vp]. destruct q as [q Vq].
  unfold fmap in *. unfold f_preds in *. simpl in *.
  inv H.
  f_equal.
  apply inj_pair2 in H2. unfold ffun_fmap, f_identity in *.
  unfold fmap, compose in H2.
  extensionality w.
 apply equal_f with w in H2. unfold fidentity_fmap in *.
  unfold p2p' in *. inv H2.
  unfold K.predicate in *.
  apply pred_ext'. intros [k o]. destruct o.
  apply equal_f with k in H0. rewrite H0; intuition.
Qed.
*)
  Lemma join_unsquash : forall phi1 phi2 phi3,
    join phi1 phi2 phi3 <->
    join (unsquash phi1) (unsquash phi2) (unsquash phi3).
  Proof.
    intros.
    unfold unsquash.
    rewrite KSa.join_unsquash.
    destruct (K.unsquash phi1) as [n f].
    destruct (K.unsquash phi2) as [n0 f0].
    destruct (K.unsquash phi3) as [n1 f1].
    simpl; intuition.
    destruct H; simpl in *; split; simpl; auto.
    intro l; spec H0 l.
    destruct f as [f ?].
    destruct f0 as [f0 ?].
    destruct f1 as [f1 ?].
    simpl in *.
    unfold compose.
    inv H0; simpl.
    constructor; auto.
    destruct p. simpl in *. constructor; auto. destruct p. simpl in *. constructor; auto.
    destruct p; simpl in *.
    constructor; auto.
    destruct p; simpl in *.
    constructor; auto.

    destruct H; simpl in *; split; simpl; auto.
    destruct f as [f ?].
    destruct f0 as [f0 ?].
    destruct f1 as [f1 ?].
    hnf in H0. simpl proj1_sig in H0.
    intro l; spec H0 l.
    simpl proj1_sig.
    clear - H0.
    forget (f l) as a; forget (f0 l) as b; forget (f1 l) as c.
    clear - H0.
    unfold res2resource in *. unfold res_fmap in *.
    destruct a as [ra | ra sha ka pa| ka pa]; try destruct pa as [? ?p];
    destruct b as [rb | rb shb kb pb|kb pb]; try destruct pb as [? ?p];
    destruct c as [rc | rc shc kc pc|kc pc]; try destruct pc as [? ?p];
    inv H0.
    + constructor; auto.
    + apply inj_pair2 in H8. subst p0. constructor; auto.
    + apply inj_pair2 in H8. subst p0. constructor; auto.
    + subst. apply inj_pair2 in H11. subst p1. apply inj_pair2 in H7; subst p0.
      constructor; auto.
    + subst ; apply inj_pair2 in H8. subst p1. apply inj_pair2 in H5. subst p0.
      constructor; auto.
Qed.

  Definition rmap_age1 (k:rmap) : option rmap :=
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.

  Definition rmap_unage (k:rmap) : rmap :=
    match unsquash k with
    | (n,x) => squash (S n, x)
    end.

  Lemma rmap_age1_knot_age1 :
    rmap_age1 = @age1 _ K.ageable_knot.
  Proof.
    extensionality x.
    unfold rmap_age1.
    rewrite  K.knot_age1.
    unfold unsquash, squash.
    case (K.unsquash x); simpl; intros.
    destruct n; auto.
    rewrite rmap'2pre_rmap2rmap'.
    f_equal.
  Qed.

  Lemma rmap_age1_eq: @age1 _ ag_rmap = rmap_age1.
  Proof.
   unfold age1. unfold ag_rmap; simpl; auto.
   rewrite rmap_age1_knot_age1; reflexivity.
  Qed.

  Lemma rmap_level_eq: @level rmap ag_rmap = fun x => fst (unsquash x).
  Proof.
    intros.
   extensionality x.  unfold level.  unfold ag_rmap.
   unfold KSa.K.ageable_knot. unfold unsquash.
   rewrite K.knot_level. destruct (K.unsquash x); simpl. auto.
  Qed.

  Lemma unevolve_identity_rmap :
   (* REMARK:  This may not be needed for anything, so for now it's removed
     from the Module Type *)
    forall w w':rmap, necR w w' -> identity w' -> identity w.
  Proof.
    intros.
    induction H; eauto.
    rewrite identity_unit_equiv in H0.
    rewrite identity_unit_equiv.
    red in H0. red.
    rewrite join_unsquash in H0.
    rewrite join_unsquash.
    hnf in H. unfold rmap, ag_rmap in H. rewrite <- rmap_age1_knot_age1 in H.
    unfold rmap_age1 in H.
   destruct (unsquash x).
   destruct n. inv H.
    assert (y = squash (n,r)).
    inv H; auto.
    subst y.
    rewrite unsquash_squash in H0.
    destruct H0; split;  simpl fst in *; simpl snd in *; try split; auto.
    intro l; spec H1 l.
    destruct r.
    simpl in *.
    unfold compose in *.
    destruct (x0 l); simpl in *.
    constructor; auto.
    inv H1; auto.
    inv H1. constructor; auto.
    constructor.
  Qed.

End Rmaps.
Local Close Scope nat_scope.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C P Q R Cprime Aprime Bprime : Universe, ((wd_ Q C /\ (wd_ P C /\ (wd_ Q R /\ (wd_ R B /\ (wd_ P Q /\ (wd_ Aprime Bprime /\ (wd_ C Cprime /\ (wd_ A Aprime /\ (wd_ B Bprime /\ (wd_ Aprime Q /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Q A /\ (wd_ P B /\ (wd_ R A /\ (wd_ Cprime Aprime /\ (wd_ Q Cprime /\ (col_ P Q Cprime /\ (col_ Aprime Cprime Q /\ (col_ Bprime Cprime P /\ (col_ Aprime Bprime P /\ (col_ Aprime Bprime Q /\ (col_ Aprime Bprime Cprime /\ (col_ R A B /\ (col_ Q A C /\ col_ P B C)))))))))))))))))))))))))) -> col_ Aprime Q P)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj5synthconj4 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 lv1) (mult lv0 Zero)).
Admitted.
QuickChick conj5synthconj4.


Require Import Bool.

Require Import Events.
Require Import Memory.
Require Import Coqlib.
Require Import Values.
Require Import Maps.
Require Import Integers.
Require Import AST.
Require Import Globalenvs.
Require Import Axioms.

Require Import mem_lemmas. (*needed for definition of mem_forward etc*)
Require Import semantics.
Require Import semantics_lemmas.
Require Import structured_injections.
Require Import reach.
Require Import mem_welldefined.
Require Import simulations.

Require Import effect_semantics. (*for specialization below*)

(** * Closed (Whole) Program Simulations *)

(** Closed simulations differ from the open simulations of [simulations.v] in
that they lack clauses for [at_external] and [after_external] (closed programs
do not call external functions). *)

(** Also, previously, we retained effects even in closed program simulations.
But this meant we had to paramterize over [EffectSemantics] (specialized to
CompCert memories), and not over just [CoreSemantics]. Since the paper, we have
updated closed simulations to remove the effects, which has made it possible to
use the same simulation structure in a wider variety of situations (e.g., to
relate semantics that may not use CompCert memories). *)

Module Wholeprog_sim. Section Wholeprog_sim.

Context {G1 C1 M1 G2 C2 M2 : Type}

(Sem1 : @CoreSemantics G1 C1 M1)
(Sem2 : @CoreSemantics G2 C2 M2)

(ge1 : G1)
(ge2 : G2)

(main : val).

Variable ge_inv : G1 -> G2 -> Prop.

Variable init_inv : meminj -> G1 -> list val -> M1 -> G2 -> list val -> M2 -> Prop.

Variable halt_inv : SM_Injection -> G1 -> val -> M1 -> G2 -> val -> M2 -> Prop.

Record Wholeprog_sim :=
{ core_data : Type
; match_state : core_data -> SM_Injection -> C1 -> M1 -> C2 -> M2 -> Prop
; core_ord : core_data -> core_data -> Prop
; core_ord_wf : well_founded core_ord
; genv_inv : ge_inv ge1 ge2
; core_initial :
    forall j c1 vals1 m1 vals2 m2,
    initial_core Sem1 ge1 main vals1 = Some c1 ->
    init_inv j ge1 vals1 m1 ge2 vals2 m2 ->
    exists mu cd c2,
      as_inj mu = j
      /\ initial_core Sem2 ge2 main vals2 = Some c2
      /\ match_state cd mu c1 m1 c2 m2
; core_diagram :
    forall st1 m1 st1' m1',
    corestep Sem1 ge1 st1 m1 st1' m1' ->
    forall cd st2 mu m2,
    match_state cd mu st1 m1 st2 m2 ->
    exists st2', exists m2', exists cd', exists mu',
    match_state cd' mu' st1' m1' st2' m2'
    /\ (corestep_plus Sem2 ge2 st2 m2 st2' m2'
        \/ (corestep_star Sem2 ge2 st2 m2 st2' m2' /\ core_ord cd' cd))
; core_halted :
    forall cd mu c1 m1 c2 m2 v1,
    match_state cd mu c1 m1 c2 m2 ->
    halted Sem1 c1 = Some v1 ->
    exists j v2,
       halt_inv j ge1 v1 m1 ge2 v2 m2
    /\ halted Sem2 c2 = Some v2 }.

End Wholeprog_sim.

End Wholeprog_sim.

Section CompCert_wholeprog_sim.

Context {F1 V1 C1 F2 V2 C2 : Type}

(Sem1 : @EffectSem (Genv.t F1 V1) C1)
(Sem2 : @EffectSem (Genv.t F2 V2) C2)

(ge1 : Genv.t F1 V1)
(ge2 : Genv.t F2 V2)

(main : val).

Definition cc_init_inv j (ge1 : Genv.t F1 V1) vals1 m1 (ge2 : Genv.t F2 V2) vals2 m2 :=
  Mem.inject j m1 m2 /\ Forall2 (val_inject j) vals1 vals2
  /\ meminj_preserves_globals ge1 j /\ globalfunction_ptr_inject ge1 j
  /\ mem_wd m2 /\ valid_genv ge2 m2 /\ Forall (fun v2 => val_valid v2 m2) vals2
  /\ mem_respects_readonly ge1 m1 /\ mem_respects_readonly ge2 m2.

Definition cc_halt_inv j (ge1 : Genv.t F1 V1) v1 m1 (ge2 : Genv.t F2 V2) v2 m2 :=
  meminj_preserves_globals ge1 (as_inj j)
  /\ val_inject (as_inj j) v1 v2
  /\ Mem.inject (as_inj j) m1 m2.

Definition CompCert_wholeprog_sim :=
  @Wholeprog_sim.Wholeprog_sim _ _ _ _ _ _
    Sem1 Sem2
    ge1 ge2
    main
    genvs_domain_eq
    cc_init_inv
    cc_halt_inv.

End CompCert_wholeprog_sim.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
Require Import Setoid.
Require Import ZArith.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.DePoolFunc.
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

(* Import SolidityNotations. *)
Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100.
(*Set Typeclasses Strict Resolution. *)
(* Set Typeclasses Debug.  *)
(* Set Typeclasses Unique Instances.
Unset Typeclasses Unique Solutions. *)

(* Existing Instance monadStateT.
Existing Instance monadStateStateT. *)
(* Module MultiSigWalletSpecSig := MultiSigWalletSpecSig XTypesSig StateMonadSig. *)

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Lib.CommonCommon.

(* Require Import MultiSigWallet.Proofs.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope solidity_scope.

(* Require Import MultiSigWallet.Specifications._validatelimit_inlineSpec.
Module _validatelimit_inlineSpec := _validatelimit_inlineSpec MultiSigWalletSpecSig.
Import _validatelimit_inlineSpec. *)

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Opaque Z.eqb Z.add Z.sub Z.div Z.mul hmapLookup hmapInsert Z.ltb Z.geb Z.leb Z.gtb Z.modulo deleteListPair.

(* Opaque tvm_accept DePoolContract_Ф_checkPureDePoolBalance RoundsBase_Ф_getRound1. *)

Lemma ifSimpleState: forall X (b: bool) (f g: Ledger -> X * Ledger),
(if b then SimpleState f else SimpleState g ) =
SimpleState (if b then f else  g).
Proof.
  intros. destruct b; auto.
Qed.

Lemma ifFunApply: forall X (b: bool) (f g: Ledger -> X * Ledger) l,
(if b then f else  g ) l =
(if b then f l else g l).
Proof.
  intros. destruct b; auto.
Qed.

Lemma fstImplies : forall  X Y T (f: X*T) (g: X -> Y)  ,  (let (x, _) := f in g x) = g (fst f).
Proof.
  intros.
  destruct f; auto.
Qed.

Lemma sndImplies : forall  X Y T (f: X*T) (g: T -> Y)  ,  (let (_, t) := f in g t) = g (snd f).
Proof.
  intros.
  destruct f; auto.
Qed.

Lemma fstsndImplies : forall  X Y T (f: X*T) (g: X -> T -> Y)  ,  (let (x, t) := f in g x t) = g (fst f) (snd f).
Proof.
  intros.
  destruct f; auto.
Qed.

Ltac pr_numgoals := let n := numgoals in idtac "There are" n "goals".

(*
function cancelWithdrawal() public onlyInternalMessage {
        if (m_poolClosed) {
            return _sendError(STATUS_DEPOOL_CLOSED, 0);
        }

        optional(DePoolLib.Participant) optParticipant = fetchParticipant(msg.sender);
        if (!optParticipant.hasValue()) {
            return _sendError(STATUS_NO_PARTICIPANT, 0);
        }
        DePoolLib.Participant participant = optParticipant.get();

        participant.reinvest = true;
        participant.withdrawValue = 0;
        _setOrDeleteParticipant(msg.sender, participant);
        sendAcceptAndReturnChange();
    }
*)

Lemma DePoolContract_Ф_cancelWithdrawal_exec : forall (l : Ledger),
let sender := eval_state msg_sender l in
let isInternalMessage : bool := negb (sender =? 0) in
(* let dePool := Ledger_ι_DePoolContract l in *)
let isPoolClosed : bool := eval_state (↑ε12 DePoolContract_ι_m_poolClosed) l in
let optParticipant := eval_state (↓ ParticipantBase_Ф_fetchParticipant sender) l in
let isEmptyParticipant : bool := negb (isSome optParticipant) (* match optParticipant with | None => true | _ => false end *) in
let participant := maybeGet optParticipant (* match optParticipant with | None => default | Some p => p end *) in
let newParticipant := {$ participant with (DePoolLib_ι_Participant_ι_reinvest, true) $} in
let l_set := exec_state (↓ ParticipantBase_Ф__setOrDeleteParticipant sender newParticipant) l in
let l_send := exec_state (↓ DePoolContract_Ф_sendAcceptAndReturnChange) l_set in
let statusDepoolClosed := eval_state (↑12 ε DePoolContract_ι_STATUS_DEPOOL_CLOSED) l in
let statusNoParticipant := eval_state (↑12 ε DePoolContract_ι_STATUS_NO_PARTICIPANT) l in
exec_state DePoolContract_Ф_cancelWithdrawal' l =

if isInternalMessage then
    if isPoolClosed then exec_state (↓ DePoolContract_Ф__sendError statusDepoolClosed 0) l else
        if isEmptyParticipant then exec_state (↓ DePoolContract_Ф__sendError statusNoParticipant 0) l
        else l_send
else l.
Proof.
  intros.
  destruct l.
  destruct Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
  Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
  Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
  Ledger_ι_VMState, Ledger_ι_LocalState.

  compute. idtac.

  Time  repeat (

  time match goal with

    | |- ?x =>
      match x with

      | context [if ?b then _ else _] =>  idtac "if..." b;
                                          repeat rewrite ifSimpleState ;
                                          repeat rewrite ifFunApply ;
                                            (* compute ; *)
                                            (* let rem := fresh "rem" in  *)
                                            (* set (rem:= b) ;  *)
                                          case_eq b ;
                                          simpl ; intros
       | context [let (x, t) := ?f in @?g x t] => idtac "let..." f g;
                                                 replace (let (x, t) := f in g x t) with (g (fst f) (snd f))
                                                          by (symmetry; apply fstsndImplies) ;
                                                 destruct (snd f);
                                                 simpl
      | _ =>  idtac "solving..." x; tryif solve [auto] then idtac "solved" else idtac "not solved"
      end

  end) .

  all: pr_numgoals.

Abort.

Lemma DePoolContract_Ф_cancelWithdrawal_eval : forall (l : Ledger),
let sender := eval_state msg_sender l in
let isInternalMessage : bool := negb (sender =? 0) in
let isPoolClosed : bool := eval_state (↑ε12 DePoolContract_ι_m_poolClosed) l in
let optParticipant := eval_state (↓ ParticipantBase_Ф_fetchParticipant sender) l in
let isEmptyParticipant : bool := negb (isSome optParticipant) (* match optParticipant with | None => true | _ => false end *) in

eval_state DePoolContract_Ф_cancelWithdrawal' l =

if isInternalMessage then
    if isPoolClosed then Value (Error I) else
        if isEmptyParticipant then Value (Error I)
    else Value (Value I)
else  Error (eval_state ( ↑7 ε Errors_ι_IS_EXT_MSG) l).
Proof.

  intros.
  destruct l.
  destruct Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
  Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
  Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
  Ledger_ι_VMState, Ledger_ι_LocalState.

  compute. idtac.

  Time  repeat (

  time match goal with

    | |- ?x =>
      match x with

      | context [if ?b then _ else _] =>  idtac "if..." b;
                                          repeat rewrite ifSimpleState ;
                                          repeat rewrite ifFunApply ;
                                            (* compute ; *)
                                            (* let rem := fresh "rem" in  *)
                                            (* set (rem:= b) ;  *)
                                          case_eq b ;
                                          simpl ; intros
       | context [let (x, t) := ?f in @?g x t] => idtac "let..." f g;
                                                 replace (let (x, t) := f in g x t) with (g (fst f) (snd f))
                                                          by (symmetry; apply fstsndImplies) ;
                                                 destruct (snd f);
                                                 simpl
      | _ =>  idtac "solving..." x; tryif solve [auto] then idtac "solved" else idtac "not solved"
      end

  end) .

  all: pr_numgoals.

Abort.


Require Import ZArith List String Omega.
Require Import  Vellvm.LLVMAst Vellvm.Util.
Require Import Vellvm.StepSemantics.
Import ListNotations.

Set Implicit Arguments.
Set Contextual Implicit.

(* SAZ: This file is deprecated. *)

Inductive Addr :=
| Null
| Ptr (n:nat)
.

Module A : Vellvm.LLVMIO.ADDR with Definition addr := Addr.
  Definition addr := Addr.
  Definition null := Null.
End A.

Module SS := StepSemantics.StepSemantics(A).
Export SS.
Export SS.DV.

Definition memory := list dvalue.

Definition mem_step {X} (e:IO X) (m:memory) : (IO X) + (list dvalue * X) :=
  match e in IO Y return (IO Y) + (list dvalue * Y) with
  | Alloca t =>
    inr  ((m ++ [undef t])%list,
          DVALUE_Addr (Ptr (List.length m)))

  | Load t a =>
    inr (m,
         match a with
         | DVALUE_Addr (Ptr n) => nth_default (undef t) m n
         | _ => undef t
         end)

  | Store a v =>
    inr (
        match a with
        | DVALUE_Addr (Ptr n) => replace m n v
        | _ => m   (* TODO: should fail! *)
        end,
        ())

  | GEP t a vs => inl (GEP t a vs) (* TODO: GEP semantics *)

  | ItoP t i => inl (ItoP t i) (* TODO: ItoP semantics *)

  | PtoI t a => inl (PtoI t a) (* TODO: ItoP semantics *)

  | Call t f args  => inl (Call t f args)

  | DeclareFun f =>
    (* TODO: should check for re-declarations and maintain that state in the memory *)
    inr (m,
         DVALUE_FunPtr f)
  end.

(*
 memory -> Trace () -> Trace () -> Prop
*)

CoFixpoint memD {X} (m:memory) (d:Trace X) : Trace X :=
  match d with
  | Trace.Tau d'            => Trace.Tau (memD m d')
  | Trace.Vis _ io k =>
    match mem_step io m with
    | inr (m', v) => Trace.Tau (memD m' (k v))
    | inl e => Trace.Vis io k
    end
  | Trace.Ret x => d
  | Trace.Err x => d
  end.

Definition run_with_memory prog : option (Trace dvalue) :=
  let scfg := AstLib.modul_of_toplevel_entities prog in
  match CFG.mcfg_of_modul scfg with
  | None => None
  | Some mcfg =>
    mret
      (memD []
      ('s <- SS.init_state mcfg "main";
         SS.step_sem mcfg (SS.Step s)))
  end.

(*
Fixpoint MemDFin (m:memory) (d:Trace ()) (steps:nat) : option memory :=
  match steps with
  | O => None
  | S x =>
    match d with
    | Vis (Fin d) => Some m
    | Vis (Err s) => None
    | Tau _ d' => MemDFin m d' x
    | Vis (Eff e)  =>
      match mem_step e m with
      | inr (m', v, k) => MemDFin m' (k v) x
      | inl _ => None
      end
    end
  end%N.
*)

(*
Previous bug:
Fixpoint MemDFin {A} (memory:mtype) (d:Obs A) (steps:nat) : option mtype :=
  match steps with
  | O => None
  | S x =>
    match d with
    | Ret a => None
    | Fin d => Some memory
    | Err s => None
    | Tau d' => MemDFin memory d' x
    | Eff (Alloca t k)  => MemDFin (memory ++ [undef])%list (k (DVALUE_Addr (pred (List.length memory)))) x
    | Eff (Load a k)    => MemDFin memory (k (nth_default undef memory a)) x
    | Eff (Store a v k) => MemDFin (replace memory a v) k x
    | Eff (Call d ds k)    => None
    end
  end%N.
*)


Require Export List. Export ListNotations.
Require Export ZArith.
Local Open Scope Z_scope.
Require Export Integers.
Require Export floyd.sublist.

Definition Nk := 8. (* number of words in key *)
Definition Nr := 14. (* number of cipher rounds *)
Definition Nb := 4. (* number of words in a block (state) *)

(* arr: list of 4 bytes *)
Definition get_uint32_le (arr: list Z) (i: Z) : int :=
 (Int.or (Int.or (Int.or
            (Int.repr (Znth  i    arr 0))
   (Int.shl (Int.repr (Znth (i+1) arr 0)) (Int.repr  8)))
   (Int.shl (Int.repr (Znth (i+2) arr 0)) (Int.repr 16)))
   (Int.shl (Int.repr (Znth (i+3) arr 0)) (Int.repr 24))).

(* outputs a list of 4 bytes *)
Definition put_uint32_le (x : int) : list int :=
  [ (Int.and           x                (Int.repr 255));
    (Int.and (Int.shru x (Int.repr  8)) (Int.repr 255));
    (Int.and (Int.shru x (Int.repr 16)) (Int.repr 255));
    (Int.and (Int.shru x (Int.repr 24)) (Int.repr 255)) ].

Definition byte0 (x : int) : Z :=
  (Z.land (Int.unsigned x) (Int.unsigned (Int.repr 255))).
Definition byte1 (x : int) : Z :=
  (Z.land (Int.unsigned (Int.shru x (Int.repr 8))) (Int.unsigned (Int.repr 255))).
Definition byte2 (x : int) : Z :=
  (Z.land (Int.unsigned (Int.shru x (Int.repr 16))) (Int.unsigned (Int.repr 255))).
Definition byte3 (x : int) : Z :=
  (Z.land (Int.unsigned (Int.shru x (Int.repr 24))) (Int.unsigned (Int.repr 255))).


Require Import FloydSeq.base2.
Require Import FloydSeq.semax_tactics.
Require Import CSplit.strong.
Import ListNotations.

(* Unlike unfold_Ssequence in veric/SeparationLogic.v, unfold_seq preserves Sfor and Swhile.
   In fact, it folds them even if they were not explicitly written in the input.
   Note that we don't treat Sdowhile, because there are no floyd tactics for it, and because
   it would result in 2198 cases when unfold_seq is printed. *)
Fixpoint unfold_seq c : list statement :=
  match c with
  | Sloop (Ssequence (Sifthenelse e Sskip Sbreak) s) Sskip =>
    [Swhile e s]
  | Ssequence s1 (Sloop (Ssequence (Sifthenelse e2 Sskip Sbreak) s3) s4) =>
    (* TODO check if this matches cases we don't want it to match and if so, check that the loop
       iteration variable of s1 is the same as in the increment in s4, but then we'll exclude
       multi-statement for loop initialisations *)
    [Sfor s1 e2 s3 s4]
  | Ssequence c1 c2 => unfold_seq c1 ++ unfold_seq c2
  | _ => [c]
  end.

Fixpoint fold_seq lc : statement :=
  match lc with
  | nil => Sskip
  | [c1] => c1
  | c :: lc0 => Ssequence c (fold_seq lc0)
  end.

Lemma flat_map_app: forall {A B: Type} (f: A -> list B) l1 l2,
  flat_map f l1 ++ flat_map f l2 = flat_map f (l1 ++ l2).
Proof.
  intros. induction l1.
  - reflexivity.
  - simpl. rewrite <- app_assoc. congruence.
Qed.

Lemma unfold_Ssequence_idempotent: forall c,
  flat_map unfold_Ssequence (unfold_Ssequence c) = unfold_Ssequence c.
Proof.
  intro c. induction c; try reflexivity.
  simpl. rewrite <- flat_map_app. congruence.
Qed.

Lemma flat_map_unfold_Ssequence_idempotent: forall ls,
  flat_map unfold_Ssequence (flat_map unfold_Ssequence ls) = flat_map unfold_Ssequence ls.
Proof.
  intro. induction ls.
  - reflexivity.
  - simpl. rewrite <- flat_map_app. f_equal; [ | assumption ].
    apply unfold_Ssequence_idempotent.
Qed.

Lemma unfold_seq_to_unfold_Ssequence: forall cs,
  unfold_Ssequence cs = flat_map unfold_Ssequence (unfold_seq cs).
Proof.
  intro cs. induction cs; try reflexivity.
  - simpl. rewrite IHcs1, IHcs2. rewrite flat_map_app.
    destruct cs2; try reflexivity;
    try rewrite flat_map_unfold_Ssequence_idempotent; try reflexivity.
    destruct cs2_1; try reflexivity;
    try rewrite flat_map_unfold_Ssequence_idempotent; try reflexivity.
    destruct cs2_1_1; try reflexivity;
    try rewrite flat_map_unfold_Ssequence_idempotent; try reflexivity.
    destruct cs2_1_1_1; try reflexivity;
    try rewrite flat_map_unfold_Ssequence_idempotent; try reflexivity.
    destruct cs2_1_1_2; try reflexivity;
    try rewrite flat_map_unfold_Ssequence_idempotent; try reflexivity.
    rewrite <- flat_map_app.
    simpl. rewrite app_nil_r. f_equal; [ symmetry; assumption | ].
    destruct cs2_2; reflexivity.
  - simpl.
    destruct cs1; try reflexivity.
    destruct cs1_1; try reflexivity.
    destruct cs1_1_1; try reflexivity.
    destruct cs1_1_2; try reflexivity.
    destruct cs2; reflexivity.
Qed.

Lemma semax_unfold_seq {Espec: OracleKind} {CS: compspecs} : forall c1 c2,
  unfold_seq c1 = unfold_seq c2 ->
  forall P Q Delta, semax Delta P c1 Q -> semax Delta P c2 Q.
Proof.
  intros. eapply semax_unfold_Ssequence; [ | eassumption ].
  do 2 rewrite unfold_seq_to_unfold_Ssequence.
  congruence.
Qed.

Ltac reassoc_seq_raw :=
  cbv [Sfor Swhile Sdowhile];
  match goal with
  | |- semax _ _ ?cs _ =>
    let cs' := eval cbv [unfold_seq fold_seq app]
               in (fold_seq (unfold_seq cs)) in
    apply (semax_unfold_seq cs' cs eq_refl)
  end.

Ltac reassoc_seq := unfold_abbrev'; reassoc_seq_raw; abbreviate_semax.

(* if size does not divide (Zlength l), the last chunk will be smaller *)
Fixpoint partition {T: Type} (firstSize size: Z) (l: list T) : list (list T) :=
  match l with
  | h :: t => if firstSize =? 0 then
      match partition (size-1) size t with
      | wip :: res => nil :: (h :: wip) :: res
      | nil => nil :: [h] :: nil
      end
    else
      match partition (firstSize-1) size t with
      | wip :: res => (h :: wip) :: res
      | nil => [h] :: nil
      end
  | nil => nil
  end.

Definition reassoc_into_chunks (cs: statement) (chunksize: Z) : statement :=
  fold_seq (map fold_seq (partition chunksize chunksize (unfold_seq cs))).

(* requires that unfold_abbrev' was already invoked *)
Ltac reassoc_seq_chunks chunksize :=
  cbv [Sfor Swhile Sdowhile];
  match goal with
  | |- semax _ _ ?cs _ => let cs' := eval cbv
       [reassoc_into_chunks fold_seq map partition unfold_seq Zlength Zlength_aux Z.succ Z.add
        Pos.add Pos.succ Pos.add_carry app Z.eqb Pos.eqb Z.sub Z.opp Z.pos_sub
        Z.succ_double Z.pred_double Z.double Pos.pred_double]
       in (reassoc_into_chunks cs chunksize)
       in apply (semax_unfold_seq cs' cs eq_refl)
  end.

(* This tactic calculates the effect of reassoc_seq, without any proofs.
  It's useful with the find_statement_in_body  tactic *)
Ltac reassociate_stmt S :=
 lazymatch S with
 | Ssequence (Ssequence ?S1 ?S2) ?S3 =>
       reassociate_stmt (Ssequence S1 (Ssequence S2 S3))
 | Ssequence ?S1 ?S2 =>
       let S1' := reassociate_stmt S1 in
       let S2' := reassociate_stmt S2 in
       let S' := constr:(Ssequence S1' S2') in
       match S1' with (Ssequence _ _) => reassociate_stmt S' | _ => S' end
 | Sloop ?S1 ?S2 =>
       let S1' := reassociate_stmt S1 in
       let S2' := reassociate_stmt S2 in
       let S' := constr:(Sloop S1' S2') in S'
 | Sifthenelse ?E ?S1 ?S2 =>
       let S1' := reassociate_stmt S1 in
       let S2' := reassociate_stmt S2 in
       let S' := constr:(Sifthenelse E S1' S2') in S'
 | Sswitch ?E ?LS =>
       let LS' := reassociate_stmt_ls LS in
       let S' := constr:(Sswitch E LS') in S'
 | _ => S
 end
with reassociate_stmt_ls LS :=
 match S with
 | LSnil => let S' := constr:(LSnil) in S'
 | LScons ?L ?S1 ?LS1 =>
       let S1' := reassociate_stmt S1 in
       let LS1' := reassociate_stmt LS1 in
       let LS' := constr:(LScons L S1' LS1') in LS'
 end.


From HoTT Require Import Basics.
From HoTT Require Import Categories.
From HoTT Require Import Spaces.Finite.
Require Import Misc.
Require Import Limits.Graph.
Require Import Limits.Product.
Require Import Limits.Terminal.
Require Import Limits.Pullback.
Require Import Limits.Extension.
Require Import Slice.Misc.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope morphism_scope.

Definition IsCartesian (C : PreCategory) :=
  Terminal C * forall(a b : object C), Product a b.

Arguments get {A n} v i.
Definition UnbiasedProductGr {C : PreCategory} {n : nat} :
  Vect (object C) n -> Graph C (Fin n) Empty
  := fun v =>
       {| gr_vertex := get v
       ;  gr_edges  := fun e => Empty_ind _ e
       |}.
Definition UnbiasedProduct {C : PreCategory} (P : IsCartesian C) {n : nat}
  (v : Vect (object C) n) : Limit (UnbiasedProductGr v).
Proof. destruct P. apply AllProductsFromProduct; assumption. Qed.

Definition IsLocallyCartesian (C : PreCategory) :=
  forall(a : object C), IsCartesian (C / a).

Module LocallyCartesianPullbacks.
  Section LCPullbacks.
    Import Slice.
    Context {C : PreCategory}.
    Context {a1 a2 b : object C}.
    Context (m1 : morphism C a1 b).
    Context (m2 : morphism C a2 b).
    Definition PbGr := PullbackGr m1 m2.
    Definition ProdGr := ProductGr (Build_SliceObject m1) (Build_SliceObject m2).

    Definition LCConeFromPullback : Cone PbGr -> Cone ProdGr.
    Proof.
      intro cn. srapply mkCone; [ exact (Build_SliceObject (cn_side cn f3)) | idtac | empty_ind' ].
      intro n; destruct2 n.
      - refine (Build_SliceMorphism' (Build_SliceObject (cn_side cn f3))
                                     (Build_SliceObject m2) _ _). apply (cn_comm cn fin1).
      - refine (Build_SliceMorphism' (Build_SliceObject (cn_side cn f3))
                                     (Build_SliceObject m1) _ _). apply (cn_comm cn fin2).
    Defined.
    Definition PullbackConeFromLCCone : Cone ProdGr -> Cone PbGr.
    Proof.
      intro cn. srapply mkCone; [ exact (s (cn_top cn)) | idtac | idtac ].
      - intro n; destruct3 n; [ exact (f (cn_top cn))
                              | exact (m (cn_side cn fin2))
                              | exact (m (cn_side cn fin1))].
      - intro n; destruct2 n; unfold gr_edge; simpl.
        + apply (slice_m_comm (cn_side cn fin1)).
        + apply (slice_m_comm (cn_side cn fin2)).
    Defined.
    Definition AdjunctPullbackLCConeL (c1 : Cone PbGr) (c2 : Cone ProdGr) :
      ConeMorphism (LCConeFromPullback c1) c2 ->
      ConeMorphism c1 (PullbackConeFromLCCone c2).
    Proof.
      intro mph. srapply mkCnMph; [ exact (m (cnmph_mph mph)) | idtac ].
      intro n; destruct3 n.
      - apply (slice_m_comm (cnmph_mph mph)).
      - apply (ap m (cnmph_comm mph fin2)).
      - apply (ap m (cnmph_comm mph fin1)).
    Defined.
    Definition AdjunctPullbackLCConeMorphism (c1 : Cone PbGr) (c2 : Cone ProdGr) :
      ConeMorphism c1 (PullbackConeFromLCCone c2) ->
      morphism (C/b) (cn_top (LCConeFromPullback c1)) (cn_top c2).
    Proof.
      intro mph. apply (Build_SliceMorphism'
                          (Build_SliceObject (cn_side c1 f3)) (cn_top c2) (cnmph_mph mph)).
      simpl. apply (cnmph_comm mph f3).
    Defined.
    Definition AdjunctPullbackLCConeR (c1 : Cone PbGr) (c2 : Cone ProdGr) :
      ConeMorphism c1 (PullbackConeFromLCCone c2) ->
      ConeMorphism (LCConeFromPullback c1) c2.
    Proof.
      intro mph. srapply mkCnMph; [ exact (AdjunctPullbackLCConeMorphism mph) | idtac ].
      intro n; destruct2 n; apply slice_m_injective; simpl.
      - apply (cnmph_comm mph f2).
      - apply (cnmph_comm mph f1).
    Defined.
    Theorem PullbackFromLocalProduct :
      Product (Build_SliceObject m1) (Build_SliceObject m2) -> Pullback m1 m2.
    Proof.
      intro prod. srapply mkLim; [ exact (PullbackConeFromLCCone (lim_cone prod)) | idtac | idtac ].
      - intro c. pose (cn := LCConeFromPullback c). apply AdjunctPullbackLCConeL. apply (lim_ex prod).
      - intros c m m'.
        pose (mph  := AdjunctPullbackLCConeR m). pose (mph' := AdjunctPullbackLCConeR m').
        assert (CommaCategory.g (AdjunctPullbackLCConeMorphism m)
                = CommaCategory.g (AdjunctPullbackLCConeMorphism m')) as Heq.
        { f_ap. exact (lim_uniq prod _ mph mph'). } apply Heq.
    Defined.
  End LCPullbacks.
End LocallyCartesianPullbacks.

Theorem LocallyCartesianPullbacks {C : PreCategory} (LCC : IsLocallyCartesian C)
        {a b c : object C} (f : morphism C a c) (g : morphism C b c) :
  exists(P : Pullback f g),
    fprod_obj P = Slice.s (prod_obj (snd (LCC c) (Build_SliceObject f) (Build_SliceObject g))).
Proof.
  exists(LocallyCartesianPullbacks.PullbackFromLocalProduct (snd (LCC c)
                                                            (Build_SliceObject f)
                                                            (Build_SliceObject g))).
  reflexivity.
Qed.

Theorem LocallyCartesianHasPullbacks {C : PreCategory} :
  IsLocallyCartesian C -> AllPullbacks C.
Proof.
  intro LCC. intros x y z f g. apply LocallyCartesianPullbacks. assumption.
Defined.

Module LocallyCartesianFromPullbacks.
  Section LCPullbacks.
    Import Slice.
    Context {C : PreCategory}.
    Context {c : object C}.
    Context {a b : object (C/c)}.

    Let ProdGr := ProductGr a b.
    Let PbGr := PullbackGr (f a) (f b).

    Definition PullbackConeFromLCCone : Cone ProdGr -> Cone PbGr.
    Proof.
      intro cn. srapply mkCone.
      - exact (s (cn_top cn)).
      - intro n; destruct3 n.
        + exact (f (cn_top cn)).
        + apply m. exact (cn_side cn fin2).
        + apply m. exact (cn_side cn fin1).
      - intro n; destruct2 n.
        + apply (slice_m_comm (cn_side cn fin1)).
        + apply (slice_m_comm (cn_side cn fin2)).
    Defined.
    Definition LCConeFromPullback : Cone PbGr -> Cone ProdGr.
    Proof.
      intro cn. srapply mkCone; [ exact (Build_SliceObject (cn_side cn f3)) | idtac | empty_ind' ].
      intro n; destruct2 n.
      - apply (Build_SliceMorphism' (Build_SliceObject (cn_side cn f3)) b (cn_side cn f2)). simpl.
        apply (cn_comm cn fin1).
      - apply (Build_SliceMorphism' (Build_SliceObject (cn_side cn f3)) a (cn_side cn f1)). simpl.
        apply (cn_comm cn fin2).
    Defined.
    Definition AdjunctPullbackLCConeL (c1 : Cone ProdGr) (c2 : Cone PbGr) :
      ConeMorphism (PullbackConeFromLCCone c1) c2 ->
      ConeMorphism c1 (LCConeFromPullback c2).
    Proof.
      intro mph. srapply mkCnMph.
      - apply (Build_SliceMorphism' (cn_top c1) (cn_top (LCConeFromPullback c2)) (cnmph_mph mph)).
        simpl. apply (cnmph_comm mph f3).
      - intro n; destruct2 n; apply slice_m_injective; simpl.
        + apply (cnmph_comm mph f2).
        + apply (cnmph_comm mph f1).
    Defined.
    Definition AdjunctPullbackLCConeR (c1 : Cone ProdGr) (c2 : Cone PbGr) :
      ConeMorphism c1 (LCConeFromPullback c2) ->
      ConeMorphism (PullbackConeFromLCCone c1) c2.
    Proof.
      intro mph. srapply mkCnMph; [ exact (m (cnmph_mph mph)) | idtac ].
      intro n; destruct3 n.
      - apply (slice_m_comm (cnmph_mph mph)).
      - apply (ap m (cnmph_comm mph fin2)).
      - apply (ap m (cnmph_comm mph fin1)).
    Defined.
    Lemma LocalProductFromPullback : Pullback (f a) (f b) -> Product a b.
    Proof.
      intro pb. srapply mkLim.
      - exact (LCConeFromPullback (lim_cone pb)).
      - intro cn. apply AdjunctPullbackLCConeL. apply (lim_ex pb).
      - intros cn m1 m2.
        pose (mph1 := AdjunctPullbackLCConeR m1). pose (mph2 := AdjunctPullbackLCConeR m2).
        apply slice_m_injective. apply (lim_uniq pb _ mph1 mph2).
    Qed.

  End LCPullbacks.
End LocallyCartesianFromPullbacks.

Theorem LocallyCartesianIfPullbacks {C : PreCategory} :
  AllPullbacks C -> IsLocallyCartesian C.
Proof.
  intro P. intro x. split.
  - srapply mkLim.
    + srapply mkCone; [ exact (Build_SliceObject (identity x)) | empty_ind' | empty_ind' ].
    + intro c. srapply mkCnMph; [ simpl | empty_ind' ].
      apply (Build_SliceMorphism' (cn_top c) (Build_SliceObject (identity x)) (Slice.f (cn_top c))).
      apply left_identity.
    + intros c m1 m2. apply slice_m_injective.
      rewrite <- (left_identity C _ _ (Slice.m (cnmph_mph m1))).
      rewrite <- (left_identity C _ _ (Slice.m (cnmph_mph m2))).
      rewrite (slice_m_comm (cnmph_mph m1)). rewrite (slice_m_comm (cnmph_mph m2)).
      reflexivity.
  - intros a b. apply LocallyCartesianFromPullbacks.LocalProductFromPullback. apply P.
Qed.

Theorem LCC_CompleteIffTerminal {C : PreCategory} (LCC : IsLocallyCartesian C) :
  Terminal C <-> HasFiniteLimits C.
Proof.
  split; intro H.
  - apply AllLimitsFromPullbackAndTerminal; try assumption.
    apply LocallyCartesianHasPullbacks. exact LCC.
  - exact (H 0%nat 0%nat (TerminalGr C)).
Qed.

Module LCCHasLocalPullbacks.
  Section LCCHasLocalPullbacks.
    Context `{Funext}.
    Context {C : PreCategory}.
    Context (LCC : IsLocallyCartesian C).
    Context {Y : object C}.
    Context {x y z : object (C/Y)}.
    Context (f : morphism (C/Y) x z) (g : morphism (C/Y) y z).

    Definition X : object C := Slice.s z.
    Definition f_X : object (C/X) := Build_SliceObject (Slice.m f).
    Definition g_X : object (C/X) := Build_SliceObject (Slice.m g).
    Definition fXg : Product f_X g_X := snd (LCC X) f_X g_X.

    Definition PbCone : Cone (ProductGr f_X g_X) -> Cone (PullbackGr f g).
    Proof.
      intro cn. srapply mkCone.
      - srapply Build_SliceObject; [ exact (Slice.s (cn_top cn)) | ].
        exact (Slice.f z o Slice.m f o Slice.m (cn_side cn fin1)).
      - intro n; destruct3 n.
        + srapply Build_SliceMorphism; [ exact (Slice.m f o Slice.m (cn_side cn fin1)) | ].
          rewrite <- associativity. reflexivity.
        + srapply Build_SliceMorphism; [ exact (Slice.m (cn_side cn fin2)) | ].
          simpl. rewrite associativity. change (Slice.m f) with (Slice.f f_X).
          rewrite (slice_m_comm (cn_side cn fin1)). rewrite <- (slice_m_comm (cn_side cn fin2)).
          rewrite <- associativity. change (Slice.f g_X) with (Slice.m g).
          rewrite (slice_m_comm g). reflexivity.
        + srapply Build_SliceMorphism; [ exact (Slice.m (cn_side cn fin1)) | ]. simpl.
          rewrite <- (slice_m_comm f). reflexivity.
      - intro n; destruct2 n; apply slice_m_injective; simpl; try reflexivity.
        change (gr_edge (PullbackGr f g) (inr tt)) with g.
        change (Slice.m f) with (Slice.f f_X). rewrite (slice_m_comm (cn_side cn fin1)).
        rewrite <- (slice_m_comm (cn_side cn fin2)). reflexivity.
    Defined.
    Definition PdCone : Cone (PullbackGr f g) -> Cone (ProductGr f_X g_X).
    Proof.
      intro cn. srapply mkCone.
      - srapply Build_SliceObject; [ exact (Slice.s (cn_top cn)) | ].
        exact (Slice.f f_X o Slice.m (cn_side cn f1)).
      - intro n; destruct2 n.
        + srapply Build_SliceMorphism; [ exact (Slice.m (cn_side cn f2)) | ].
          simpl. rewrite <- slice_m_comp. rewrite (cn_comm cn fin1).
          rewrite <- (cn_comm cn fin2). reflexivity.
        + srapply Build_SliceMorphism; [ exact (Slice.m (cn_side cn f1)) | ].
          reflexivity.
      - intro n. empty_ind.
    Defined.

    Definition ConeMorphismPbToPd c1 c2 :
      ConeMorphism (PdCone c1) c2 ->
      ConeMorphism c1 (PbCone c2).
    Proof.
      intro mph. srapply mkCnMph.
      - srapply Build_SliceMorphism; [ exact (Slice.m (cnmph_mph mph)) | ].
        simpl. rewrite slice_m_comm. rewrite associativity.
        rewrite <- (slice_m_comp (cnmph_mph mph) (cn_side c2 fin1)).
        rewrite cnmph_comm. simpl. rewrite slice_m_comm. reflexivity.
      - intro n; apply slice_m_injective; rewrite slice_m_comp; destruct3 n.
        + rewrite associativity. rewrite <- (slice_m_comp (cnmph_mph mph) (cn_side c2 fin1)).
          rewrite cnmph_comm. simpl. rewrite <- slice_m_comp. rewrite (cn_comm c1 fin2).
          reflexivity.
        + rewrite <- (slice_m_comp (cnmph_mph mph) (cn_side c2 fin2)).
          rewrite cnmph_comm. reflexivity.
        + rewrite <- (slice_m_comp (cnmph_mph mph) (cn_side c2 fin1)).
          rewrite cnmph_comm. reflexivity.
    Defined.
    Definition ConeMorphismPdToPb c1 c2 :
      ConeMorphism c1 (PbCone c2) ->
      ConeMorphism (PdCone c1) c2.
    Proof.
      intro mph. srapply mkCnMph.
      - srapply Build_SliceMorphism; [ exact (Slice.m (cnmph_mph mph)) | ].
        simpl. rewrite <- (slice_m_comm (cn_side c2 fin2)). simpl.
        rewrite <- (slice_m_comp (cn_side c1 f1) f).
        rewrite (cn_comm c1 fin2). rewrite <- (cn_comm c1 fin1). rewrite slice_m_comp.
        change (gr_edge (PullbackGr f g) fin1) with g.
        rewrite <- (cnmph_comm mph f2). rewrite slice_m_comp. apply associativity.
      - intro n; apply slice_m_injective; rewrite slice_m_comp; destruct2 n.
        + rewrite <- (cnmph_comm mph f2). rewrite slice_m_comp. reflexivity.
        + rewrite <- (cnmph_comm mph f1). rewrite slice_m_comp. reflexivity.
    Defined.

    Definition PbLimit : Limit (PullbackGr f g).
    Proof.
      srapply mkLim; [ exact (PbCone (lim_cone fXg)) | | ].
      - intro cn. apply ConeMorphismPbToPd. apply lim_ex.
      - intros c m1 m2.
        pose (mph1 := ConeMorphismPdToPb m1). pose (mph2 := ConeMorphismPdToPb m2).
        pose (Huniq := lim_uniq fXg _ mph1 mph2). apply slice_m_injective.
        change (Slice.m (cnmph_mph m1)) with (Slice.m (cnmph_mph mph1)).
        change (Slice.m (cnmph_mph m2)) with (Slice.m (cnmph_mph mph2)).
        exact (ap Slice.m Huniq).
    Defined.
  End LCCHasLocalPullbacks.
End LCCHasLocalPullbacks.

Theorem LCCHasLocalPullbacks {C : PreCategory} (LCC : IsLocallyCartesian C) :
  forall(Y : object C), AllPullbacks (C/Y).
Proof.
  intros Y a b c f g. apply LCCHasLocalPullbacks.PbLimit. exact LCC.
Defined.
Arguments LCCHasLocalPullbacks [C] (LCC Y).


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrbool.
Require Import ssrnat.
Require Import part.
Require Import znat.
Require Import hubcap.
Require Import present.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Lemma exclude5 : reducibility -> excluded_arity 5.
Proof.
move=> Hred; Presentation.
Pcase L0_1: s[1] <= 5.
  Pcase L1_1: s[2] <= 5.
    Pcase L2_1: s[3] <= 6.
      Pcase: s[3] <= 5.
        Reducible.
      Pcase: s[4] <= 5.
        Reducible.
      Pcase: s[5] > 6.
        Hubcap T[1,2]<=0 T[3,4]<=(-6) T[5]<=(-4) [].
      Pcase: s[5] > 5.
        Hubcap T[1,2]<=0 T[3,4]<=(-7) T[5]<=(-3) [].
      Reducible.
    Pcase: s[5] <= 6.
      Similar to *L2_1[3].
    Pcase: s[4] > 5.
      Hubcap T[1,2]<=0 T[3,4]<=(-6) T[5]<=(-4) [].
    Hubcap T[1,2]<=0 T[3,4]<=(-5) T[5]<=(-5) [].
  Pcase: s[5] <= 5.
    Similar to L1_1[4].
  Pcase L1_2: s[3] <= 5.
    Pcase: s[2] <= 6.
      Reducible.
    Pcase: s[4] <= 5.
      Similar to L1_1[2].
    Pcase L2_1: s[4] <= 6.
      Pcase: s[5] <= 6.
        Reducible.
      Hubcap T[1,2]<=(-4) T[3,4]<=(-2) T[5]<=(-4) [].
    Pcase: s[5] <= 6.
      Similar to *L2_1[2].
    Hubcap T[1,2]<=(-4) T[3,4]<=(-3) T[5]<=(-3) [].
  Pcase: s[4] <= 5.
    Similar to *L1_2[4].
  Pcase L1_3: s[2] > 6.
    Pcase: s[5] > 6.
      Hubcap T[1,2]<=(-3) T[3,4]<=(-4) T[5]<=(-3) [].
    Hubcap T[1,2]<=(-3) T[3,4]<=(-5) T[5]<=(-2) [].
  Pcase: s[5] > 6.
    Similar to *L1_3[4].
  Hubcap T[1,2]<=(-2) T[3,4]<=(-6) T[5]<=(-2) [].
Pcase: s[2] <= 5.
  Similar to L0_1[1].
Pcase: s[3] <= 5.
  Similar to L0_1[2].
Pcase: s[4] <= 5.
  Similar to L0_1[3].
Pcase: s[5] <= 5.
  Similar to L0_1[4].
Hubcap T[1,2]<=(-4) T[3,4]<=(-4) T[5]<=(-2) [].
Qed.

Set Strict Implicit.
Unset Implicit Arguments.


Require Import VerdiRaft.CommonTheorems.

Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.

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

  Definition entries_contiguous_nw net :=
    forall p t n pli plt es ci,
      In p (nwPackets net) ->
      pBody p = AppendEntries t n pli plt es ci ->
      contiguous_range_exact_lo es pli.

  Definition entries_gt_0_nw net :=
    forall p t n pli plt es ci e,
      In p (nwPackets net) ->
      pBody p = AppendEntries t n pli plt es ci ->
      In e es ->
      eIndex e > 0.

  Definition entries_sorted_nw net :=
    forall p t n pli plt es ci,
      In p (nwPackets net) ->
      pBody p = AppendEntries t n pli plt es ci ->
      sorted es.

  Definition entries_gt_0 net :=
    forall h e,
      In e (log (snd (nwState net h))) ->
      eIndex e > 0.

  Definition entries_contiguous net :=
    forall h,
      contiguous_range_exact_lo (log (snd (nwState net h))) 0.

  Definition entries_sorted net :=
    forall h,
      sorted (log (snd (nwState net h))).

  Definition entries_match_nw_1 net :=
    forall p t n pli plt es ci p' t' n' pli' plt' es' ci' e e' e'',
      In p (nwPackets net) ->
      In p' (nwPackets net) ->
      pBody p = AppendEntries t n pli plt es ci ->
      pBody p' = AppendEntries t' n' pli' plt' es' ci' ->
      In e es ->
      In e' es' ->
      eIndex e = eIndex e' ->
      eTerm e = eTerm e' ->
      In e'' es ->
      pli' < eIndex e'' <= eIndex e ->
      In e'' es'.

  Definition entries_match_nw_host net :=
    forall p t n pli plt es ci h e e' e'',
      In p (nwPackets net) ->
      pBody p = AppendEntries t n pli plt es ci ->
      In e es ->
      In e' (log (snd (nwState net h))) ->
      eIndex e = eIndex e' ->
      eTerm e = eTerm e' ->
      In e'' es ->
      eIndex e'' <= eIndex e ->
      In e'' (log (snd (nwState net h))).

  Class refined_log_matching_lemmas_interface : Prop :=
    {
      entries_contiguous_nw_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          entries_contiguous_nw net;
      entries_gt_0_nw_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          entries_gt_0_nw net;
      entries_sorted_nw_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          entries_sorted_nw net;
      entries_gt_0_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          entries_gt_0 net;
      entries_contiguous_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          entries_contiguous net;
      entries_sorted_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          entries_sorted net;
      entries_match_invariant :
        forall net h h',
          refined_raft_intermediate_reachable net ->
          entries_match (log (snd (nwState net h))) (log (snd (nwState net h')));
      entries_match_nw_1_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          entries_match_nw_1 net;
      entries_match_nw_host_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          entries_match_nw_host net;
      allEntries_gt_0_invariant :
        forall net h e,
          refined_raft_intermediate_reachable net ->
          In e (map snd (allEntries (fst (nwState net h)))) ->
          eIndex e > 0
    }.
End RefinedLogMatchingLemmas.


From iris.program_logic Require Import atomic.
From iris.heap_lang Require Import lifting notation.
Set Default Proof Using "Type".

(** A general logically atomic interface for a stack. *)
Record atomic_stack {Σ} `{!heapG Σ} := AtomicStack {
  (* -- operations -- *)
  new_stack : val;
  push : val;
  pop : val;
  (* -- other data -- *)
  name : Type;
  name_eqdec : EqDecision name;
  name_countable : Countable name;
  (* -- predicates -- *)
  is_stack (N : namespace) (γs : name) (v : val) : iProp Σ;
  stack_content (γs : name) (l : list val) : iProp Σ;
  (* -- predicate properties -- *)
  is_stack_persistent N γs v : Persistent (is_stack N γs v);
  stack_content_timeless γs l : Timeless (stack_content γs l);
  stack_content_exclusive γs l1 l2 :
    stack_content γs l1 -∗ stack_content γs l2 -∗ False;
  (* -- operation specs -- *)
  new_stack_spec N :
    {{{ True }}} new_stack #() {{{ γs s, RET s; is_stack N γs s ∗ stack_content γs [] }}};
  push_spec N γs s (v : val) :
    is_stack N γs s -∗
    <<< ∀ l : list val, stack_content γs l >>>
      push s v @ ⊤∖↑N
    <<< stack_content γs (v::l), RET #() >>>;
  pop_spec N γs s :
    is_stack N γs s -∗
    <<< ∀ l : list val, stack_content γs l >>>
      pop s @ ⊤∖↑N
    <<< stack_content γs (tail l),
        RET match l with [] => NONEV | v :: _ => SOMEV v end >>>;
}.
Arguments atomic_stack _ {_}.

Existing Instances
  is_stack_persistent stack_content_timeless
  name_countable name_eqdec.


(** * Universal properties of product categories *)
Require Import Category.Core Functor.Core Category.Prod Functor.Composition.Core Functor.Prod.Core.
Require Import Functor.Paths.
Require Import Types.Prod HoTT.Tactics Types.Forall Types.Sigma.
Require Import Basics.Tactics.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Notation fst_type := Basics.Datatypes.fst.
Local Notation snd_type := Basics.Datatypes.snd.
Local Notation pair_type := Basics.Datatypes.pair.
Local Notation prod_type := Basics.Datatypes.prod.

Local Open Scope morphism_scope.
Local Open Scope functor_scope.

Section universal.
  Context `{Funext}.

  Variables A B C : PreCategory.

  Local Open Scope functor_scope.

  Section universal.
    Variable a : Functor C A.
    Variable b : Functor C B.

    (** ** [fst ∘ (a * b) = a] *)
    Lemma compose_fst_prod : fst o (a * b) = a.
    Proof.
      path_functor; trivial.
    Defined.

    (** ** [snd ∘ (a * b) = b] *)
    Lemma compose_snd_prod : snd o (a * b) = b.
    Proof.
      path_functor; trivial.
    Defined.

    Section unique.
      Variable F : Functor C (A * B).
      Hypothesis H1 : fst o F = a.
      Hypothesis H2 : snd o F = b.

      Lemma unique_helper c
      : (a * b) c = F c.
      Proof.
        pose proof (ap (fun F => object_of F c) H1).
        pose proof (ap (fun F => object_of F c) H2).
        simpl in *.
        path_induction.
        apply eta_prod.
      Defined.

      Lemma unique_helper2
      : transport
          (fun GO : C -> prod_type A B =>
             forall s d : C,
               morphism C s d ->
               prod_type (morphism A (fst_type (GO s)) (fst_type (GO d)))
                         (morphism B (snd_type (GO s)) (snd_type (GO d))))
          (path_forall (a * b) F unique_helper)
          (fun (s d : C) (m : morphism C s d) => pair_type (a _1 m) (b _1 m)) =
        morphism_of F.
      Proof.
        repeat (apply path_forall; intro).
        repeat match goal with
                 | _ => reflexivity
                 | _ => progress simpl
                 | _ => rewrite !transport_forall_constant
               end.
        transport_path_forall_hammer.
        unfold unique_helper.
        repeat match goal with
                 | [ H : _ = _ |- _ ] => case H; simpl; clear H
               end.
        repeat match goal with
                 | [ |- context[@morphism_of ?C ?D ?F ?s ?d ?m] ]
                   => destruct (@morphism_of C D F s d m); clear m
                 | [ |- context[@object_of ?C ?D ?F ?x] ]
                   => destruct (@object_of C D F x); clear x
               end.
        reflexivity.
      Qed.

      Lemma unique
      : a * b = F.
      Proof.
        path_functor.
        exists (path_forall _ _ unique_helper).
        apply unique_helper2.
      Defined.
    End unique.

    Local Open Scope core_scope.

    (** ** Universal property characterizing unique product of functors *)
    Global Instance contr_prod_type
           `{IsHSet (Functor C A), IsHSet (Functor C B)}
    : Contr { F : Functor C (A * B)
            | fst o F = a
              /\ snd o F = b }.
    Proof.
      refine (Build_Contr _ (a * b; (compose_fst_prod, compose_snd_prod)) _).
      intro y.
      apply path_sigma_uncurried.
      simpl.
      exists (unique (fst_type y.2) (snd_type y.2)).
      exact (center _).
    Qed.
  End universal.

  (** ** Classification of path space of functors to a product precategory *)
  Definition path_prod (F G : Functor C (A * B))
             (H1 : fst o F = fst o G)
             (H2 : snd o F = snd o G)
  : F = G.
  Proof.
    etransitivity; [ symmetry | ];
    apply unique; try eassumption; reflexivity.
  Defined.
End universal.


From iris.base_logic Require Export derived.
From iris.algebra Require Import proofmode_classes.

Import base_logic.bi.uPred.

(* Setup of the proof mode *)
Section class_instances.
Context {M : ucmraT}.
Implicit Types P Q R : uPred M.

Global Instance into_pure_cmra_valid `{CmraDiscrete A} (a : A) :
  @IntoPure (uPredI M) (✓ a) (✓ a).
Proof. by rewrite /IntoPure discrete_valid. Qed.

Global Instance from_pure_cmra_valid {A : cmraT} af (a : A) :
  @FromPure (uPredI M) af (✓ a) (✓ a).
Proof.
  rewrite /FromPure. eapply bi.pure_elim; [by apply bi.affinely_if_elim|]=> ?.
  rewrite -uPred.cmra_valid_intro //.
Qed.

Global Instance from_sep_ownM (a b1 b2 : M) :
  IsOp a b1 b2 →
  FromSep (uPred_ownM a) (uPred_ownM b1) (uPred_ownM b2).
Proof. intros. by rewrite /FromSep -ownM_op -is_op. Qed.
Global Instance from_sep_ownM_core_id (a b1 b2 : M) :
  IsOp a b1 b2 → TCOr (CoreId b1) (CoreId b2) →
  FromAnd (uPred_ownM a) (uPred_ownM b1) (uPred_ownM b2).
Proof.
  intros ? H. rewrite /FromAnd (is_op a) ownM_op.
  destruct H; by rewrite bi.persistent_and_sep.
Qed.

Global Instance into_and_ownM p (a b1 b2 : M) :
  IsOp a b1 b2 → IntoAnd p (uPred_ownM a) (uPred_ownM b1) (uPred_ownM b2).
Proof.
  intros. apply bi.intuitionistically_if_mono. by rewrite (is_op a) ownM_op bi.sep_and.
Qed.

Global Instance into_sep_ownM (a b1 b2 : M) :
  IsOp a b1 b2 → IntoSep (uPred_ownM a) (uPred_ownM b1) (uPred_ownM b2).
Proof. intros. by rewrite /IntoSep (is_op a) ownM_op. Qed.
End class_instances.