Require Import Coq.Strings.String Coq.omega.Omega Coq.Lists.List Coq.Logic.FunctionalExtensionality Coq.Sets.Ensembles
        Fiat.Common.List.ListFacts
        Fiat.Computation
        Fiat.Computation.Refinements.Iterate_Decide_Comp
        Fiat.ADT
        Fiat.ADTRefinement Fiat.ADTNotation
        Fiat.QueryStructure.Specification.Representation.Schema
        Fiat.QueryStructure.Specification.Representation.QueryStructureSchema
        Fiat.ADTRefinement.BuildADTRefinements
        Fiat.QueryStructure.Specification.Representation.QueryStructure
        Fiat.Common.Ensembles.IndexedEnsembles
        Fiat.QueryStructure.Specification.Operations.Query
        Fiat.QueryStructure.Specification.Operations.Delete
        Fiat.QueryStructure.Specification.Operations.Mutate
        Fiat.QueryStructure.Implementation.Constraints.ConstraintChecksRefinements
        Fiat.Common.IterateBoundedIndex
        Fiat.Common.DecideableEnsembles
        Fiat.Common.List.PermutationFacts
        Fiat.QueryStructure.Implementation.Operations.General.QueryRefinements
        Fiat.QueryStructure.Implementation.Operations.General.MutateRefinements
        Fiat.Common.Ensembles.EnsembleListEquivalence.

(* Facts about implements delete operations. *)

Section DeleteRefinements.

  Hint Resolve crossConstr.
  Hint Unfold SatisfiesCrossRelationConstraints
       SatisfiesAttributeConstraints
       SatisfiesTupleConstraints.

  Arguments GetUnConstrRelation : simpl never.
  Arguments UpdateUnConstrRelation : simpl never.
  Arguments replace_BoundedIndex : simpl never.
  Arguments BuildQueryStructureConstraints : simpl never.
  Arguments BuildQueryStructureConstraints' : simpl never.

  Local Transparent QSDelete.

  Definition QSDeletedTuples
             {qsSchema}
             (qs : UnConstrQueryStructure qsSchema) Ridx
             (DeletedTuples : Ensemble RawTuple) :=
    (UnIndexedEnsembleListEquivalence
       (Intersection _
                     (GetUnConstrRelation qs Ridx)
                     (Complement _ (EnsembleDelete (GetUnConstrRelation qs Ridx) DeletedTuples)))).

  Lemma QSDeleteSpec_UnConstr_refine_AttributeConstraints :
    forall qsSchema qs  Ridx
           (DeletedTuples : Ensemble RawTuple)
           or,
      @DropQSConstraints_AbsR qsSchema or qs ->
      refine
        {b : bool |
         (forall tup,
            GetUnConstrRelation qs Ridx tup ->
            SatisfiesAttributeConstraints Ridx (indexedElement tup)) ->
         decides b
                 (MutationPreservesAttributeConstraints
                    (EnsembleDelete (GetRelation or Ridx) DeletedTuples)
                    (SatisfiesAttributeConstraints Ridx))}
        (ret true).
  Proof.
    unfold MutationPreservesAttributeConstraints; intros * AbsR_or_qs v Comp_v.
    computes_to_econstructor; intros; computes_to_inv; subst; simpl; intros.
    unfold DropQSConstraints_AbsR in *; eapply H; inversion H0; subst;
    rewrite GetRelDropConstraints; eauto.
  Qed.

  Lemma QSDeleteSpec_UnConstr_refine_CrossConstraints' :
    forall qsSchema qs  Ridx
           (DeletedTuples : Ensemble RawTuple)
           or,
      @DropQSConstraints_AbsR qsSchema or qs ->
  refine
   {b : bool |
   (forall Ridx',
    Ridx' <> Ridx ->
    forall tup',
    GetUnConstrRelation qs Ridx tup' ->
    SatisfiesCrossRelationConstraints Ridx Ridx' (indexedElement tup')
      (GetUnConstrRelation qs Ridx')) ->
   decides b
     (forall Ridx',
      Ridx' <> Ridx ->
      MutationPreservesCrossConstraints
        (EnsembleDelete (GetRelation or Ridx) DeletedTuples)
        (GetUnConstrRelation qs Ridx')
        (SatisfiesCrossRelationConstraints Ridx Ridx'))}
   (ret true).
  Proof.
    unfold MutationPreservesCrossConstraints; intros * AbsR_or_qs v Comp_v.
    computes_to_econstructor; intros;  computes_to_inv; subst; simpl; intros.
    unfold DropQSConstraints_AbsR in *; eapply H; inversion H1; subst; eauto.
    rewrite GetRelDropConstraints; eauto.
  Qed.

  Lemma QSDeleteSpec_UnConstr_refine_opt :
    forall qsSchema qs Ridx DeletedTuples or,
      @DropQSConstraints_AbsR qsSchema or qs ->
      refine
        (or' <- (QSDelete or Ridx DeletedTuples);
         nr' <- {nr' | DropQSConstraints_AbsR (fst or') nr'};
         ret (nr', snd or'))
        match (tupleConstraints (GetNRelSchema (qschemaSchemas qsSchema) Ridx)) with
          | Some tConstr =>
            tupleConstr <- {b | (forall tup tup',
                                   elementIndex tup <> elementIndex tup'
                                   -> GetUnConstrRelation qs Ridx tup
                                     -> GetUnConstrRelation qs Ridx tup'
                                     -> tConstr (indexedElement tup) (indexedElement tup'))
                                  -> decides b (MutationPreservesTupleConstraints
                                                  (EnsembleDelete (GetRelation or Ridx) DeletedTuples)
                                                  tConstr) };
              crossConstr <- (Iterate_Decide_Comp_opt_Pre _
                                  (fun Ridx' =>
                                      if fin_eq_dec Ridx Ridx'
                                      then None
                                      else
                                        match
                                          BuildQueryStructureConstraints qsSchema Ridx'
                                                                         Ridx
                                        with
                                          | Some CrossConstr =>
                                            Some
                                              ((MutationPreservesCrossConstraints
                                                  (GetUnConstrRelation qs Ridx')
                                                  (EnsembleDelete (GetRelation or Ridx) DeletedTuples)
                                                 CrossConstr))
                                          | None => None
                                        end)
                                  (@Iterate_Ensemble_BoundedIndex_filter
                                     _
                                     (fun Ridx' =>
                                        forall tup',
                                          (GetUnConstrRelation qs Ridx') tup'
                                          -> SatisfiesCrossRelationConstraints
                                               Ridx' Ridx (indexedElement tup') (GetUnConstrRelation qs Ridx))
                                     (fun idx =>
                                        if (fin_eq_dec Ridx idx)
                                          then false else true)
                             ));
              match tupleConstr, crossConstr with
                | true, true =>
                  deleted  <- Pick (QSDeletedTuples qs Ridx DeletedTuples);
                    ret (UpdateUnConstrRelation qs Ridx (EnsembleDelete (GetUnConstrRelation qs Ridx) DeletedTuples), deleted)
                | _, _  => ret (qs, [])
              end
          | None =>
              crossConstr <- (Iterate_Decide_Comp_opt_Pre _
                                  (fun Ridx'  =>
                                      if fin_eq_dec Ridx Ridx'
                                      then None
                                      else
                                        match
                                          BuildQueryStructureConstraints qsSchema Ridx'
                                                                         Ridx
                                        with
                                          | Some CrossConstr =>
                                            Some
                                              ((MutationPreservesCrossConstraints
                                                  (GetUnConstrRelation qs Ridx')
                                                  (EnsembleDelete (GetRelation or Ridx) DeletedTuples)
                                                 CrossConstr))
                                          | None => None
                                        end)
                                  (@Iterate_Ensemble_BoundedIndex_filter
                                     _
                                     (fun Ridx' =>
                                        forall tup',
                                          (GetUnConstrRelation qs Ridx') tup'
                                          -> SatisfiesCrossRelationConstraints
                                               Ridx' Ridx (indexedElement tup') (GetUnConstrRelation qs Ridx))
                                     (fun idx =>
                                        if (fin_eq_dec Ridx idx)
                                        then false else true)));
              match crossConstr with
                | true  =>
                  deleted   <- Pick (QSDeletedTuples qs Ridx DeletedTuples);
                    ret (UpdateUnConstrRelation qs Ridx (EnsembleDelete (GetUnConstrRelation qs Ridx) DeletedTuples), deleted)
                | _ => ret (qs, [])
            end
        end.
  Proof.
    unfold QSDelete.
    intros; rewrite QSMutateSpec_UnConstr_refine;
    eauto using
          QSDeleteSpec_UnConstr_refine_AttributeConstraints,
    refine_SatisfiesTupleConstraintsMutate,
    refine_SatisfiesCrossConstraintsMutate,
    QSDeleteSpec_UnConstr_refine_CrossConstraints'.
    simplify with monad laws.
    unfold SatisfiesTupleConstraints.
    case_eq (tupleConstraints (GetNRelSchema (qschemaSchemas qsSchema) Ridx)); intros;
    [eapply refine_under_bind; intros
    | simplify with monad laws].
    simpl; unfold DropQSConstraints_AbsR, QSDeletedTuples in *; subst.
    f_equiv; unfold pointwise_relation; intros;
    repeat find_if_inside; try simplify with monad laws; try reflexivity.
    rewrite GetRelDropConstraints, get_update_unconstr_eq; f_equiv.
    f_equiv; unfold pointwise_relation; intros; eauto.
    simpl; unfold DropQSConstraints_AbsR, QSDeletedTuples in *; subst.
    repeat find_if_inside; try simplify with monad laws; try reflexivity.
    rewrite GetRelDropConstraints, get_update_unconstr_eq; f_equiv.
  Qed.

  Lemma EnsembleComplementIntersection {A}
  : forall E (P : Ensemble A),
      DecideableEnsemble P
      -> forall (a : @IndexedElement A),
           (In _ (Intersection _ E
                               (Complement _ (EnsembleDelete E P))) a
            <-> In _ (Intersection _ E
                                   (fun itup => P (indexedElement itup))) a).
  Proof.
    unfold EnsembleDelete, Complement, In in *; intuition;
    destruct H; constructor; eauto; unfold In in *.
    - case_eq (DecideableEnsembles.dec (indexedElement x)); intros.
      + eapply dec_decides_P; eauto.
      + exfalso; apply H0; constructor; unfold In; eauto.
        intros H'; apply dec_decides_P in H'; congruence.
    - intros H'; destruct H'; unfold In in *; eauto.
  Qed.

  Lemma DeletedTuplesIntersection {qsSchema}
  : forall qs Ridx (P : Ensemble RawTuple),
      DecideableEnsemble P
      -> refine {x | @QSDeletedTuples qsSchema qs Ridx P x}
                {x | UnIndexedEnsembleListEquivalence
                       (Intersection _ (GetUnConstrRelation qs Ridx)
                                     (fun itup => P (indexedElement itup))) x}.
  Proof.
    intros qs Ridx P P_dec v Comp_v;  computes_to_inv.
    computes_to_constructor.
    unfold QSDeletedTuples, UnIndexedEnsembleListEquivalence in *; destruct_ex;
    intuition; subst.
    eexists; intuition.
    unfold EnsembleListEquivalence in *; intuition; eauto with typeclass_instances.
    + eapply H; eapply EnsembleComplementIntersection; eauto with typeclass_instances.
    + eapply EnsembleComplementIntersection; eauto with typeclass_instances.
      eapply H; eauto.
  Qed.

  Definition UpdateUnConstrRelationDeleteC {qsSchema} (qs : UnConstrQueryStructure qsSchema) Ridx DeletedTuples :=
    ret (UpdateUnConstrRelation qs Ridx (EnsembleDelete (GetUnConstrRelation qs Ridx) DeletedTuples)).

  Lemma QSDeleteSpec_refine_subgoals ResultT :
    forall qsSchema (qs : QueryStructure qsSchema) qs' Ridx
           default success
           refined_schConstr refined_qsConstr
           (DeletedTuples : Ensemble RawTuple)
           (k : _ -> Comp ResultT),
      DropQSConstraints_AbsR qs qs'
      -> refine match tupleConstraints (GetNRelSchema (qschemaSchemas qsSchema) Ridx) with
                | Some Constr =>
                  {b | (forall tup tup',
                           elementIndex tup <> elementIndex tup'
                           -> GetUnConstrRelation qs' Ridx tup
                           -> GetUnConstrRelation qs' Ridx tup'
                           -> Constr (indexedElement tup)
                                                        (indexedElement tup'))
                       -> decides b
                                  (MutationPreservesTupleConstraints
                                     (EnsembleDelete (GetUnConstrRelation qs' Ridx) DeletedTuples)
                                     Constr) }
                | None => ret true
                end
                refined_schConstr
      -> refine (Iterate_Decide_Comp_opt_Pre _
                                  (fun Ridx' =>
                                      if fin_eq_dec Ridx Ridx'
                                      then None
                                      else
                                        match BuildQueryStructureConstraints qsSchema Ridx' Ridx with
                                        | Some CrossConstr =>
                                          Some
                                            (MutationPreservesCrossConstraints (GetUnConstrRelation qs' Ridx')
                                                                               (EnsembleDelete (GetUnConstrRelation qs' Ridx) DeletedTuples)
                                                                               CrossConstr)
                                        | None => None
                                        end)
                                  (@Iterate_Ensemble_BoundedIndex_filter
                                     _
                                     (fun Ridx' =>
                                        forall tup',
                                          GetUnConstrRelation qs' Ridx' tup'
                                          -> SatisfiesCrossRelationConstraints
                                               Ridx' Ridx (indexedElement tup') (GetUnConstrRelation qs' Ridx))
                                     (fun idx =>
                                        if (fin_eq_dec Ridx idx)
                                        then false else true)
                )) refined_qsConstr
      -> (forall qs'' qs''' mutated,
             DropQSConstraints_AbsR qs'' qs'''
             -> (forall Ridx',
                    Ridx <> Ridx' ->
                    GetRelation qs Ridx' =
                    GetRelation qs'' Ridx')
             -> (forall t,
                    GetRelation qs'' Ridx t <-> EnsembleDelete (GetRelation qs Ridx) DeletedTuples t)
             -> QSDeletedTuples qs' Ridx DeletedTuples mutated
             -> refine (k (qs'', mutated))
                       (success qs''' mutated))
      -> refine (k (qs, [ ])) default
      -> refine
           (qs' <- QSDelete qs Ridx DeletedTuples; k qs')
           ( schConstr <- refined_schConstr;
             qsConstr <- refined_qsConstr;
             match schConstr, qsConstr with
             | true, true =>
               mutated  <- Pick (QSDeletedTuples qs' Ridx DeletedTuples);
                 qs'' <- UpdateUnConstrRelationDeleteC qs' Ridx DeletedTuples;
                 success qs'' mutated
             | _, _ => default
             end).
  Proof.
    intros.
    unfold QSDelete.
    rewrite QSMutateSpec_refine_subgoals' with (refined_schConstr_self := ret true)
                                                (refined_qsConstr' := ret true);
      try first [eassumption | reflexivity ].
    simplify with monad laws.
    repeat (f_equiv; unfold pointwise_relation; intros).
    rewrite <- H0, <- (GetRelDropConstraints qs Ridx), <- H.
    rewrite refine_SatisfiesTupleConstraintsMutate; eauto.
    destruct (tupleConstraints (GetNRelSchema (qschemaSchemas qsSchema) Ridx));
    f_equiv.
    rewrite refine_SatisfiesCrossConstraintsMutate; eauto.
    rewrite <- (GetRelDropConstraints qs Ridx).
    rewrite <- H1, H; f_equiv.
    repeat find_if_inside.
    unfold QSDeletedTuples.
    f_equiv.
    rewrite <- (GetRelDropConstraints qs Ridx).
    unfold GetUnConstrRelation, UpdateUnConstrRelation.
    rewrite ilist2.ith_replace2_Index_eq, <- H; reflexivity.
    unfold UpdateUnConstrRelationDeleteC, UpdateUnConstrRelationMutateC;
    rewrite <- H, GetRelDropConstraints; reflexivity.
    reflexivity.
    reflexivity.
    eauto using QSDeleteSpec_UnConstr_refine_AttributeConstraints.
    eauto using QSDeleteSpec_UnConstr_refine_CrossConstraints'.
    intros; eapply H2; eauto.
    unfold QSDeletedTuples.
    unfold GetUnConstrRelation, UpdateUnConstrRelation in H7.
    rewrite ilist2.ith_replace2_Index_eq in H7.
    rewrite <- GetRelDropConstraints, H in H7; eauto.
  Qed.

  Local Transparent Query_For.

  Lemma DeletedTuplesFor {qsSchema}
  : forall qs Ridx P,
      DecideableEnsemble P
      -> refine {x | @QSDeletedTuples qsSchema qs Ridx P x}
                (For (UnConstrQuery_In qs Ridx
                                       (fun tup => Where (P tup) Return tup))).
  Proof.
    intros qs Ridx P P_dec v Comp_v; rewrite DeletedTuplesIntersection by auto.
    computes_to_constructor.
    unfold UnIndexedEnsembleListEquivalence.
    unfold Query_For in *.
    computes_to_inv.
    destruct Comp_v as [l [Perm_l_v Comp_v] ].
    unfold UnConstrQuery_In, QueryResultComp in *;  computes_to_inv.
    remember (GetUnConstrRelation qs Ridx); clear Heqi.
    revert P_dec i v v0 Perm_l_v Comp_v Comp_v'; clear; induction l; simpl; intros.
    - apply Return_inv in Comp_v; subst.
      eexists nil; simpl; split; eauto.
      rewrite Permutation_nil by eauto; reflexivity.
      + unfold EnsembleListEquivalence in *; intuition.
        * destruct H; intuition.
          apply Pick_inv in Perm_l_v; inversion Perm_l_v.
          unfold In in *; intuition; subst.
          apply H1 in H.
          eapply (@FlattenCompList.flatten_CompList_nil _ P x0); eauto.
          destruct x0; simpl in *; try discriminate; computes_to_econstructor.
        * constructor.
    - apply Pick_inv in Perm_l_v.
       unfold UnConstrRelation in i.
       destruct Perm_l_v as [ [ | [a' x'] ] [x_eq [equiv_u_x' NoDup_x'] ] ].
       destruct l; simpl in *; try discriminate.
       unfold In in Comp_v; pose (Bind_inv Comp_v); destruct_ex; intuition; subst; computes_to_inv; subst.
       simpl in x_eq; injections.
      case_eq (@DecideableEnsembles.dec _ P P_dec a); intros.
      + apply Pick_inv in H0; intuition.
        apply dec_decides_P in H2. apply H3 in H2.
        apply Return_inv in H2; simpl in *; subst; simpl in *.
        pose proof (PermutationConsSplit _ _ _ Comp_v'); destruct_ex; subst.
        unfold UnIndexedEnsembleListEquivalence in *.
        destruct (H (fun x => i x /\ x <> {|indexedElement := a; elementIndex := a' |}) (app x x0) v1); intuition eauto.
        apply PickComputes.
        computes_to_inv; injections.
        eexists _; intuition eauto.
        unfold In in *; intuition.
        rewrite equiv_u_x' in H2; destruct H2; subst; eauto; congruence.
        unfold In; intuition.
        apply equiv_u_x'; simpl; intuition.
        inversion NoDup_x'; subst; eauto.
        apply H7; apply in_map_iff; eexists; split; eauto; simpl; eauto.
        inversion NoDup_x'; subst; eauto.
        eapply Permutation_cons_inv; rewrite Permutation_middle; eassumption.
        * symmetry in H2; pose proof (app_map_inv _ _ _ _ H2); destruct_ex;
          intuition; subst.
          eexists (app x2 ({|indexedElement := a; elementIndex := a' |} :: x3));
            simpl; rewrite map_app.
          { simpl; intuition; computes_to_inv; injections.
            - destruct H5; unfold In in *; apply equiv_u_x' in H5; simpl in *; intuition.
              apply in_or_app; simpl; eauto.
              assert (i x) as u_x by (apply equiv_u_x'; eauto).
              assert (List.In x (x2 ++ x3)) as In_x by
                    (apply H0; constructor; unfold In; intuition; subst;
                inversion NoDup_x'; subst; eapply H10; apply in_map_iff; eexists;
                split; cbv beta; simpl; eauto; reflexivity).
              apply in_or_app; simpl; apply in_app_or in In_x; intuition.
            - unfold In.
              assert (List.In x (x2 ++ x3) \/ x = {|indexedElement := a; elementIndex := a' |})
                as In_x0
                  by (apply in_app_or in H5; simpl in H5; intuition).
              intuition.
              + apply H0 in H7; destruct H7; unfold In in *; intuition.
                constructor; eauto.
              + subst; constructor; eauto.
                apply equiv_u_x'; simpl; eauto.
                case_eq (@DecideableEnsembles.dec _ P P_dec a); intros.
                apply dec_decides_P; eauto.
                assert (~ P a) as H''
                    by (unfold not; intros H'; apply dec_decides_P in H'; congruence);
                apply H4 in H''; discriminate.
            - rewrite map_app; apply NoDup_app_swap; simpl; constructor; eauto.
              inversion NoDup_x'; subst; unfold not; intros; apply H8.
              rewrite <- map_app in H5; apply in_map_iff in H5; destruct_ex; intuition.
              assert (List.In x (x2 ++ x3)) as In_a by
                    (apply in_or_app; apply in_app_or in H10; intuition).
              apply H0 in In_a; destruct In_a; unfold In in *; intuition.
              apply equiv_u_x' in H12; simpl in *; intuition.
              destruct x; simpl in *; subst.
              apply in_map_iff; eexists; split; eauto; simpl; eauto.
              apply NoDup_app_swap; rewrite <- map_app; eauto.
          }
      + unfold Query_Where, Query_Return in H0;
        computes_to_inv; intuition.
        assert (~ P a) as H''
            by (unfold not; intros H'; apply dec_decides_P in H'; congruence
        ).
        apply H4 in H''; subst; simpl in *; subst.
        destruct (H (fun x => i x /\ x <> {|indexedElement := a; elementIndex := a' |}) v v1); intuition eauto.
        * computes_to_econstructor.
          eexists; intuition; eauto.
          unfold In in *; intuition.
          apply equiv_u_x' in H5; destruct H5; subst; eauto.
          congruence.
          unfold In; intuition.
          unfold In; intuition.
          subst.
          apply equiv_u_x'; simpl; intuition.
          inversion NoDup_x'; subst; eauto.
          apply H8; apply in_map_iff; eexists; split; eauto; simpl; eauto.
          inversion NoDup_x'; subst; eauto.
        * unfold In.
          eexists; split; eauto.
          unfold UnIndexedEnsembleListEquivalence in *; intuition.
          destruct H6; intuition.
          eapply H0; constructor; unfold In in *; subst; intuition.
          subst; apply_in_hyp dec_decides_P; simpl in *; congruence.
          constructor;
            apply H0 in H6; destruct H6; unfold In in *; intuition.
  Qed.

End DeleteRefinements.


Require Import Hask.Prelude.
Require Import Hask.Ltac.
Require Import Hask.Data.Functor.Identity.
Require Import Hask.Data.Functor.Kan.
Require Import Hask.Control.Monad.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.
Set Asymmetric Patterns.

Definition Yoneda (f : Type -> Type) (a : Type) :=
  forall r : Type, (a -> r) -> f r.

(* #[export] *)
(* Instance Yoneda_lemma `{Functor f} : forall a, Yoneda f a ≅ f a := { *)
(*   iso_to   := fun x => x _ id; *)
(*   iso_from := fun x _ k => fmap k x *)
(* }. *)

#[export]
Instance Yoneda_Functor {f : Type -> Type} : Functor (Yoneda f) := {
  fmap := fun _ _ g k _ h => k _ (h \o g)
}.

#[export]
Instance Yoneda_Applicative `{Applicative f} :
  Applicative (Yoneda f) := {
  pure := fun _ x => fun _ k => pure (k x);
  ap   := fun a b g x => fun _ k => g _ (comp k) <*> x _ id
}.

Definition Yoneda_join `{Monad m} `(k : Yoneda m (Yoneda m a)) : Yoneda m a :=
  fun _ h => join (k _ (fun y => y _ h)).

#[export]
Instance Yoneda_Monad `{Monad m} : Monad (Yoneda m) := {
  join := @Yoneda_join m _
}.

Require Import FunctionalExtensionality.

Module YonedaLaws.

(* Include IsomorphismLaws. *)
Include MonadLaws.

(* Parametricity theorem. *)
Corollary Yoneda_parametricity : forall `{Functor f} a b c (k : Yoneda f a)
  (g : b -> c) (h : a -> b), fmap g (k _ h) = k _ (g \o h).
Proof.
  intros.
  pose proof (@Ran_parametricity a b c Identity _ f _).
  simpl in H0.
  unfold id in H0.
Admitted.
(* jww (2017-04-24): Universe inconsistency in Coq 8.6 *)
(*
  apply (H0 k g h).
Qed.
*)

(* #[export] *)
(* Program Instance Yoneda_lemma `{FunctorLaws f} : *)
(*   forall a, @IsomorphismLaws (Yoneda f a) (f a) (Yoneda_lemma a). *)
(* Obligation 1. *)
(*   extensionality x. *)
(*   simpl. *)
(*   extensionality r. *)
(*   extensionality g. *)
(*   apply Yoneda_parametricity. *)
(* Qed. *)
(* Obligation 2. *)
(*   extensionality x. *)
(*   unfold comp. *)
(*   rewrite fmap_id. *)
(*   reflexivity. *)
(* Qed. *)

#[export]
Program Instance Yoneda_FunctorLaws {f : Type -> Type} : FunctorLaws (Yoneda f).

#[export]
Program Instance Yoneda_ApplicativeLaws `{ApplicativeLaws f} :
  ApplicativeLaws (Yoneda f).
Obligation 1.
  extensionality x.
  extensionality r.
  extensionality k0.
  rewrite ap_fmap, <- fmap_comp, fmap_id.
  unfold comp, id.
  apply Yoneda_parametricity.
Qed.
Obligation 2.
  extensionality r.
  extensionality k.
  rewrite <- ap_comp; f_equal.
  repeat rewrite ap_fmap; f_equal.
  repeat rewrite Yoneda_parametricity; f_equal.
Qed.
Obligation 3.
  extensionality r.
  extensionality k.
  rewrite ap_fmap.
  unfold comp.
  rewrite <- fmap_comp_x.
  repeat rewrite fmap_pure_x.
  reflexivity.
Qed.
Obligation 4.
  extensionality r.
  extensionality k.
  rewrite ap_fmap, <- fmap_comp, ap_interchange.
  unfold comp.
  rewrite ap_fmap.
  repeat rewrite Yoneda_parametricity.
  f_equal.
Qed.
Obligation 5.
  extensionality k.
  extensionality r.
  extensionality g.
  rewrite ap_fmap, <- fmap_comp_x.
  unfold comp.
  repeat rewrite Yoneda_parametricity.
  f_equal.
Qed.

#[export]
Program Instance Yoneda_MonadLaws `{MonadLaws m} : MonadLaws (Yoneda m).
Obligation 1.
  extensionality k.
  unfold Yoneda_join.
  extensionality r.
  extensionality h.
  simpl.
  rewrite <- join_fmap_join_x, Yoneda_parametricity.
  reflexivity.
Qed.
Obligation 2.
  extensionality k.
  unfold Yoneda_join.
  extensionality r.
  extensionality h.
  unfold comp.
  replace (fun x : a => pure[m] (h x)) with (pure[m] \o h).
    rewrite <- Yoneda_parametricity.
    rewrite join_fmap_pure_x.
    reflexivity.
  reflexivity.
Qed.
Obligation 3.
  extensionality k.
  unfold Yoneda_join.
  extensionality r.
  extensionality h.
  unfold comp.
  rewrite join_pure_x.
  reflexivity.
Qed.

End YonedaLaws.

(**************************************************************************)

(* The contravariant Yoneda lemma, made applicable to covariant functors by
   changing it from a universally quantified function to an existentially
   quantified construction of two arguments. *)

Inductive Coyoneda (f : Type -> Type) (a : Type) :=
  COYO : forall x, (x -> a) -> f x -> Coyoneda f a.

Arguments COYO {f a x} _ _.

Definition liftCoyoneda {f : Type -> Type} {a : Type} : f a -> Coyoneda f a :=
  COYO id.

Definition lowerCoyoneda `{Functor f} {a : Type} (c : Coyoneda f a) : f a :=
  match c with COYO _ g h => fmap g h end.

#[export]
Instance Coyoneda_Functor (f : Type -> Type) : Functor (Coyoneda f) := {
  fmap := fun _ _ f x => match x with COYO _ g h => COYO (f \o g) h end
}.

Require Import FunctionalExtensionality.

Module CoyonedaLaws.

Include FunctorLaws.

#[export]
Program Instance Coyoneda_FunctorLaws (f : Type -> Type) :
  FunctorLaws (Coyoneda f).
Obligation 1. extensionality x. destruct x; reflexivity. Qed.
Obligation 2. extensionality x. destruct x; reflexivity. Qed.

Theorem coyo_to `{FunctorLaws f} : forall a (x : f a),
  lowerCoyoneda (liftCoyoneda x) = x.
Proof.
  intros a x.
  unfold lowerCoyoneda, liftCoyoneda.
  rewrite fmap_id.
  reflexivity.
Qed.

Theorem coyo_lower_naturality `{FunctorLaws f} : forall a b (g : a -> b),
  fmap g \o lowerCoyoneda (f:=f) = lowerCoyoneda \o fmap g.
Proof.
  intros a b k.
  extensionality x.
  destruct x as [x g h]; simpl.
  rewrite fmap_comp_x.
  reflexivity.
Qed.

Axiom coyo_parametricity : forall `{FunctorLaws f} a b (g : a -> b),
  COYO g = COYO id \o fmap g.

Theorem coyo_lift_naturality `{FunctorLaws f} : forall a b (g : a -> b),
  fmap g \o liftCoyoneda (f:=f) = liftCoyoneda \o fmap g.
Proof.
  intros a b g.
  unfold liftCoyoneda.
  extensionality x.
  simpl.
  replace (g \o id) with g; auto.
  rewrite coyo_parametricity.
  reflexivity.
Qed.

Theorem coyo_from `{FunctorLaws f} : forall a (x : Coyoneda f a),
  liftCoyoneda (lowerCoyoneda x) = x.
Proof.
  intros a [x g h].
  unfold lowerCoyoneda.
  replace (liftCoyoneda ((fmap[f] g) h)) with ((liftCoyoneda \o (fmap[f] g)) h).
    rewrite <- coyo_lift_naturality.
    reflexivity.
  reflexivity.
Qed.

End CoyonedaLaws.


(*
  This file showcases the use of packages.
 *)

From Coq Require Import Utf8.
Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-format".
From mathcomp Require Import ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice seq.
Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format".
From extructures Require Import ord fset fmap.
From Crypt Require Import RulesStateProb Package Prelude.
Import PackageNotation.

From Equations Require Import Equations.
Require Equations.Prop.DepElim.

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

#[local] Open Scope package_scope.

Definition I0 : Interface :=
  [interface #val #[3] : 'nat → 'nat].

Definition I1 : Interface :=
  [interface
    #val #[0] : 'bool → 'bool ;
    #val #[1] : 'nat → 'unit ;
    #val #[2] : 'unit → 'bool
  ].

Definition I2 : Interface :=
  [interface
    #val #[4] : 'bool × 'bool → 'bool
  ].

Definition pempty : package fset0 [interface] [interface] :=
  [package].

Definition p0 : package fset0 [interface] I0 :=
  [package
    #def #[3] (x : 'nat) : 'nat {
      ret x
    }
  ].

Definition p1 : package fset0 [interface] I1 :=
  [package
    #def #[0] (z : 'bool) : 'bool {
      ret z
    } ;
    #def #[1] (y : 'nat) : 'unit {
      ret Datatypes.tt
    } ;
    #def #[2] (u : 'unit) : 'bool {
      ret false
    }
  ].

Definition foo (x : bool) : code fset0 [interface] bool_choiceType :=
  {code let u := x in ret u}.

Definition bar (b : bool) : code fset0 [interface] nat_choiceType :=
  {code if b then ret 0 else ret 1}.

Definition p2 : package fset0 [interface] I2 :=
  [package
    #def #[4] (x : 'bool × 'bool) : 'bool {
      let '(u,v) := x in ret v
    }
  ].

Definition test₁ :
  package
    [fset (chNat; 0)]
    [interface #val #[0] : 'nat → 'nat]
    [interface
      #val #[1] : 'nat → 'nat ;
      #val #[2] : 'unit → 'unit
    ]
  :=
  [package
    #def #[1] (x : 'nat) : 'nat {
      getr ('nat; 0) (λ n : nat,
        opr (0, ('nat, 'nat)) n (λ m,
          putr ('nat; 0) m (ret m)
        )
      )
    } ;
    #def #[2] (_ : 'unit) : 'unit {
      putr ('nat; 0) 0 (ret Datatypes.tt)
    }
  ].

Definition sig := {sig #[0] : 'nat → 'nat }.

#[program] Definition test₂ :
  package
    [fset ('nat; 0)]
    [interface #val #[0] : 'nat → 'nat ]
    [interface
      #val #[1] : 'nat → 'nat ;
      #val #[2] : 'unit → 'option ('fin 2) ;
      #val #[3] : {map 'nat → 'nat} → 'option 'nat
    ]
  :=
  [package
    #def #[1] (x : 'nat) : 'nat {
      n ← get ('nat ; 0) ;;
      m ← op sig ⋅ n ;;
      n ← get ('nat ; 0) ;;
      m ← op sig ⋅ n ;;
      #put ('nat ; 0) := m ;;
      ret m
    } ;
    #def #[2] (_ : 'unit) : 'option ('fin 2) {
      #put ('nat ; 0) := 0 ;;
      ret (Some (gfin 1))
    } ;
    #def #[3] (m : {map 'nat → 'nat}) : 'option 'nat {
      ret (getm m 0)
    }
  ].

(* Testing the #import notation *)
Definition test₃ :
  package
    fset0
    [interface
      #val #[0] : 'nat → 'bool ;
      #val #[1] : 'bool → 'unit
    ]
    [interface
      #val #[2] : 'nat → 'nat ;
      #val #[3] : 'bool × 'bool → 'bool
    ]
  :=
  [package
    #def #[2] (n : 'nat) : 'nat {
      #import {sig #[0] : 'nat → 'bool } as f ;;
      #import {sig #[1] : 'bool → 'unit } as g ;;
      b ← f n ;;
      if b then
        g false ;;
        ret 0
      else ret n
    } ;
    #def #[3] ('(b₀,b₁) : 'bool × 'bool) : 'bool {
      ret b₀
    }
  ].

(** Information is redundant between the export interface and the package
    definition, so it can safely be skipped.
*)
Definition test₄ : package fset0 [interface] _ :=
  [package
    #def #[ 0 ] (n : 'nat) : 'nat {
      ret (n + n)%N
    } ;
    #def #[ 1 ] (b : 'bool) : 'nat {
      if b then ret 0 else ret 13
    }
  ].

Definition ℓ : Location := ('nat ; 0).

#[tactic=notac] Equations? foo : code fset0 [interface] 'nat :=
  foo := {code
    n ← get ℓ ;;
    ret n
  }.
Proof.
  ssprove_valid.
Abort.


(*
 * Copyright (c) 2009-2011, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

Require Import VST.msl.base.

Set Implicit Arguments.

Module CovariantFunctor.

Record functorFacts (PS : Type -> Type)
  (fmap : forall A B (f : A -> B), PS A -> PS B) : Type :=
FunctorFacts {
  ff_id : forall A, fmap _ _ (id A) = id (PS A);
  ff_comp : forall A B C (f : B -> C) (g : A -> B),
fmap _ _ f oo fmap _ _ g = fmap _ _ (f oo g)
}.

Record functor : Type := Functor {
  _functor: Type -> Type;
  fmap : forall A B (f : A -> B), _functor A -> _functor B;
  functor_facts : functorFacts _functor fmap
}.

End CovariantFunctor.

Module ContraVariantFunctor.

Record functorFacts (PS : Type -> Type)
  (fmap : forall A B (f : B -> A), PS A -> PS B) : Type :=
FunctorFacts {
  ff_id : forall A, fmap _ _ (id A) = id (PS A);
  ff_comp : forall A B C (f : C -> B) (g : B -> A),
fmap _ _ f oo fmap _ _ g = fmap _ _ (g oo f)
}.

Record functor : Type := Functor {
  _functor: Type -> Type;
  fmap : forall A B (f : B -> A), _functor A -> _functor B;
  functor_facts : functorFacts _functor fmap
}.

End ContraVariantFunctor.

Module MixVariantFunctor.

Record functorFacts (PS : Type -> Type)
 (fmap : forall A B (f1 : A -> B) (f2 : B -> A), PS A -> PS B) : Type :=
FunctorFacts {
  ff_id : forall A, fmap _ _ (id A) (id A) = id (PS A);
  ff_comp : forall A B C (f1 : B -> C) (f2 : C -> B) (g1 : A -> B)
(g2 : B -> A), fmap _ _ f1 f2 oo fmap _ _ g1 g2 = fmap _ _ (f1 oo g1) (g2 oo f2)
}.

Record functor : Type := Functor {
  _functor: Type -> Type;
  fmap : forall A B (f1 : A -> B) (f2 : B -> A), _functor A -> _functor B;
  functor_facts : functorFacts _functor fmap
}.

End MixVariantFunctor.

Module CovariantBiFunctor.

Record functorFacts (PS : Type -> Type -> Type)
 (fmap : forall A1 B1 A2 B2 (f1 : A1 -> B1) (f2 : A2 -> B2),
    PS A1 A2 -> PS B1 B2) : Type :=
FunctorFacts {
  ff_id : forall A1 A2, fmap _ _ _ _ (id A1) (id A2) = id (PS A1 A2);
  ff_comp : forall A1 A2 B1 B2 C1 C2 (f1 : B1 -> C1) (f2 : B2 -> C2)
(g1 : A1 -> B1) (g2 : A2 -> B2),
  fmap _ _ _ _ f1 f2 oo fmap _ _ _ _ g1 g2 = fmap _ _ _ _ (f1 oo g1) (f2 oo g2)
}.

Record functor : Type := Functor {
  _functor: Type -> Type -> Type;
  fmap : forall A1 B1 A2 B2 (f1 : A1 -> B1) (f2 : A2 -> B2),
    _functor A1 A2 -> _functor B1 B2;
  functor_facts : functorFacts _functor fmap
}.

End CovariantBiFunctor.

Module CoContraVariantBiFunctor.

Record functorFacts (PS : Type -> Type -> Type)
 (fmap : forall A1 B1 A2 B2 (f1 : A1 -> B1) (f2 : B2 -> A2),
    PS A1 A2 -> PS B1 B2) : Type :=
FunctorFacts {
  ff_id : forall A1 A2, fmap _ _ _ _ (id A1) (id A2) = id (PS A1 A2);
  ff_comp : forall A1 A2 B1 B2 C1 C2 (f1 : B1 -> C1) (f2 : C2 -> B2)
(g1 : A1 -> B1) (g2 : B2 -> A2),
  fmap _ _ _ _ f1 f2 oo fmap _ _ _ _ g1 g2 = fmap _ _ _ _ (f1 oo g1) (g2 oo f2)
}.

Record functor : Type := Functor {
  _functor: Type -> Type -> Type;
  fmap : forall A1 B1 A2 B2 (f1 : A1 -> B1) (f2 : B2 -> A2),
    _functor A1 A2 -> _functor B1 B2;
  functor_facts : functorFacts _functor fmap
}.

End CoContraVariantBiFunctor.

Coercion CovariantFunctor._functor:
  CovariantFunctor.functor >-> Funclass.
Coercion ContraVariantFunctor._functor:
  ContraVariantFunctor.functor >-> Funclass.
Coercion MixVariantFunctor._functor:
  MixVariantFunctor.functor >-> Funclass.
Coercion CovariantBiFunctor._functor:
  CovariantBiFunctor.functor >-> Funclass.
Coercion CoContraVariantBiFunctor._functor:
  CoContraVariantBiFunctor.functor >-> Funclass.

Module CovariantFunctorLemmas.

Import CovariantFunctor.

Lemma fmap_id {F: functor} : forall A, fmap F (id A) = id (F A).
Proof. intros. destruct F as [F FM [ff_id ?]]; simpl. apply ff_id. Qed.

Lemma fmap_comp {F: functor} : forall A B C (f : B -> C) (g : A -> B),
  fmap F f oo fmap F g = fmap F (f oo g).
Proof. intros. destruct F as [F FM [? ff_comp]]; simpl. apply ff_comp. Qed.

Lemma fmap_app {F: functor} : forall A B C (f : B -> C) (g : A -> B) x,
  fmap F f (fmap F g x) = fmap F (f oo g) x.
Proof. intros. rewrite <- fmap_comp; auto. Qed.

End CovariantFunctorLemmas.

Module ContraVariantFunctorLemmas.

Import ContraVariantFunctor.

Lemma fmap_id {F: functor} : forall A, fmap F (id A) = id (F A).
Proof. intros. destruct F as [F FM [ff_id ?]]; simpl. apply ff_id. Qed.

Lemma fmap_comp {F: functor} : forall A B C (f : C -> B) (g : B -> A),
  fmap F f oo fmap F g = fmap F (g oo f).
Proof. intros. destruct F as [F FM [? ff_comp]]; simpl. apply ff_comp. Qed.

Lemma fmap_app {F: functor} : forall A B C (f : C -> B) (g : B -> A) x,
  fmap F f (fmap F g x) = fmap F (g oo f) x.
Proof. intros. rewrite <- fmap_comp; auto. Qed.

End ContraVariantFunctorLemmas.

Module MixVariantFunctorLemmas.

Import MixVariantFunctor.

Lemma fmap_id {F: functor} : forall A, fmap F (id A) (id A) = id (F A).
Proof. intros. destruct F as [F FM [ff_id ?]]; simpl. apply ff_id. Qed.

Lemma fmap_comp {F: functor} : forall A B C (f1 : B -> C) (f2: C -> B)
(g1 : A -> B) (g2: B -> A),
  fmap F f1 f2 oo fmap F g1 g2 = fmap F (f1 oo g1) (g2 oo f2).
Proof. intros. destruct F as [F FM [? ff_comp]]; simpl. apply ff_comp. Qed.

Lemma fmap_app {F: functor} : forall A B C (f1 : B -> C) (f2: C -> B)
(g1 : A -> B) (g2: B -> A) x,
  fmap F f1 f2 (fmap F g1 g2 x) = fmap F (f1 oo g1) (g2 oo f2) x.
Proof. intros. rewrite <- fmap_comp; auto. Qed.

End MixVariantFunctorLemmas.

Module CovariantBiFunctorLemmas.

Import CovariantBiFunctor.

Lemma fmap_id {F: functor} : forall A1 A2, fmap F (id A1) (id A2) = id (F A1 A2).
Proof. intros. destruct F as [F FM [ff_id ?]]; simpl. apply ff_id. Qed.

Lemma fmap_comp {F: functor} : forall A1 A2 B1 B2 C1 C2 (f1 : B1 -> C1)
(f2: B2 -> C2) (g1 : A1 -> B1) (g2: A2 -> B2),
  fmap F f1 f2 oo fmap F g1 g2 = fmap F (f1 oo g1) (f2 oo g2).
Proof. intros. destruct F as [F FM [? ff_comp]]; simpl. apply ff_comp. Qed.

Lemma fmap_app {F: functor} : forall A1 A2 B1 B2 C1 C2 (f1 : B1 -> C1)
(f2: B2 -> C2) (g1 : A1 -> B1) (g2: A2 -> B2) x,
  fmap F f1 f2 (fmap F g1 g2 x) = fmap F (f1 oo g1) (f2 oo g2) x.
Proof. intros. rewrite <- fmap_comp; auto. Qed.

End CovariantBiFunctorLemmas.

Module CoContraVariantBiFunctorLemmas.

Import CoContraVariantBiFunctor.

Lemma fmap_id {F: functor} : forall A1 A2, fmap F (id A1) (id A2) = id (F A1 A2).
Proof. intros. destruct F as [F FM [ff_id ?]]; simpl. apply ff_id. Qed.

Lemma fmap_comp {F: functor} : forall A1 A2 B1 B2 C1 C2 (f1 : B1 -> C1)
(f2: C2 -> B2) (g1 : A1 -> B1) (g2: B2 -> A2),
  fmap F f1 f2 oo fmap F g1 g2 = fmap F (f1 oo g1) (g2 oo f2).
Proof. intros. destruct F as [F FM [? ff_comp]]; simpl. apply ff_comp. Qed.

Lemma fmap_app {F: functor} : forall A1 A2 B1 B2 C1 C2 (f1 : B1 -> C1)
(f2: C2 -> B2) (g1 : A1 -> B1) (g2: B2 -> A2) x,
  fmap F f1 f2 (fmap F g1 g2 x) = fmap F (f1 oo g1) (g2 oo f2) x.
Proof. intros. rewrite <- fmap_comp; auto. Qed.

End CoContraVariantBiFunctorLemmas.

Module GeneralFunctorGenerator.

Definition CovariantFunctor_MixVariantFunctor (F: CovariantFunctor.functor):
  MixVariantFunctor.functor.
  refine (@MixVariantFunctor.Functor
   (fun T => F T)
   (fun A B f _ => CovariantFunctor.fmap F f) _).
  constructor; intros; simpl.
  + apply CovariantFunctor.ff_id, CovariantFunctor.functor_facts.
  + apply CovariantFunctor.ff_comp, CovariantFunctor.functor_facts.
Defined.

Definition ContraVariantFunctor_MixVariantFunctor
 (F: ContraVariantFunctor.functor):
  MixVariantFunctor.functor.
  refine (@MixVariantFunctor.Functor
   (fun T => F T)
   (fun A B _ f => ContraVariantFunctor.fmap F f) _).
  constructor; intros; simpl.
  + apply ContraVariantFunctor.ff_id, ContraVariantFunctor.functor_facts.
  + apply ContraVariantFunctor.ff_comp, ContraVariantFunctor.functor_facts.
Defined.

Definition CovariantFunctor_CoContraVariantBiFunctor
 (F: CovariantFunctor.functor):
  CoContraVariantBiFunctor.functor.
  refine (@CoContraVariantBiFunctor.Functor
   (fun T1 T2 => F T1)
   (fun A B C D f _ => CovariantFunctor.fmap F f) _).
  constructor; intros; simpl.
  + apply CovariantFunctor.ff_id, CovariantFunctor.functor_facts.
  + apply CovariantFunctor.ff_comp, CovariantFunctor.functor_facts.
Defined.

Definition CoContraVariantBiFunctor_MixVariantFunctor
 (F: CoContraVariantBiFunctor.functor):
  MixVariantFunctor.functor.
  refine (@MixVariantFunctor.Functor
   (fun T => F T T)
   (fun A B f g => CoContraVariantBiFunctor.fmap F f g) _).
  constructor; intros; simpl.
  + apply CoContraVariantBiFunctor.ff_id,
          CoContraVariantBiFunctor.functor_facts.
  + apply CoContraVariantBiFunctor.ff_comp,
          CoContraVariantBiFunctor.functor_facts.
Defined.

Definition CovariantFunctor_CovariantFunctor_compose
(F1 F2: CovariantFunctor.functor):
  CovariantFunctor.functor.
  refine (@CovariantFunctor.Functor
   (fun T => F1 (F2 T))
   (fun A B f => CovariantFunctor.fmap F1 (CovariantFunctor.fmap F2 f)) _).
  constructor; intros; simpl.
  + rewrite !CovariantFunctorLemmas.fmap_id; auto.
  + rewrite !CovariantFunctorLemmas.fmap_comp; auto.
Defined.

Definition CovariantFunctor_MixVariantFunctor_compose
(F1: CovariantFunctor.functor) (F2: MixVariantFunctor.functor):
  MixVariantFunctor.functor.
  refine (@MixVariantFunctor.Functor
   (fun T => F1 (F2 T))
   (fun A B f g => CovariantFunctor.fmap F1 (MixVariantFunctor.fmap F2 f g)) _).
  constructor; intros; simpl.
  + rewrite MixVariantFunctorLemmas.fmap_id, CovariantFunctorLemmas.fmap_id; auto.
  + rewrite !CovariantFunctorLemmas.fmap_comp, MixVariantFunctorLemmas.fmap_comp; auto.
Defined.

Definition CovariantBiFunctor_CovariantFunctor_compose
(F: CovariantBiFunctor.functor)
(F1 F2: CovariantFunctor.functor):
  CovariantFunctor.functor.
  refine (@CovariantFunctor.Functor
   (fun T => F (F1 T) (F2 T))
   (fun A B f => CovariantBiFunctor.fmap F
      (CovariantFunctor.fmap F1 f) (CovariantFunctor.fmap F2 f)) _).
  constructor; intros; simpl.
  + rewrite !CovariantFunctorLemmas.fmap_id, CovariantBiFunctorLemmas.fmap_id; auto.
  + rewrite CovariantBiFunctorLemmas.fmap_comp, !CovariantFunctorLemmas.fmap_comp; auto.
Defined.

Definition CovariantBiFunctor_MixVariantFunctor_compose
(F: CovariantBiFunctor.functor)
(F1 F2: MixVariantFunctor.functor):
  MixVariantFunctor.functor.
  refine (@MixVariantFunctor.Functor
   (fun T => F (F1 T) (F2 T))
   (fun A B f g => CovariantBiFunctor.fmap F
      (MixVariantFunctor.fmap F1 f g) (MixVariantFunctor.fmap F2 f g)) _).
  constructor; intros; simpl.
  + rewrite !MixVariantFunctorLemmas.fmap_id, CovariantBiFunctorLemmas.fmap_id; auto.
  + rewrite CovariantBiFunctorLemmas.fmap_comp, !MixVariantFunctorLemmas.fmap_comp; auto.
Defined.

Definition CoContraVariantBiFunctor_CoContraVariantFunctor_compose
(F: CoContraVariantBiFunctor.functor)
(F1: CovariantFunctor.functor)
(F2: ContraVariantFunctor.functor):
  CovariantFunctor.functor.
  refine (@CovariantFunctor.Functor
   (fun T => F (F1 T) (F2 T))
   (fun A B f => CoContraVariantBiFunctor.fmap F
      (CovariantFunctor.fmap F1 f) (ContraVariantFunctor.fmap F2 f)) _).
  constructor; intros; simpl.
  + rewrite CovariantFunctorLemmas.fmap_id, ContraVariantFunctorLemmas.fmap_id, CoContraVariantBiFunctorLemmas.fmap_id; auto.
  + rewrite CoContraVariantBiFunctorLemmas.fmap_comp, CovariantFunctorLemmas.fmap_comp, ContraVariantFunctorLemmas.fmap_comp; auto.
Defined.

Definition CoContraVariantBiFunctor_MixVariantFunctor_compose
(F: CoContraVariantBiFunctor.functor)
(F1 F2: MixVariantFunctor.functor):
  MixVariantFunctor.functor.
  refine (@MixVariantFunctor.Functor
   (fun T => F (F1 T) (F2 T))
   (fun A B f g => CoContraVariantBiFunctor.fmap F
      (MixVariantFunctor.fmap F1 f g) (MixVariantFunctor.fmap F2 g f)) _).
  constructor; intros; simpl.
  + rewrite !MixVariantFunctorLemmas.fmap_id, CoContraVariantBiFunctorLemmas.fmap_id; auto.
  + rewrite CoContraVariantBiFunctorLemmas.fmap_comp, !MixVariantFunctorLemmas.fmap_comp; auto.
Defined.

End GeneralFunctorGenerator.

Module CovariantBiFunctorGenerator.

Import CovariantBiFunctor.
Import CovariantBiFunctorLemmas.

Definition Fpair: functor.
  refine (@Functor
   (fun T1 T2 => prod T1 T2)
   (fun _ _ _ _ f1 f2 x => (f1 (fst x), f2 (snd x))) _).
  constructor; intros; simpl; auto.
  extensionality p; destruct p as [a1 a2]; simpl; auto.
Defined.

Definition Fchoice: functor.
  refine (@Functor
   (fun T1 T2 => sum T1 T2)
   (fun _ _ _ _ f1 f2 x =>
      match x with
      | inl x => inl (f1 x)
      | inr x => inr (f2 x)
      end) _).
  constructor; intros; simpl.
  + extensionality c.
    destruct c; auto.
  + extensionality c.
    destruct c; unfold compose; simpl; auto.
Defined.

End CovariantBiFunctorGenerator.

Module CoContraVariantBiFunctorGenerator.

Import CoContraVariantBiFunctor.
Import CoContraVariantBiFunctorLemmas.

Definition Ffunc: functor.
  refine (@Functor
   (fun T1 T2 => T2 -> T1)
   (fun _ _ _ _ f1 f2 x => fun a => f1 (x (f2 a))) _).
  constructor; intros; simpl; auto.
Defined.

End CoContraVariantBiFunctorGenerator.

Module CovariantFunctorGenerator.

Import CovariantFunctor.
Import CovariantFunctorLemmas.

Definition fconst (T : Type): functor.
  refine (@Functor (fun _ => T) (fun _ _ _ x => x) _).
  constructor; intros; auto.
Defined.

Definition fidentity: functor.
  refine (@Functor (fun T => T) (fun _ _ f => f) _).
  constructor; intros; auto.
Defined.

Definition Foption: functor.
  refine (@Functor (fun T => option T)
   (fun _ _ f x => match x with Some x0 => Some (f x0) | _ => None end) _).
  constructor; intros; simpl; auto.
  + extensionality x; destruct x; auto.
  + extensionality x; destruct x; auto.
Defined.

Definition Flist: functor.
  refine (@Functor (fun T => list T)
   (fun _ _ f x => map f x) _).
  constructor; intros; simpl; auto.
  + extensionality x; apply map_id.
  + extensionality x; apply map_map.
Defined.

Definition fpair (F1 F2: functor): functor :=
  GeneralFunctorGenerator.CovariantBiFunctor_CovariantFunctor_compose
  CovariantBiFunctorGenerator.Fpair
  F1
  F2.

Goal forall (F1 F2: functor) (T: Type), fpair F1 F2 T = prod (F1 T) (F2 T).
reflexivity.
Qed.

Definition fchoice (F1 F2: functor): functor :=
  GeneralFunctorGenerator.CovariantBiFunctor_CovariantFunctor_compose
  CovariantBiFunctorGenerator.Fchoice
  F1
  F2.

Definition foption (F: functor): functor :=
  GeneralFunctorGenerator.CovariantFunctor_CovariantFunctor_compose
  Foption
  F.

Definition flist (F: functor): functor :=
  GeneralFunctorGenerator.CovariantFunctor_CovariantFunctor_compose
  Flist
  F.

Goal forall (F : functor) (T: Type), foption F T = option (F T).
reflexivity.
Qed.

Definition ffunc (F1: ContraVariantFunctor.functor) (F2: functor): functor :=
  GeneralFunctorGenerator.CoContraVariantBiFunctor_CoContraVariantFunctor_compose
  CoContraVariantBiFunctorGenerator.Ffunc
  F2
  F1.

Goal forall (F1 : ContraVariantFunctor.functor) (F2: functor) (T: Type),
  ffunc F1 F2 T = (F1 T -> F2 T).
reflexivity.
Qed.

Definition fsig {I: Type} (F: I -> functor): functor.
  refine (@Functor
   (fun T => @sigT I (fun i => F i T))
   (fun _ _ f x => match x with existT _ i x0 => existT _ i (fmap (F i) f x0) end) _).
  constructor; intros; simpl.
  + extensionality p; destruct p as [i a]; simpl.
    rewrite !fmap_id; auto.
  + extensionality p; destruct p as [i a]; simpl.
    unfold compose at 1. rewrite !fmap_app; auto.
Defined.

Definition fsubset (F: functor) (P: forall A, F A -> Prop)
  (Pfmap: forall A B (f: A -> B) x, P A x -> P B (fmap F f x)): functor.
  refine (@Functor
   (fun T => {x: F T | P T x})
   (fun _ _ f x =>
      match x with exist _ x' H => exist _ (fmap F f x')
                                           (Pfmap _ _ f x' H) end) _).
  constructor; intros; simpl.
  + extensionality x; destruct x as [x ?H].
    apply exist_ext.
    rewrite !fmap_id; auto.
  + extensionality x; destruct x as [x ?H].
    apply exist_ext.
    rewrite !fmap_app; auto.
Defined.

End CovariantFunctorGenerator.

Module MixVariantFunctorGenerator.

Import MixVariantFunctor.
Import MixVariantFunctorLemmas.

Definition fconst (T : Type): functor :=
  GeneralFunctorGenerator.CovariantFunctor_MixVariantFunctor
  (CovariantFunctorGenerator.fconst T).

Definition fidentity: functor :=
  GeneralFunctorGenerator.CovariantFunctor_MixVariantFunctor
  CovariantFunctorGenerator.fidentity.

Definition fpair (F1 F2: functor): functor :=
  GeneralFunctorGenerator.CovariantBiFunctor_MixVariantFunctor_compose
  CovariantBiFunctorGenerator.Fpair
  F1
  F2.

Definition fchoice (F1 F2: functor): functor :=
  GeneralFunctorGenerator.CovariantBiFunctor_MixVariantFunctor_compose
  CovariantBiFunctorGenerator.Fchoice
  F1
  F2.

Definition foption (F: functor): functor :=
  GeneralFunctorGenerator.CovariantFunctor_MixVariantFunctor_compose
  CovariantFunctorGenerator.Foption
  F.

Definition flist (F: functor): functor :=
  GeneralFunctorGenerator.CovariantFunctor_MixVariantFunctor_compose
  CovariantFunctorGenerator.Flist
  F.

Definition ffunc (F1 F2: functor): functor :=
  GeneralFunctorGenerator.CoContraVariantBiFunctor_MixVariantFunctor_compose
  CoContraVariantBiFunctorGenerator.Ffunc
  F2
  F1.

Definition fsig {I: Type} (F: I -> functor): functor.
  refine (@Functor
   (fun T => @sigT I (fun i => F i T))
   (fun _ _ f g x => match x with existT _ i x0 => existT _ i (fmap (F i) f g x0) end) _).
  constructor; intros; simpl.
  + extensionality p; destruct p as [i a]; simpl.
    rewrite !fmap_id; auto.
  + extensionality p; destruct p as [i a]; simpl.
    unfold compose at 1. rewrite !fmap_app; auto.
Defined.

Definition fpi {I: Type} (F: I -> functor): functor.
  refine (@Functor
   (fun T => forall i: I, F i T)
   (fun _ _ f g x => fun i => fmap (F i) f g (x i)) _).
  constructor; intros; simpl.
  + extensionality p i; simpl.
    rewrite !fmap_id; auto.
  + extensionality p i; simpl.
    unfold compose at 1. rewrite !fmap_app; auto.
Defined.

Definition fsubset (F: functor) (P: forall A, F A -> Prop)
  (Pfmap: forall A B f g x, P A x -> P B (fmap F f g x)): functor.
  refine (@Functor
   (fun T => {x: F T | P T x})
   (fun _ _ f g x =>
      match x with exist _ x' H => exist _ (fmap F f g x')
                                           (Pfmap _ _ f g x' H) end) _).
  constructor; intros; simpl.
  + extensionality x; destruct x as [x ?H].
    apply exist_ext.
    rewrite !fmap_id; auto.
  + extensionality x; destruct x as [x ?H].
    apply exist_ext.
    rewrite !fmap_app; auto.
Defined.

End MixVariantFunctorGenerator.

Unset Implicit Arguments.


(** Separation logic. *)

From Coq Require Import ZArith Lia Bool List Program.Equality.
From Coq Require Import FunctionalExtensionality PropExtensionality.
From CDF Require Import Sequences Separation.

Local Open Scope Z_scope.

(** * 1. A language of pointers *)

(** We now define a small programming language to work with pointers to
    mutable state.  The language has variables, but these variables are
    immutable.  This in unlike IMP but like ML: mutable variables are
    expressed as immutable pointers (references) to mutable state. *)

(** As in ML too, we blur the distinction between expressions and commands.
    Every command returns a value, which we take to be an integer,
    in addition to possibly performing effects. *)

(** We use higher-order abstract syntax to represent commands in this
    language.  With first-order abstract syntax, a "let" binding
    [let x = a in b] would be represented using the constructor
<<
    LET: forall (x: ident) (a b: com), com
>>
    With higher-order syntax, we use a Coq function [fun x => b] to
    represent the binding of [x] inside [b]:
<<
    LET: forall (a: com) (b: Z -> com), com
>>
    As a benefit, we can use any Coq expression of type [Z] as a
    pure command of the language, making it unnecessary to define
    syntax and semantics for a specific expression language.
*)

CoInductive com: Type :=
  | PURE (x: Z)                         (**r command without effects *)
  | LET (c: com) (f: Z -> com)          (**r sequencing of commands *)
  | IFTHENELSE (b: Z) (c1 c2: com)      (**r conditional *)
  | ALLOC (sz: nat)                     (**r allocate [sz] words of storage *)
  | GET (l: addr)                       (**r dereference a pointer *)
  | SET (l: addr) (v: Z)                (**r assign through a pointer *)
  | FREE (l: addr)                      (**r free one word of storage *)
  | PICK (n: Z).                        (**r pick a number between 0 and [n] *)

(** Some derived forms. *)

Definition SKIP: com := PURE 0.

Definition SEQ (c1 c2: com) := LET c1 (fun _ => c2).

Definition EITHER (c1 c2: com) := LET (PICK 2) (fun n => IFTHENELSE n c1 c2).

(** Reduction semantics. *)

Inductive red: com * heap -> com * heap -> Prop :=
  | red_pick: forall n i h,
      0 <= i < n ->
      red (PICK n, h) (PURE i, h)
  | red_let_done: forall x f h,
      red (LET (PURE x) f, h) (f x, h)
  | red_let_step: forall c f h c' h',
      red (c, h) (c', h') ->
      red (LET c f, h) (LET c' f, h')
  | red_ifthenelse: forall b c1 c2 h,
      red (IFTHENELSE b c1 c2, h) ((if b =? 0 then c2 else c1), h)
  | red_alloc: forall sz (h: heap) l,
      (forall i, l <= i < l + Z.of_nat sz -> h i = None) ->
      l <> 0 ->
      red (ALLOC sz, h) (PURE l, hinit l sz h)
  | red_get: forall l (h: heap) v,
      h l = Some v ->
      red (GET l, h) (PURE v, h)
  | red_set: forall l v (h: heap),
      h l <> None ->
      red (SET l v, h) (SKIP, hupdate l v h)
  | red_free: forall l (h: heap),
      h l <> None ->
      red (FREE l, h) (SKIP, hfree l h).

(** Absence of run-time errors. [immsafe c h] holds if [c / h] is not
    going to abort immediately on a run-time error, such as dereferencing
    an invalid pointer. *)

Inductive immsafe: com * heap -> Prop :=
  | immsafe_pure: forall v h,
      immsafe (PURE v, h)
  | immsafe_let: forall c f h,
      immsafe (c, h) -> immsafe (LET c f, h)
  | immsafe_ifthenelse: forall b c1 c2 h,
      immsafe (IFTHENELSE b c1 c2, h)
  | immsafe_alloc: forall sz (h: heap) l,
      l <> 0 -> (forall i, l <= i < l + Z.of_nat sz -> h i = None) ->
      immsafe (ALLOC sz, h)
  | immsafe_get: forall l (h: heap),
      h l <> None -> immsafe (GET l, h)
  | immsafe_set: forall l v (h: heap),
      h l <> None -> immsafe (SET l v, h)
  | immsafe_free: forall l (h: heap),
      h l <> None -> immsafe (FREE l, h)
  | immsafe_pick: forall n h,
      immsafe (PICK n, h).

(** * 2.  The rules of separation logic *)

Definition precond := assertion.
Definition postcond := Z -> assertion.

(** ** 2.1.  Semantic definition of strong triples *)

(** Instead of axiomatizing the rules of separation logic, then prove
    their soundness against the operational semantics, we define
    triples [ ⦃ P ⦄ c ⦃ Q ⦄ ] directly in terms of the
    operational semantics, then show the rules of separation logic as
    lemmas about these semantic triples.

    Note: the way triples are defined below, they are strong triples
    that guarantee termination.  However, we write them with braces
    instead of brackets, for consistency with the third lecture
    and with the literature on separation logic.
 *)

(** [safe c h Q] holds if [c] started in [h] always terminates without errors,
    and when it terminates with value [v], the postcondition [Q v] holds
    of the final heap. *)

Inductive safe: com -> heap -> postcond -> Prop :=
  | safe_done: forall v h (Q: postcond),
      Q v h ->
      safe (PURE v) h Q
  | safe_step: forall c h Q,
      match c with PURE _ => False | _ => True end ->
      immsafe (c, h) ->
      (forall c' h', red (c, h) (c', h') -> safe c' h' Q) ->
      safe c h Q.

(** We define semantic triples like we did for Hoare logic: *)

Definition triple (P: precond) (c: com) (Q: postcond) :=
  forall h, P h -> safe c h Q.

Notation "⦃ P ⦄ c ⦃ Q ⦄" := (triple P c Q) (at level 90, c at next level).

(** ** 2.2. The frame rule *)

(** The frame rule is valid because the operational semantics has nice
    properties with respect to heap extension: if a command is safe
    in a small heap, it is safe in a bigger heap, and any reduction
    from the bigger heap is simulated by a reduction from the smaller heap. *)

Ltac inv H := inversion H; clear H; subst.

Lemma immsafe_frame: forall h' c h,
  immsafe (c, h) -> hdisjoint h h' -> immsafe (c, hunion h h').
Proof.
  intros h' c h IMM; dependent induction IMM; intros DISJ.
- constructor.
- constructor; auto.
- constructor.
- destruct (isfinite (hunion h h')) as [l' FIN].
  apply immsafe_alloc with (Z.max 1 l').
  lia.
  intros. apply FIN. lia.
- constructor. cbn. destruct (h l); congruence.
- constructor. cbn. destruct (h l); congruence.
- constructor. cbn. destruct (h l); congruence.
- constructor.
Qed.

Lemma red_frame: forall h2 c h1 c' h',
  red (c, hunion h1 h2) (c', h') ->
  immsafe (c, h1) ->
  hdisjoint h1 h2 ->
  exists h1', red (c, h1) (c', h1') /\ hdisjoint h1' h2 /\ h' = hunion h1' h2.
Proof.
  intros until h'; intros RED; dependent induction RED; intros IMM DISJ; inv IMM.
- exists h1; intuition auto. constructor; auto.
- exists h1; intuition auto. constructor; auto.
- edestruct IHRED as (h1' & R & D & U); eauto.
  exists h1'; intuition auto. constructor; auto.
- exists h1; intuition auto. constructor; auto.
- exists (hinit l sz h1); intuition auto.
  + constructor; auto. intros. apply H in H1. cbn in H1. destruct (h1 i); congruence.
  + red; cbn; intros i.
    assert (EITHER: l <= i < l + Z.of_nat sz \/ (i < l \/ l + Z.of_nat sz <= i)) by lia.
    destruct EITHER.
    * right. apply H in H1. cbn in H1. destruct (h1 i), (h2 i); congruence.
    * rewrite hinit_outside by auto. apply DISJ.
  + apply heap_extensionality; intros i; cbn.
    assert (EITHER: l <= i < l + Z.of_nat sz \/ (i < l \/ l + Z.of_nat sz <= i)) by lia.
    destruct EITHER.
    * rewrite ! hinit_inside by auto. auto.
    * rewrite ! hinit_outside by auto. auto.
- exists h1; intuition auto. constructor; auto. cbn in H. destruct (h1 l); congruence.
- exists (hupdate l v h1); intuition auto.
  + constructor; auto.
  + intros i; cbn. generalize (DISJ i).
    destruct (Z.eq_dec l i); intuition congruence.
  + apply heap_extensionality; intros i; cbn.
    destruct (Z.eq_dec l i); auto.
- exists (hfree l h1); intuition auto.
  + constructor; auto.
  + intros i; cbn. generalize (DISJ i).
    destruct (Z.eq_dec l i); intuition congruence.
  + apply heap_extensionality; intros i; cbn.
    destruct (Z.eq_dec l i); auto.
    subst i. generalize (DISJ l). intuition.
Qed.

Lemma safe_frame:
  forall (R: assertion) h', R h' ->
  forall c h Q,
  safe c h Q -> hdisjoint h h' -> safe c (hunion h h') (fun v => Q v ** R).
Proof.
  induction 2; intros DISJ.
- constructor. exists h, h'; auto.
- constructor. auto. apply immsafe_frame; auto.
  intros. edestruct red_frame as (h1' & RED1 & D & U); eauto. subst h'0.
  apply H3; auto.
Qed.

Lemma triple_frame: forall P c Q R,
  ⦃ P ⦄ c ⦃ Q ⦄ ->
  ⦃ P ** R ⦄ c ⦃ fun v => Q v ** R ⦄.
Proof.
  intros P c Q R TR h (h1 & h2 & P1 & R2 & D & U). subst h.
  apply safe_frame; auto.
Qed.

(** ** 2.3. The "small rules" for heap operations *)

Lemma triple_get: forall l v,
  ⦃ contains l v ⦄ GET l ⦃ fun v' => (v' = v) //\\ contains l v ⦄.
Proof.
  intros l v h P.
  assert (L: h l = Some v).
  { red in P. subst h. apply hupdate_same. }
  constructor; auto.
  - constructor. congruence.
  - intros c' h' RED. inv RED. constructor. split; auto; congruence.
Qed.

Lemma triple_set: forall l v,
  ⦃ valid l ⦄ SET l v ⦃ fun _ => contains l v ⦄.
Proof.
  intros l v h (v0 & P).
  assert (L: h l = Some v0).
  { red in P; subst h; apply hupdate_same. }
  constructor; auto.
  - constructor. congruence.
  - intros c' h' RED. inv RED. constructor.
    red in P; subst h.
    red. apply heap_extensionality; intros l'; cbn.
    destruct (Z.eq_dec l l'); auto.
Qed.

Fixpoint valid_N (l: addr) (sz: nat) : assertion :=
  match sz with O => emp | S sz => valid l ** valid_N (l + 1) sz end.

Remark valid_N_init: forall sz l,
  (valid_N l sz) (hinit l sz hempty).
Proof.
  induction sz as [ | sz]; intros l; cbn.
- red; auto.
- exists (hupdate l 0 hempty), (hinit (l + 1) sz hempty); intuition auto.
  + exists 0. red; auto.
  + intros x. unfold hupdate, hempty; cbn. destruct (Z.eq_dec l x); auto.
  right. rewrite hinit_outside by lia. auto.
  + apply heap_extensionality; intros x. cbn. destruct (Z.eq_dec l x); auto.
Qed.

Lemma triple_alloc: forall sz,
  ⦃ emp ⦄
  ALLOC sz
  ⦃ fun l => (l <> 0) //\\ valid_N l sz ⦄.
Proof.
  intros sz h P. red in P. subst h.
  constructor; auto.
- apply immsafe_alloc with 1; intros.
  + lia.
  + auto.
- intros c' h' RED; inv RED. constructor.
  split; auto. apply valid_N_init; auto.
Qed.

Lemma triple_free: forall l,
  ⦃ valid l ⦄
  FREE l
  ⦃ fun _ => emp ⦄.
Proof.
  intros l h (v0 & P). red in P.
  assert (L: h l = Some v0).
  { subst h. apply hupdate_same. }
  constructor; auto.
- constructor. congruence.
- intros c' h' RED; inv RED. constructor.
  red. apply heap_extensionality; intros x. cbn.
  destruct (Z.eq_dec l x); auto.
Qed.

(** ** 2.4. Properties of the [safe] predicate *)

Lemma safe_pure: forall v h Q,
  safe (PURE v) h Q -> Q v h.
Proof.
  intros. inv H.
- auto.
- contradiction.
Qed.

Lemma safe_red: forall c h Q c' h',
  safe  c h Q -> red (c, h) (c', h') -> safe c' h' Q.
Proof.
  intros. inv H.
- inv H0.
- eauto.
Qed.

Lemma safe_immsafe: forall c h Q,
  safe c h Q -> immsafe (c, h).
Proof.
  intros. inv H.
- constructor.
- auto.
Qed.

Lemma safe_let: forall (Q R: postcond) f,
  (forall v h', Q v h' -> safe (f v) h' R) ->
  forall c h,
  safe c h Q ->
  safe (LET c f) h R.
Proof.
  intros Q R f POST. induction 1.
- constructor; auto.
  + constructor. constructor.
  + intros c' h' RED; inv RED. apply POST; auto. inv H1.
- constructor; auto.
  + constructor; auto.
  + intros c' h' RED; inv RED. contradiction. eauto.
Qed.

Lemma safe_consequence: forall (Q Q': postcond),
  (forall v, Q v -->> Q' v) ->
  forall c h, safe c h Q -> safe c h Q'.
Proof.
  intros Q Q' IMP. induction 1.
- apply safe_done. apply IMP. assumption.
- apply safe_step; auto.
Qed.

(** ** 2.5. Rules for control structures *)

Lemma triple_pure: forall P v (Q: postcond),
  P -->> Q v ->
  ⦃ P ⦄ PURE v ⦃ Q ⦄.
Proof.
  intros; intros h Ph. constructor. apply H; auto.
Qed.

Lemma triple_let:
  forall c f (P: precond) (Q R: postcond),
  ⦃ P ⦄ c ⦃ Q ⦄ ->
  (forall v, ⦃ Q v ⦄ f v ⦃ R ⦄) ->
  ⦃ P ⦄ LET c f ⦃ R ⦄.
Proof.
  intros until R; intros HR1 HR2 h Ph.
  apply safe_let with Q. apply HR2. apply HR1. auto.
Qed.

Lemma triple_ifthenelse: forall b c1 c2 P Q,
  ⦃ (b <> 0) //\\ P ⦄ c1 ⦃ Q ⦄ ->
  ⦃ (b = 0) //\\ P ⦄ c2 ⦃ Q ⦄ ->
  ⦃ P ⦄ IFTHENELSE b c1 c2 ⦃ Q ⦄.
Proof.
  intros until Q; intros HR1 HR2 h Ph. constructor; auto.
- constructor.
- intros c' h' RED; inv RED. destruct (Z.eqb_spec b 0).
  + apply HR2. split; auto.
  + apply HR1. split; auto.
Qed.

Lemma triple_consequence: forall P P' c Q' Q,
  ⦃ P' ⦄ c ⦃ Q' ⦄ ->
  P -->> P' -> (forall v, Q' v -->> Q v) ->
  ⦃ P ⦄ c ⦃ Q ⦄.
Proof.
  intros; red; intros. apply safe_consequence with Q'; auto.
Qed.

Lemma triple_pick: forall n,
  ⦃ emp ⦄
  PICK n
  ⦃ fun i => pure (0 <= i < n) ⦄.
Proof.
  intros n h Ph. constructor; auto.
- constructor.
- intros c' h' RED; inv RED. constructor. split; auto.
Qed.

(** ** 2.6.  Useful derived rules *)

(** The following rules are heavily used in the examples of section 3. *)

Lemma triple_consequence_pre: forall P P' c Q,
  ⦃ P' ⦄ c ⦃ Q ⦄ ->
  P -->> P' ->
  ⦃ P ⦄ c ⦃ Q ⦄.
Proof.
  intros. apply triple_consequence with P' Q; auto. intros; red; auto.
Qed.

Lemma triple_consequence_post: forall P c Q Q',
  ⦃ P ⦄ c ⦃ Q' ⦄ ->
  (forall v, Q' v -->> Q v) ->
  ⦃ P ⦄ c ⦃ Q ⦄.
Proof.
  intros. apply triple_consequence with P Q'; auto. red; auto.
Qed.

Lemma triple_lift_pure: forall (P: Prop) P' c Q,
  (P -> ⦃ P' ⦄ c ⦃ Q ⦄) ->
  ⦃ P //\\ P' ⦄ c ⦃ Q ⦄.
Proof.
  intros. intros h [P1 P2]. apply H; auto.
Qed.

Lemma triple_lift_exists: forall (X: Type) (P: X -> assertion) c Q,
  (forall x, ⦃ P x ⦄ c ⦃ Q ⦄) ->
  ⦃ aexists P ⦄ c ⦃ Q ⦄.
Proof.
  intros. intros h (x & Px). apply (H x); auto.
Qed.

Lemma triple_ifthen: forall b c1 c2 P Q,
  b <> 0 -> ⦃ P ⦄ c1 ⦃ Q ⦄ ->
  ⦃ P ⦄ IFTHENELSE b c1 c2 ⦃ Q ⦄.
Proof.
  intros. apply triple_ifthenelse; apply triple_lift_pure; intros.
- auto.
- lia.
Qed.

Lemma triple_ifelse: forall b c1 c2 P Q,
  b = 0 -> ⦃ P ⦄ c2 ⦃ Q ⦄ ->
  ⦃ P ⦄ IFTHENELSE b c1 c2 ⦃ Q ⦄.
Proof.
  intros. apply triple_ifthenelse; apply triple_lift_pure; intros.
- lia.
- auto.
Qed.

Lemma unroll_com: forall c,
  c = match c with
      | PURE x => PURE x
      | LET c f => LET c f
      | IFTHENELSE b c1 c2 => IFTHENELSE b c1 c2
      | ALLOC sz => ALLOC sz
      | GET l => GET l
      | SET l v => SET l v
      | FREE l => FREE l
      | PICK n => PICK n
      end.
Proof.
  destruct c; auto.
Qed.

(** * 3. Singly-linked lists *)

(** ** Representation predicate *)

(** Here is a separation logic assertion that describes the in-memory
    representation of a list.
-   [a] is the pointer to the list head (or 0 if the list is empty).
-   [l] is the Coq list of the list elements.
*)

Fixpoint list_at (a: addr) (l: list Z) : assertion :=
  match l with
  | nil => (a = 0) //\\ emp
  | h :: t => (a <> 0) //\\ aexists (fun a' => contains a h ** contains (a + 1) a' ** list_at a' t)
  end.

(** ** The "cons" operation *)

Definition list_cons (n: Z) (a: addr) : com :=
  LET (ALLOC 2) (fun a' => SEQ (SET a' n) (SEQ (SET (a' + 1) a) (PURE a'))).

Lemma list_cons_correct: forall a n l,
    ⦃ list_at a l ⦄
  list_cons n a
    ⦃ fun a' => list_at a' (n :: l) ⦄.
Proof.
  intros. eapply triple_let.
  rewrite <- sepconj_emp at 1. apply triple_frame. apply triple_alloc.
  intros b; simpl. rewrite lift_pureconj, ! sepconj_assoc, sepconj_emp.
  apply triple_lift_pure; intros H1.
  eapply triple_let. apply triple_frame. apply triple_set. simpl; intros _.
  eapply triple_let. rewrite sepconj_pick2.
  apply triple_frame. apply triple_set. simpl; intros _.
  rewrite sepconj_pick2.
  apply triple_pure. intros h A. split. auto. exists a; auto.
Qed.

(** ** Computing the length of a list *)

(** Taking advantage of the coinductive nature of type [com],
    we use infinite commands to represent loops and tail-recursive functions. *)

CoFixpoint list_length_rec (a: addr) (len: Z) : com :=
  IFTHENELSE a (LET (GET (a + 1)) (fun t => list_length_rec t (len + 1))) (PURE len).

Definition list_length (a: addr) : com := list_length_rec a 0.

(** Normally we would write
<<
   len = 0;
   while (a != 0) { a = get (a + 1); len = len + 1; }
>>
   With the coinductive definition, we write the equivalent infinite command
<<
   if (a == 0) return 0; else {
     a1 = get (a + 1);
     if (a1 == 0) return 1; else {
       a2 = get (a1 + 1);
       if (a2 == 0) return 2; else ...
>>
*)

Lemma list_length_rec_correct: forall l a len,
    ⦃ list_at a l ⦄
  list_length_rec a len
    ⦃ fun len' => (len' = len + Z.of_nat (List.length l)) //\\ list_at a l ⦄.
Proof.
Local Opaque Z.of_nat.
  induction l as [ | h t]; intros; rewrite (unroll_com (list_length_rec a len)); cbn.
- apply triple_lift_pure; intro H1.
  apply triple_ifelse; auto.
  apply triple_pure. intros h H2. split. lia. split; auto.
- apply triple_lift_pure; intro H1.
  apply triple_lift_exists; intros a'.
  apply triple_ifthen; auto.
  eapply triple_let.
  rewrite sepconj_pick2. apply triple_frame. apply triple_get. simpl.
  intros a''. rewrite lift_pureconj. apply triple_lift_pure; intros H3. subst a''.
  rewrite sepconj_swap3.
  eapply triple_consequence_post.
  apply triple_frame. apply IHt. intros len'; simpl.
  rewrite lift_pureconj. rewrite <- sepconj_swap3, sepconj_pick2.
  intros h1 (A & B). split. lia. split. auto. exists a'; auto.
Qed.

Corollary list_length_correct: forall l a,
    ⦃ list_at a l ⦄
  list_length a
    ⦃ fun len => (len = Z.of_nat (length l)) //\\ list_at a l ⦄.
Proof.
  intros. apply list_length_rec_correct.
Qed.

(** ** Concatenating two lists in-place *)

(** In loop notation:
<<
  if (l1 == 0) return l2; else {
    t = get(l1 + 1);
    while (get (t + 1) != 0) t = get (t + 1);
    set (t + 1, l2);
    return l1;
  }
>>
*)

CoFixpoint list_concat_rec (a1 a2: addr) : com :=
  LET (GET (a1 + 1)) (fun t => IFTHENELSE t (list_concat_rec t a2) (SET (a1 + 1) a2)).

Definition list_concat (a1 a2: addr) : com :=
  IFTHENELSE a1 (SEQ (list_concat_rec a1 a2) (PURE a1)) (PURE a2).

Lemma list_concat_rec_correct: forall l2 a2 l1 a1,
  a1 <> 0 ->
    ⦃ list_at a1 l1 ** list_at a2 l2 ⦄
  list_concat_rec a1 a2
    ⦃ fun _ => list_at a1 (l1 ++ l2) ⦄.
Proof.
  induction l1 as [ | h1 t1]; intros; rewrite (unroll_com (list_concat_rec a1 a2)); simpl.
- rewrite lift_pureconj. apply triple_lift_pure; intros. lia.
- rewrite lift_pureconj. apply triple_lift_pure. intros H1.
  rewrite lift_aexists. apply triple_lift_exists. intros a'.
  rewrite sepconj_assoc.
  eapply triple_let.
  + rewrite sepconj_assoc, sepconj_pick2. apply triple_frame. apply triple_get.
  + intros t. simpl.
    rewrite lift_pureconj. apply triple_lift_pure. intros H2; subst t.
    apply triple_ifthenelse.
    * apply triple_lift_pure. intros H2.
      rewrite <- sepconj_assoc, sepconj_comm.
      eapply triple_consequence_post. apply triple_frame. apply IHt1. auto.
      simpl. intros _. rewrite sepconj_pick2, sepconj_swap3.
      intros h P. split; auto. exists a'; auto.
    * apply triple_lift_pure. intros H2.
      eapply triple_consequence_post.
      apply triple_frame.
      eapply triple_consequence_pre. apply triple_set.
      intros h P; exists a'; auto.
      simpl. intros _. rewrite sepconj_pick2, sepconj_pick3.
      destruct t1; simpl.
      ** rewrite lift_pureconj, sepconj_emp.
         intros h (A & B). split; auto. exists a2; auto.
      ** rewrite lift_pureconj. intros h (A & B). lia.
Qed.

Lemma list_concat_correct: forall l1 a1 l2 a2,
    ⦃ list_at a1 l1 ** list_at a2 l2 ⦄
  list_concat a1 a2
    ⦃ fun a => list_at a (l1 ++ l2) ⦄.
Proof.
  intros. unfold list_concat. apply triple_ifthenelse.
- apply triple_lift_pure; intros H1.
  eapply triple_let. apply list_concat_rec_correct; auto.
  simpl. intros _. apply triple_pure. red; auto.
- apply triple_lift_pure; intros H1.
  destruct l1; simpl.
  + apply triple_pure. rewrite lift_pureconj, sepconj_emp. intros h (A & B); auto.
  + rewrite lift_pureconj. apply triple_lift_pure. intros; lia.
Qed.

(** ** List reversal in place *)

(** In loop notation:
<<
  p = 0;
  while (l != 0) {
    n = get (l + 1);
    set (l + 1, p);
    p = l;
    l = n;
  }
  return p;
>>
*)

CoFixpoint list_rev_rec (a p: addr) : com :=
  IFTHENELSE a
    (LET (GET (a + 1)) (fun n =>
     SEQ (SET (a + 1) p)
         (list_rev_rec n a)))
    (PURE p).

Definition list_rev (a: addr) : com := list_rev_rec a 0.

Lemma list_rev_rec_correct: forall l a l' p,
    ⦃ list_at a l ** list_at p l' ⦄
  list_rev_rec a p
    ⦃ fun x => list_at x (List.rev_append l l') ⦄.
Proof.
  induction l as [ | hd l]; intros; rewrite (unroll_com (list_rev_rec a p)); simpl.
- rewrite lift_pureconj, sepconj_emp. apply triple_lift_pure; intros H1.
  apply triple_ifelse; auto. apply triple_pure. red; auto.
- rewrite lift_pureconj; apply triple_lift_pure; intros H1.
  rewrite lift_aexists; apply triple_lift_exists; intros a'.
  apply triple_ifthen; auto.
  eapply triple_let.
  rewrite ! sepconj_assoc, sepconj_pick2.
  apply triple_frame. apply triple_get. intros a''. simpl.
  rewrite lift_pureconj. apply triple_lift_pure. intros H3. subst a''.
  eapply triple_let.
  apply triple_frame. eapply triple_consequence_pre.
  apply triple_set.
  intros h P; exists a'; auto.
  simpl. intros _.
  rewrite sepconj_pick2, sepconj_pick3.
  eapply triple_consequence_pre.
  apply IHl.
  simpl. apply sepconj_imp_r. intros h A. split; auto. exists p; auto.
Qed.

Lemma list_rev_correct: forall a l,
    ⦃ list_at a l ⦄
  list_rev a
    ⦃ fun x => list_at x (List.rev l) ⦄.
Proof.
  intros. rewrite List.rev_alt.
  eapply triple_consequence_pre. apply list_rev_rec_correct.
  simpl. rewrite sepconj_comm, lift_pureconj, sepconj_emp.
  intros h A; split; auto.
Qed.

(** * 4. An alternate definition of separation logic triples *)

Module AlternateSeplog.

(** For some languages, the frame property for reductions (lemma
    [red_frame] above) does not hold, e.g. because allocations are
    deterministic.  Or maybe we do not want to prove the [red_frame]
    lemma.

    In this case, not all is lost: we can define our separation
    triples [ ⦃ P ⦄ c ⦃ Q ⦄ ] as Hoare triples plus framing. *)

Definition Hoare (P: precond) (c: com) (Q: postcond) : Prop :=
  forall h, P h -> safe c h Q.

Definition triple (P: precond) (c: com) (Q: postcond) :=
  forall (R: assertion), Hoare (P ** R) c (fun v => Q v ** R).

Notation "⦃ P ⦄ c ⦃ Q ⦄" := (triple P c Q) (at level 90, c at next level).

(** This definition validates the frame rule. *)

Lemma triple_frame: forall P c Q R,
  ⦃ P ⦄ c ⦃ Q ⦄ ->
  ⦃ P ** R ⦄ c ⦃ fun v => Q v ** R ⦄.
Proof.
  intros P c Q R TR R'. rewrite sepconj_assoc.
  replace (fun v => (Q v ** R) ** R') with (fun v => Q v ** (R ** R')).
  apply TR.
  apply functional_extensionality; intros. rewrite sepconj_assoc; auto.
Qed.

(** It also validates the "small rules" for heap operations. *)

Lemma triple_get: forall l v,
  ⦃ contains l v ⦄ GET l ⦃ fun v' => (v' = v) //\\ contains l v ⦄.
Proof.
  intros l v R h (h1 & h2 & H1 & H2 & D & U).
  assert (L1: h1 l = Some v).
  { red in H1. subst h1. apply hupdate_same. }
  assert (L: h l = Some v).
  { intros. rewrite U; simpl. rewrite L1; auto. }
  constructor; auto.
  - constructor. congruence.
  - intros c' h' RED. inv RED. constructor.
    exists h1, h2. unfold pureconj. intuition congruence.
Qed.

Lemma triple_set: forall l v,
  ⦃ valid l ⦄ SET l v ⦃ fun _ => contains l v ⦄.
Proof.
  intros l v R h (h1 & h2 & H1 & H2 & D & U).
  destruct H1 as (v0 & H1). red in H1.
  assert (L1: h1 l = Some v0).
  { subst h1; apply hupdate_same. }
  assert (L: h l = Some v0).
  { rewrite U; cbn. rewrite L1; auto. }
  constructor; auto.
  - constructor. congruence.
  - intros c' h' RED. inv RED. constructor.
    exists (hupdate l v hempty), h2.
    split. red. auto.
    split. auto.
    split. intro l'. specialize (D l'). cbn in *. destruct D; auto. destruct (Z.eq_dec l l'); auto. congruence.
    apply heap_extensionality; intros l'; cbn. destruct (Z.eq_dec l l'); auto.
Qed.

Remark valid_N_init:
  forall (R: assertion) sz l h,
  R h ->
  (forall i, l <= i < l + Z.of_nat sz -> h i = None) ->
  (valid_N l sz ** R) (hinit l sz h).
Proof.
  induction sz as [ | sz]; intros l h Rh EMPTY; cbn.
- rewrite sepconj_emp. auto.
- rewrite sepconj_assoc. exists (hupdate l 0 hempty), (hinit (l + 1) sz h).
  split. exists 0. red; auto.
  split. apply IHsz. auto. intros. apply EMPTY. lia.
  split. intros x. unfold hupdate, hempty; cbn. destruct (Z.eq_dec l x); auto.
  right. rewrite hinit_outside by lia. apply EMPTY; lia.
  apply heap_extensionality; intros x. cbn. destruct (Z.eq_dec l x); auto.
Qed.

Lemma triple_alloc: forall sz,
  ⦃ emp ⦄
  ALLOC sz
  ⦃ fun l => (l <> 0) //\\ valid_N l sz ⦄.
Proof.
  intros sz R h H. rewrite sepconj_emp in H.
  constructor; auto.
- destruct (isfinite h) as (l0 & FIN). apply immsafe_alloc with (Z.max l0 1); intros.
  + lia.
  + apply FIN. lia.
- intros c' h' RED; inv RED. constructor.
  rewrite lift_pureconj; split. auto. apply valid_N_init; auto.
Qed.

Lemma triple_free: forall l,
  ⦃ valid l ⦄
  FREE l
  ⦃ fun _ => emp ⦄.
Proof.
  intros l R h (h1 & h2 & H1 & H2 & D & U).
  destruct H1 as (v0 & H1).
  assert (L1: h1 l = Some v0).
  { rewrite H1. apply hupdate_same. }
  assert (L: h l = Some v0).
  { rewrite U; cbn. rewrite L1. auto. }
  constructor; auto.
- constructor. congruence.
- intros c' h' RED; inv RED. constructor. rewrite sepconj_emp.
  replace (hfree l (hunion h1 h2)) with h2; auto.
  apply heap_extensionality; intros x. generalize (D x); rewrite H1; cbn.
  destruct (Z.eq_dec l x); auto. intuition congruence.
Qed.

(** The rules for control structures are also valid.
    Proof plan: first show Hoare-style rules for the [Hoare] triple,
    then frame by an arbitrary [R] to obtain the separation triple. *)

Lemma Hoare_pure: forall P v (Q: postcond),
  P -->> Q v ->
  Hoare P (PURE v) Q.
Proof.
  intros; intros h Ph. constructor. apply H; auto.
Qed.

Lemma triple_pure: forall P v (Q: postcond),
  P -->> Q v ->
  ⦃ P ⦄ PURE v ⦃ Q ⦄.
Proof.
  intros; intros R. apply Hoare_pure. apply sepconj_imp_l; auto.
Qed.

Lemma Hoare_let:
  forall c f (P: precond) (Q R: postcond),
  Hoare P c Q ->
  (forall v, Hoare (Q v) (f v) R) ->
  Hoare P (LET c f) R.
Proof.
  intros until R; intros HR1 HR2 h Ph.
  apply safe_let with Q. apply HR2. apply HR1. auto.
Qed.

Lemma triple_let:
  forall c f (P: precond) (Q R: postcond),
  ⦃ P ⦄ c ⦃ Q ⦄ ->
  (forall v, ⦃ Q v ⦄ f v ⦃ R ⦄) ->
  ⦃ P ⦄ LET c f ⦃ R ⦄.
Proof.
  intros c f P Q R TR1 TR2 R'.
  apply Hoare_let with (fun v => Q v ** R').
  apply TR1.
  intros. apply TR2.
Qed.

Lemma Hoare_ifthenelse: forall b c1 c2 P Q,
  Hoare ((b <> 0) //\\ P) c1 Q ->
  Hoare ((b = 0) //\\ P) c2 Q ->
  Hoare P (IFTHENELSE b c1 c2) Q.
Proof.
  intros until Q; intros HR1 HR2 h Ph. constructor; auto.
- constructor.
- intros c' h' RED; inv RED. destruct (Z.eqb_spec b 0).
  + apply HR2. split; auto.
  + apply HR1. split; auto.
Qed.

Lemma triple_ifthenelse: forall b c1 c2 P Q,
  ⦃ (b <> 0) //\\ P ⦄ c1 ⦃ Q ⦄ ->
  ⦃ (b = 0) //\\ P ⦄ c2 ⦃ Q ⦄ ->
  ⦃ P ⦄ IFTHENELSE b c1 c2 ⦃ Q ⦄.
Proof.
  intros b c1 c2 P Q TR1 TR2 R.
  apply Hoare_ifthenelse; rewrite <- lift_pureconj; auto.
Qed.

Lemma Hoare_consequence: forall P P' c Q' Q,
  Hoare P' c Q' ->
  P -->> P' -> (forall v, Q' v -->> Q v) ->
  Hoare P c Q.
Proof.
  intros; red; intros. apply safe_consequence with Q'; auto.
Qed.

Lemma triple_consequence: forall P P' c Q' Q,
  ⦃ P' ⦄ c ⦃ Q' ⦄ ->
  P -->> P' -> (forall v, Q' v -->> Q v) ->
  ⦃ P ⦄ c ⦃ Q ⦄.
Proof.
  intros; red; intros. apply Hoare_consequence with (P' ** R) (fun v => Q' v ** R).
  apply H.
  apply sepconj_imp_l; auto.
  intros; apply sepconj_imp_l; auto.
Qed.

Lemma Hoare_pick: forall P n,
  Hoare P (PICK n) (fun i => (0 <= i < n) //\\ P).
Proof.
  intros P n h Ph. constructor; auto.
- constructor.
- intros c' h' RED; inv RED. constructor. split; auto.
Qed.

Lemma triple_pick: forall n,
  ⦃ emp ⦄
  PICK n
  ⦃ fun i => pure (0 <= i < n) ⦄.
Proof.
  intros; intros R. rewrite sepconj_emp. eapply Hoare_consequence with (P' := R). apply Hoare_pick.
  red; auto.
  intros; red; intros. rewrite pureconj_sepconj. auto.
Qed.

End AlternateSeplog.

(** * 5. Ramification *)

(** Assume we have a triple [{P'} c {Q'}] and we want to conclude [{P} c {Q}].
    In general, we need to frame the former triple by an appropriate [R],
    then use the consequence rule to conclude. *)

Lemma triple_frame_consequence: forall R P c Q P' Q',
  ⦃ P ⦄ c ⦃ Q ⦄ ->
  P' -->> P ** R ->
  (forall v, Q v ** R -->> Q' v) ->
  ⦃ P' ⦄ c ⦃ Q' ⦄.
Proof.
  intros. apply triple_consequence with (P ** R) (fun v => Q v ** R); auto. apply triple_frame; auto.
Qed.

(** This rule still needs the user to guess the framing predicate [R].
    An alternate presentation uses the magic wand instead.
    This approach is called "ramification" in the literature. *)

Lemma triple_ramification: forall P c Q P' Q',
 ⦃ P ⦄ c ⦃ Q ⦄ ->
  P' -->> P ** (aforall (fun v => Q v --* Q' v)) ->
  ⦃ P' ⦄ c ⦃ Q' ⦄.
Proof.
  intros. eapply triple_frame_consequence with (R := aforall (fun v => Q v --* Q' v)).
  eassumption.
  assumption.
  intros v h (h1 & h2 & Q1 & W2 & D & U).
  apply (wand_cancel (Q v)). exists h1, h2; auto.
Qed.

(** * 6. Weakest preconditions *)

(** ** 6.1.  Definition and characterization *)

(** Here is one possible definition of the weakest precondition for
    command [c] with postcondition [Q]. *)

Definition wp (c: com) (Q: postcond) : precond :=
  aexists (fun P => ⦃ P ⦄ c ⦃ Q ⦄ //\\ P).

(** What matters about [wp c Q] is that it is a precondition... *)

Lemma wp_precond: forall c Q,
  ⦃ wp c Q ⦄ c ⦃ Q ⦄.
Proof.
  intros c Q h (P & T & C). apply T. auto.
Qed.

(** ... and it is implied by any other precondition. *)

Lemma wp_weakest: forall P c Q,
  ⦃ P ⦄ c ⦃ Q ⦄ ->
  P -->> wp c Q.
Proof.
  intros P c Q T h Ph. exists P; split; auto.
Qed.

(** This leads to the following alternate definition of triples in terms
    of weakest preconditions. *)

Corollary wp_equiv: forall P c Q,
  ⦃ P ⦄ c ⦃ Q ⦄ <-> (P -->> wp c Q).
Proof.
  intros; split; intros.
- apply wp_weakest; auto.
- apply triple_consequence_pre with (wp c Q); auto using wp_precond.
Qed.

(** Here is another definition of the weakest precondition, using the
    operational semantics directly. *)

Definition wp' (c: com) (Q: postcond) : precond :=
  fun h => safe c h Q.

Lemma wp'_precond: forall c Q,
  ⦃ wp' c Q ⦄ c ⦃ Q ⦄.
Proof.
  intros c Q h SAFE. apply SAFE.
Qed.

Lemma wp'_weakest: forall P c Q,
  ⦃ P ⦄ c ⦃ Q ⦄ ->
  P -->> wp' c Q.
Proof.
  intros; intros h Ph. apply H. auto.
Qed.

(** ** 6.2. Structural rules for weakest preconditions *)

Lemma wp_consequence: forall (Q Q': postcond) c,
  (forall v, Q v -->> Q' v) ->
  wp c Q -->> wp c Q'.
Proof.
  intros. apply wp_weakest. apply triple_consequence_post with Q; auto using wp_precond.
Qed.

Lemma wp_frame: forall R c Q,
  wp c Q ** R -->> wp c (fun v => Q v ** R).
Proof.
  intros. apply wp_weakest. apply triple_frame. apply wp_precond.
Qed.

Corollary wp_frame_consequence: forall R Q c Q',
  (forall v, Q v ** R -->> Q' v) ->
  wp c Q ** R -->> wp c Q'.
Proof.
  intros; red; intros. apply wp_consequence with (fun v => Q v ** R). assumption.
  apply wp_frame; auto.
Qed.

Corollary wp_ramification: forall c Q Q',
  wp c Q ** aforall (fun v => Q v --* Q' v) -->> wp c Q'.
Proof.
  intros. apply wp_frame_consequence.
  intros v h (h1 & h2 & A & B & D & U). apply (wand_cancel (Q v)). exists h1, h2; auto.
Qed.

(** ** 6.3.  Weakest precondition rules for our language of pointers *)

Lemma wp_pure: forall (Q: postcond) v,
  Q v -->> wp (PURE v) Q.
Proof.
  intros. apply wp_weakest. apply triple_pure. red; auto.
Qed.

Lemma wp_let: forall c f Q,
  wp c (fun v => wp (f v) Q) -->> wp (LET c f) Q.
Proof.
  intros. apply wp_weakest. eapply triple_let.
  apply wp_precond.
  intros. apply wp_precond.
Qed.

Lemma wp_ifthenelse: forall b c1 c2 Q,
  (if b =? 0 then wp c2 Q else wp c1 Q) -->> wp (IFTHENELSE b c1 c2) Q.
Proof.
  intros. apply wp_weakest. apply triple_ifthenelse.
- apply triple_consequence_pre with (wp c1 Q). apply wp_precond.
  intros h (A & B). rewrite <- Z.eqb_neq in A. rewrite A in B. auto.
- apply triple_consequence_pre with (wp c2 Q). apply wp_precond.
  intros h (A & B). subst b. auto.
Qed.

Lemma wp_alloc: forall sz Q,
  aforall (fun l => (l <> 0) //\\ valid_N l sz --* Q l) -->> wp (ALLOC sz) Q.
Proof.
  intros; red; intros.
  apply wp_ramification with (Q := fun l => (l <> 0) //\\ valid_N l sz).
  apply sepconj_imp_l with emp.
  apply wp_weakest. apply triple_alloc.
  rewrite sepconj_emp. assumption.
Qed.

Lemma wp_get: forall l v Q,
  contains l v ** (contains l v --* Q v) -->> wp (GET l) Q.
Proof.
  intros.
  assert (W: contains l v -->> wp (GET l) (fun v' => (v' = v) //\\ contains l v)).
  { apply wp_weakest. apply triple_get. }
  intros; red; intros.
  eapply wp_ramification. eapply sepconj_imp_l. eexact W.
  eapply sepconj_imp_r. 2: eexact H.
  intros h' H' v' h'' D (A & B). subst v'. apply H'; auto.
Qed.

Lemma wp_set: forall l v Q,
  valid l ** aforall (fun v' => (contains l v --* Q v')) -->> wp (SET l v) Q.
Proof.
  intros.
  assert (W: valid l -->> wp (SET l v) (fun _ => contains l v)).
  { apply wp_weakest. apply triple_set. }
  intros; red; intros.
  eapply wp_ramification. eapply sepconj_imp_l. eexact W.
  eapply sepconj_imp_r. 2: eexact H.
  red; auto.
Qed.

Corollary wp_set': forall l v Q,
  valid l ** (contains l v --* Q) -->> wp (SET l v) (fun _ => Q).
Proof.
  intros; red; intros. apply wp_set. eapply sepconj_imp_r; eauto.
  intros h' H' v'. auto.
Qed.

Lemma wp_free: forall l Q,
  valid l ** aforall (fun v' => Q v') -->> wp (FREE l) Q.
Proof.
  intros.
  assert (W: valid l -->> wp (FREE l) (fun _ => emp)).
  { apply wp_weakest. apply triple_free. }
  intros; red; intros.
  eapply wp_ramification. eapply sepconj_imp_l. eexact W.
  eapply sepconj_imp_r. 2: eexact H.
  red; intros. intros v h' D E. rewrite E in *. rewrite hunion_comm, hunion_empty by HDISJ.
  apply H0.
Qed.

Corollary wp_free': forall l Q,
  valid l ** Q -->> wp (FREE l) (fun _ => Q).
Proof.
  intros; red; intros. apply wp_free. eapply sepconj_imp_r; eauto.
  intros h' H' v'. auto.
Qed.

Lemma wp_pick: forall n Q,
  aforall (fun i => pure (0 <= i < n) --* Q i) -->> wp (PICK n) Q.
Proof.
  intros.
  assert (W: emp -->> wp (PICK n) (fun i => pure (0 <= i < n))).
  { apply wp_weakest. apply triple_pick. }
  intros; red; intros.
  eapply wp_ramification. eapply sepconj_imp_l. eexact W.
  eapply sepconj_imp_r. 2: rewrite sepconj_emp; eexact H.
  red; auto.
Qed.