Require Import String Omega List FunctionalExtensionality Ensembles
        Computation ADT ADTRefinement ADTNotation QueryStructureSchema
        BuildADTRefinements QueryStructure
        QuerySpecs.QueryQSSpecs QuerySpecs.InsertQSSpecs EnsembleListEquivalence
        ConstraintChecksRefinements.

(* Facts about implements insert operations. *)

Section InsertRefinements.

  Hint Resolve AC_eq_nth_In AC_eq_nth_NIn crossConstr.
  Hint Unfold SatisfiesCrossRelationConstraints
       SatisfiesSchemaConstraints.

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

  Program
    Definition Insert_Valid
    (qsSchema : QueryStructureSchema)
    (qs : QueryStructure qsSchema)
    (Ridx : _)
    (tup : @IndexedTuple (QSGetNRelSchemaHeading qsSchema Ridx))
    (schConstr : forall tup',
                   GetRelation qs Ridx tup' ->
                   SatisfiesSchemaConstraints Ridx tup tup')
    (schConstr' : forall tup',
                   GetRelation qs Ridx tup' ->
                   SatisfiesSchemaConstraints Ridx tup' tup)
    (schConstr_self :
       @SatisfiesSchemaConstraints qsSchema Ridx tup tup)
    (qsConstr : forall Ridx',
                  SatisfiesCrossRelationConstraints Ridx Ridx' tup (GetRelation qs Ridx'))
    (qsConstr' : forall Ridx',
                   Ridx' <> Ridx ->
                   forall tup',
                     GetRelation qs Ridx' tup'
                     -> SatisfiesCrossRelationConstraints
                     Ridx' Ridx tup'
                     (EnsembleInsert tup (GetRelation qs Ridx)))
  : QueryStructure qsSchema :=
    {| rels :=
         UpdateRelation _ (rels qs) Ridx {| rel := EnsembleInsert tup (GetRelation qs Ridx)|}
    |}.
  Next Obligation.
    unfold GetRelation.
    unfold SatisfiesSchemaConstraints, QSGetNRelSchema, GetNRelSchema,
    GetRelation in *.
    set ((ith_Bounded _ (rels qs) Ridx )) as X in *; destruct X; simpl in *.
    destruct (schemaConstraints
                (relSchema (nth_Bounded relName (qschemaSchemas qsSchema) Ridx))); eauto.
    unfold EnsembleInsert in *; simpl in *; intuition; subst; eauto.
  Defined.
  Next Obligation.
    caseEq (BuildQueryStructureConstraints qsSchema idx idx'); eauto.
    unfold SatisfiesCrossRelationConstraints, UpdateRelation in *;
    destruct (BoundedString_eq_dec Ridx idx'); subst.

    - rewrite ith_replace_BoundIndex_eq; simpl.
      rewrite ith_replace_BoundIndex_neq in H1; eauto using string_dec.
      generalize (qsConstr' idx H0 _ H1); rewrite H; eauto.
    - rewrite ith_replace_BoundIndex_neq in *; eauto using string_dec.
      destruct (BoundedString_eq_dec Ridx idx); subst.
      + rewrite ith_replace_BoundIndex_eq in H1; simpl in *; eauto.
        unfold EnsembleInsert in H1; destruct H1; subst; eauto.
        * generalize (qsConstr idx'); rewrite H; eauto.
        * pose proof (crossConstr qs idx idx') as X; rewrite H in X; eauto.
      + rewrite ith_replace_BoundIndex_neq in H1; eauto using string_dec.
        pose proof (crossConstr qs idx idx') as X; rewrite H in X; eauto.
  Qed.

  Lemma QSInsertSpec_refine' :
    forall qsSchema (qs : QueryStructure qsSchema) Ridx tup default,
      refine
           (Pick (QSInsertSpec {| qsHint := qs |} Ridx tup))
           (schConstr_self <-
                           {b |
                            decides b
                         (SatisfiesSchemaConstraints Ridx tup tup)};
             schConstr <-
                      {b |
                       decides
                         b
                         (forall tup',
                            GetRelation qs Ridx tup'
                            -> SatisfiesSchemaConstraints Ridx tup tup')};
            schConstr' <-
                      {b |
                       decides
                         b
                         (forall tup',
                            GetRelation qs Ridx tup'
                            -> SatisfiesSchemaConstraints Ridx tup' tup)};
            qsConstr <- {b | decides b
              (forall Ridx', SatisfiesCrossRelationConstraints Ridx Ridx' tup (GetRelation qs Ridx'))};
            qsConstr' <- {b | decides
                                b
                                (forall Ridx',
                                   Ridx' <> Ridx ->
                                   forall tup',
                                     (GetRelation qs Ridx') tup'
                                     -> SatisfiesCrossRelationConstraints
                                       Ridx' Ridx tup'
                                       (EnsembleInsert tup (GetRelation qs Ridx)))};
            match schConstr_self, schConstr, schConstr', qsConstr, qsConstr' with
              | true, true, true, true, true =>
                {qs' |
                 (forall Ridx',
                    Ridx <> Ridx' ->
                    GetRelation qsHint Ridx' =
                    GetRelation qs' Ridx')
                 /\ forall t,
                      GetRelation qs' Ridx t <->
                      (EnsembleInsert tup (GetRelation qsHint Ridx) t)
             }

              | _, _ , _, _, _ => default
            end).
  Proof.
    intros qsSchema qs Ridx tup default v Comp_v.
    do 5 (apply_in_hyp computes_to_inv; destruct_ex; split_and);
      destruct x;
      [ destruct x0;
        [ destruct x1;
          [ destruct x2;
            [ destruct x3;
              [ repeat (apply_in_hyp computes_to_inv; destruct_ex; split_and); simpl in *;
                econstructor; unfold QSInsertSpec; eauto |
              ]
            | ]
          | ]
        |  ]
      |  ];
      cbv delta [decides] beta in *; simpl in *;
      repeat (apply_in_hyp computes_to_inv; destruct_ex); eauto;
      econstructor; unfold QSInsertSpec; intros;
      solve [elimtype False; intuition].
  Qed.

  Lemma QSInsertSpec_refine :
    forall qsSchema (qs : QueryStructure qsSchema) Ridx tup default,
      refine
           (Pick (QSInsertSpec {| qsHint := qs |} Ridx tup))
           (schConstr_self <- {b | decides b
                                           (SatisfiesSchemaConstraints Ridx tup tup)};
             schConstr <-
                      {b |
                       decides
                         b
                         (forall tup',
                            GetRelation qs Ridx tup'
                            -> SatisfiesSchemaConstraints Ridx tup tup')};
            schConstr' <-
                      {b |
                       decides
                         b
                         (forall tup',
                            GetRelation qs Ridx tup'
                            -> SatisfiesSchemaConstraints Ridx tup' tup)};
            qsConstr <- (@Iterate_Decide_Comp _
                                (fun Ridx' =>
                                   SatisfiesCrossRelationConstraints
                                     Ridx Ridx' tup
                                     (GetRelation qsHint Ridx')));
            qsConstr' <- (@Iterate_Decide_Comp _
                                (fun Ridx' =>
                                   Ridx' <> Ridx
                                   -> forall tup',
                                        (GetRelation qsHint Ridx') tup'
                                        -> SatisfiesCrossRelationConstraints
                                       Ridx' Ridx tup'
                                       (EnsembleInsert tup (GetRelation qs Ridx))));
            match schConstr_self, schConstr, schConstr', qsConstr, qsConstr' with
              | true, true, true, true, true =>
                {qs' |
                 (forall Ridx',
                    Ridx <> Ridx' ->
                    GetRelation qsHint Ridx' =
                    GetRelation qs' Ridx')
                 /\ forall t,
                      GetRelation qs' Ridx t <->
                      (EnsembleInsert tup (GetRelation qsHint Ridx) t)
             }

              | _, _, _, _, _ => default
            end).
  Proof.
    intros.
    rewrite QSInsertSpec_refine'; f_equiv.
    unfold pointwise_relation; intros.
    setoid_rewrite Iterate_Decide_Comp_BoundedIndex; f_equiv.
  Qed.

  Lemma QSInsertSpec_UnConstr_refine' :
    forall qsSchema (qs : UnConstrQueryStructure qsSchema)
           (Ridx : @BoundedString (map relName (qschemaSchemas qsSchema)))
           (tup : @IndexedTuple (schemaHeading (QSGetNRelSchema qsSchema Ridx)))
           (or : QueryStructure qsSchema)
           (NIntup : ~ GetUnConstrRelation qs Ridx tup),
      DropQSConstraints_AbsR or qs ->
      refine
        (or' <- (qs' <- Pick (QSInsertSpec {| qsHint := or |} Ridx tup);
                 b <- Pick (SuccessfulInsertSpec {| qsHint := or |} Ridx qs' tup);
                 ret (qs', b));
         nr' <- {nr' | DropQSConstraints_AbsR (fst or') nr'};
         ret (nr', snd or'))
        (schConstr_self <- {b | decides b (SatisfiesSchemaConstraints Ridx tup tup)};
         schConstr <-
                   {b | decides b
                      (forall tup',
                         GetUnConstrRelation qs Ridx tup'
                         -> SatisfiesSchemaConstraints Ridx tup tup')};
         schConstr' <-
                    {b |
                     decides
                       b
                       (forall tup',
                          GetUnConstrRelation qs Ridx tup'
                          -> SatisfiesSchemaConstraints Ridx tup' tup)};
         qsConstr <- (@Iterate_Decide_Comp _
                                           (fun Ridx' =>
                                              SatisfiesCrossRelationConstraints
                                     Ridx Ridx' tup
                                     (GetUnConstrRelation qs Ridx')));
            qsConstr' <- (@Iterate_Decide_Comp _
                                (fun Ridx' =>
                                   Ridx' <> Ridx
                                   -> forall tup',
                                        (GetUnConstrRelation qs Ridx') tup'
                                        -> SatisfiesCrossRelationConstraints
                                       Ridx' Ridx tup'
                                       (EnsembleInsert tup (GetUnConstrRelation qs Ridx))));
            ret match schConstr_self, schConstr, schConstr', qsConstr, qsConstr' with
              | true, true, true, true, true =>
                (UpdateUnConstrRelation qs Ridx (EnsembleInsert tup (GetUnConstrRelation qs Ridx)), true)
              | _, _, _, _, _ => (qs, false)
            end).
  Proof.
    intros.
    setoid_rewrite refineEquiv_pick_eq'.
    unfold DropQSConstraints_AbsR in *; intros; subst.
    rewrite QSInsertSpec_refine with (default := ret or).
    unfold refine; intros; subst.
      do 5 (apply_in_hyp computes_to_inv; destruct_ex; split_and).
      repeat rewrite GetRelDropConstraints in *.
      (* These assert are gross. Need to eliminate them. *)
      assert ((fun Ridx' : BoundedIndex (map relName (qschemaSchemas qsSchema)) =>
          SatisfiesCrossRelationConstraints Ridx Ridx' tup
            (GetUnConstrRelation (DropQSConstraints or) Ridx')) =
              (fun Ridx' : BoundedIndex (map relName (qschemaSchemas qsSchema)) =>
                 SatisfiesCrossRelationConstraints Ridx Ridx' tup
                                                   (GetRelation or Ridx'))) as rewriteSat
        by (apply functional_extensionality; intros; rewrite GetRelDropConstraints;
            reflexivity); rewrite rewriteSat in H3; clear rewriteSat.
      assert ((fun Ridx' : BoundedIndex (map relName (qschemaSchemas qsSchema)) =>
          Ridx' <> Ridx ->
          forall
            tup' : @IndexedTuple
                     (schemaHeading
                        (relSchema
                           (nth_Bounded relName (qschemaSchemas qsSchema)
                              Ridx'))),
          GetUnConstrRelation (DropQSConstraints or) Ridx' tup' ->
          SatisfiesCrossRelationConstraints Ridx' Ridx tup'
            (EnsembleInsert tup (GetRelation or Ridx))) =
              (fun Ridx' : BoundedIndex (map relName (qschemaSchemas qsSchema)) =>
      Ridx' <> Ridx ->
      forall
        tup' : @IndexedTuple
                 (schemaHeading
                    (relSchema
                       (nth_Bounded relName (qschemaSchemas qsSchema) Ridx'))),
      GetRelation or Ridx' tup' ->
      SatisfiesCrossRelationConstraints Ridx' Ridx tup'
                                        (EnsembleInsert tup (GetRelation or Ridx))))
          as rewriteSat
            by (apply functional_extensionality; intros; rewrite GetRelDropConstraints;
                reflexivity); rewrite rewriteSat in H4; clear rewriteSat.
      (* Resume not-terribleness *)
      generalize (Iterate_Decide_Comp_BoundedIndex _ _ _ H3) as H3';
      generalize (Iterate_Decide_Comp_BoundedIndex _ _ _ H4) as H4'; intros.
      revert H3 H4.
      repeat apply_in_hyp computes_to_inv.
      econstructor 2 with
      (comp_a_value := match x as x', x0 as x0', x1 as x1', x2 as x2', x3 as x3'
                              return decides x' _ ->
                                     decides x0' _ ->
                                     decides x1' _ ->
                                     decides x2' _ ->
                                     decides x3' _ -> _
                        with
                          | true, true, true, true, true =>
                            fun H H0 H1 H2 H3 => (@Insert_Valid _ or Ridx tup H0 H1 H H2 H3, true)
                          | _, _, _, _, _ => fun _ _ _ _ _ => (or, false)
                        end H0 H1 H2 H3' H4').
      econstructor 2 with (comp_a_value :=  match x as x', x0 as x0', x1 as x1', x2 as x2', x3 as x3'
                              return decides x' _ ->
                                     decides x0' _ ->
                                     decides x1' _ ->
                                     decides x2' _ ->
                                     decides x3' _ -> _
                        with
                          | true, true, true, true, true =>
                            fun H H0 H1 H2 H3 => @Insert_Valid _ or Ridx tup H0 H1 H H2 H3
                          | _, _, _, _, _ => fun _ _ _ _ _ => or
                        end H0 H1 H2 H3' H4').
      repeat (econstructor; eauto).
      repeat find_if_inside; try econstructor; simpl in *.
      unfold GetRelation, Insert_Valid, UpdateUnConstrRelation,
      UpdateRelation, EnsembleInsert ; simpl; split; intros; eauto.
      rewrite ith_replace_BoundIndex_neq; eauto using string_dec; simpl.
      rewrite ith_replace_BoundIndex_eq; unfold EnsembleInsert, GetRelation;
      simpl; intuition.
      econstructor.
      econstructor 3 with (v :=  match x as x', x0 as x0', x1 as x1', x2 as x2', x3 as x3'
                              return decides x' _ ->
                                     decides x0' _ ->
                                     decides x1' _ ->
                                     decides x2' _ ->
                                     decides x3' _ -> _
                        with
                          | true, true, true, true, true =>
                            fun H H0 H1 H2 H3 => true
                          | _, _, _, _, _ => fun _ _ _ _ _ => false
                        end H0 H1 H2 H3' H4').
      repeat find_if_inside; simpl;
      try (solve [unfold not; let H := fresh in intros H; eapply NIntup; eapply H;
      unfold EnsembleInsert; eauto]).
      intros; rewrite <- GetRelDropConstraints.
      unfold Insert_Valid, GetUnConstrRelation, DropQSConstraints,
      UpdateRelation; simpl.
      rewrite <- ith_Bounded_imap, ith_replace_BoundIndex_eq; simpl;
      tauto.

      repeat find_if_inside; subst; repeat econstructor.

      simpl.
      repeat find_if_inside; subst; repeat econstructor.
      unfold DropQSConstraints, Insert_Valid, EnsembleInsert; simpl.
      unfold GetRelation, Insert_Valid, UpdateUnConstrRelation,
      UpdateRelation; rewrite imap_replace_BoundedIndex; simpl; eauto using string_dec.
  Qed.

  Lemma freshIdx2UnConstr {qsSchema} qs Ridx
  : refine {bound | forall tup : IndexedTuple,
                      @GetUnConstrRelation qsSchema qs Ridx tup ->
                      tupleIndex tup <> bound}
           {bound | UnConstrFreshIdx (GetUnConstrRelation qs Ridx) bound}.
  Proof.
    unfold UnConstrFreshIdx; intros v Comp_v; econstructor.
    inversion_by computes_to_inv; intros.
    apply Comp_v in H; omega.
  Qed.

  Lemma QSInsertSpec_UnConstr_refine :
    forall qsSchema (qs : UnConstrQueryStructure qsSchema )
           (Ridx : @BoundedString (map relName (qschemaSchemas qsSchema)))
           (tup : @Tuple (schemaHeading (QSGetNRelSchema qsSchema Ridx)))
           (or : QueryStructure qsSchema)
           refined_schConstr_self refined_schConstr refined_schConstr'
           refined_qsConstr refined_qsConstr',
      refine {b | decides b (SatisfiesSchemaConstraints Ridx tup tup)}
             refined_schConstr_self
      -> refine {b | decides b
                             (forall tup',
                                GetUnConstrRelation qs Ridx tup'
                                -> SatisfiesSchemaConstraints Ridx tup tup')}
                refined_schConstr
      -> refine
           {b |
            decides
              b
              (forall tup',
                 GetUnConstrRelation qs Ridx tup'
                 -> SatisfiesSchemaConstraints Ridx tup' tup)}
           refined_schConstr'
      -> refine
           (@Iterate_Decide_Comp _
                                 (fun Ridx' =>
                                    SatisfiesCrossRelationConstraints
                                      Ridx Ridx' tup
                                      (GetUnConstrRelation qs Ridx')))
           refined_qsConstr
      -> (forall idx,
            refine
              (@Iterate_Decide_Comp _
                                    (fun Ridx' =>
                                       Ridx' <> Ridx
                                       -> forall tup',
                                            (GetUnConstrRelation qs Ridx') tup'
                                            -> SatisfiesCrossRelationConstraints
                                                 Ridx' Ridx tup'
                                                 (EnsembleInsert
                                                    {| tupleIndex := idx;
                                                       indexedTuple := tup |}
                                                    (GetUnConstrRelation qs Ridx))))
              (refined_qsConstr' idx))
      -> DropQSConstraints_AbsR or qs ->
      refine
        (or' <- (idx <- Pick (freshIdx {| qsHint := or |} Ridx);
                 qs' <- Pick (QSInsertSpec {| qsHint := or |} Ridx
                                          {| tupleIndex := idx;
                                             indexedTuple := tup |});
                 b <- Pick (SuccessfulInsertSpec {| qsHint := or |} Ridx qs'
                                                 {| tupleIndex := idx;
                                                    indexedTuple := tup |});
                 ret (qs', b));
         nr' <- {nr' | DropQSConstraints_AbsR (fst or') nr'};
         ret (nr', snd or'))
        (idx <- {idx | UnConstrFreshIdx (GetUnConstrRelation qs Ridx) idx};
         (schConstr_self <- refined_schConstr_self;
          schConstr <- refined_schConstr;
          schConstr' <- refined_schConstr';
          qsConstr <- refined_qsConstr ;
          qsConstr' <- (refined_qsConstr' idx);
          ret match schConstr_self, schConstr, schConstr', qsConstr, qsConstr' with
                | true, true, true, true, true =>
                  (UpdateUnConstrRelation qs Ridx
                                          (EnsembleInsert
                                             {| tupleIndex := idx;
                                                indexedTuple := tup |}
                                                   (GetUnConstrRelation qs Ridx)), true)
                | _, _, _, _, _ => (qs, false)
              end)).
  Proof.
    intros.
    simplify with monad laws.
    unfold freshIdx.
    simpl.
    rewrite <- GetRelDropConstraints.
    unfold DropQSConstraints_AbsR in *; subst.
    rewrite freshIdx2UnConstr.
    apply refine_bind_pick; intros.
    setoid_rewrite <- H; setoid_rewrite <- H0; setoid_rewrite <- H1;
    setoid_rewrite <- H2; setoid_rewrite <- (H3 a).
    setoid_rewrite <- (QSInsertSpec_UnConstr_refine' _ {| tupleIndex := a; indexedTuple := tup |}).
    repeat setoid_rewrite refineEquiv_bind_bind.
    setoid_rewrite refineEquiv_bind_unit; simpl.
    unfold DropQSConstraints_AbsR in *; subst.
    f_equiv; intros.
    unfold UnConstrFreshIdx, not in *; intros.
    apply H4 in H5; simpl in *; omega.
    reflexivity.
  Qed.

  Lemma refine_SatisfiesCrossConstraints'
  : forall qsSchema qs
           (Ridx : @BoundedString (map relName (qschemaSchemas qsSchema)))
           (tup : @Tuple (schemaHeading (QSGetNRelSchema qsSchema Ridx))),
    forall idx,
      refine
        (@Iterate_Decide_Comp _
                              (fun Ridx' =>
                Ridx' <> Ridx
                -> forall tup',
                     (GetUnConstrRelation qs Ridx') tup'
                     -> SatisfiesCrossRelationConstraints
                          Ridx' Ridx tup'
                          (EnsembleInsert
                             {| tupleIndex := idx;
                                indexedTuple := tup |}
                             (GetUnConstrRelation qs Ridx))))
             (@Iterate_Decide_Comp_opt' _ _ []
                                        (fun Ridx' =>
                                           if (BoundedString_eq_dec Ridx Ridx') then
                                             None
                                           else
                                             match (BuildQueryStructureConstraints qsSchema Ridx' Ridx) with
                                               | Some CrossConstr =>
                                                 Some (
                                                     forall tup',
                                                       (GetUnConstrRelation qs Ridx') tup'
                                                       -> CrossConstr (indexedTuple tup') (
                                                                        (EnsembleInsert
                                                                           {| tupleIndex := idx;
                                                                              indexedTuple := tup |}
                                                                           (GetUnConstrRelation qs Ridx))))
                                               | None => None
                                      end)).
  Proof.
    intros.
    setoid_rewrite <- refine_Iterate_Decide_Comp.
    unfold SatisfiesCrossRelationConstraints.
    apply refine_Iterate_Decide_Comp_equiv; simpl; intros.
    apply string_dec.
    destruct (BoundedString_eq_dec Ridx idx0); subst.
    congruence.
    destruct (BuildQueryStructureConstraints qsSchema idx0 Ridx); eauto.
    intro; eapply H.
    destruct (BoundedString_eq_dec Ridx idx0); subst; eauto.
    destruct (BuildQueryStructureConstraints qsSchema idx0 Ridx); eauto.
  Qed.

  Local Transparent QSInsert.

  Lemma QSInsertSpec_UnConstr_refine_opt :
    forall qsSchema (qs : UnConstrQueryStructure qsSchema )
           (Ridx : @BoundedString (map relName (qschemaSchemas qsSchema)))
           (tup : @Tuple (schemaHeading (QSGetNRelSchema qsSchema Ridx)))
           (or : QueryStructure qsSchema),
      DropQSConstraints_AbsR or qs ->
      refine
        (or' <- (idx <- Pick (freshIdx {| qsHint := or |} Ridx);
                 qs' <- Pick (QSInsertSpec {| qsHint := or |} Ridx
                                          {| tupleIndex := idx;
                                             indexedTuple := tup |});
                 b <- Pick (SuccessfulInsertSpec {| qsHint := or |} Ridx qs'
                                                 {| tupleIndex := idx;
                                                    indexedTuple := tup |});
                 ret (qs', b));
         nr' <- {nr' | DropQSConstraints_AbsR (fst or') nr'};
         ret (nr', snd or'))
        match (schemaConstraints (QSGetNRelSchema qsSchema Ridx)) with
            Some Constr =>
            idx <- {idx | UnConstrFreshIdx (GetUnConstrRelation qs Ridx) idx} ;
            (schConstr_self <- {b | decides b (Constr tup tup) };
                   schConstr <- {b | decides b
                                             (forall tup',
                                                GetUnConstrRelation qs Ridx tup'
                                                -> Constr tup tup')};
                   schConstr' <- {b | decides b
                                              (forall tup',
                                                   GetUnConstrRelation qs Ridx tup'
                                                   -> Constr tup' tup)};
                   qsConstr <- (@Iterate_Decide_Comp_opt' _ _ []
                                   (fun Ridx' =>
                                      match (BuildQueryStructureConstraints qsSchema Ridx Ridx') with
                                        | Some CrossConstr =>
                                          Some (CrossConstr tup (GetUnConstrRelation qs Ridx'))
                                        | None => None
                                      end));
                   qsConstr' <- (@Iterate_Decide_Comp_opt' _ _ []
                                        (fun Ridx' =>
                                           if (BoundedString_eq_dec Ridx Ridx') then
                                             None
                                           else
                                             match (BuildQueryStructureConstraints qsSchema Ridx' Ridx) with
                                               | Some CrossConstr =>
                                                 Some (
                                                     forall tup',
                                                       (GetUnConstrRelation qs Ridx') tup'
                                                       -> CrossConstr (indexedTuple tup') (
                                                                        (EnsembleInsert
                                                                           {| tupleIndex := idx;
                                                                              indexedTuple := tup |}
                                                                           (GetUnConstrRelation qs Ridx))))
                                               | None => None
                                      end));
                   ret match schConstr_self, schConstr, schConstr', qsConstr, qsConstr' with
                         | true, true, true, true, true =>
                           (UpdateUnConstrRelation qs Ridx
                                                   (EnsembleInsert
                                                      {| tupleIndex := idx;
                                                         indexedTuple := tup |}
                                                      (GetUnConstrRelation qs Ridx)), true)
                         | _, _, _, _, _ => (qs, false)
                       end)
          | None =>
            idx <- {idx | UnConstrFreshIdx (GetUnConstrRelation qs Ridx) idx};
            (qsConstr <- (@Iterate_Decide_Comp_opt' _ _ []
                                   (fun Ridx' =>
                                      match (BuildQueryStructureConstraints qsSchema Ridx Ridx') with
                                        | Some CrossConstr =>
                                          Some (CrossConstr tup (GetUnConstrRelation qs Ridx'))
                                        | None => None
                                      end));
                   qsConstr' <- (@Iterate_Decide_Comp_opt' _ _ []
                                        (fun Ridx' =>
                                           if (BoundedString_eq_dec Ridx Ridx') then
                                             None
                                           else
                                             match (BuildQueryStructureConstraints qsSchema Ridx' Ridx) with
                                               | Some CrossConstr =>
                                                 Some (
                                                     forall tup',
                                                       (GetUnConstrRelation qs Ridx') tup'
                                                       -> CrossConstr (indexedTuple tup') (
                                                                        (EnsembleInsert
                                                                           {| tupleIndex := idx;
                                                                              indexedTuple := tup |}
                                                                           (GetUnConstrRelation qs Ridx))))
                                               | None => None
                                      end));
                   ret match qsConstr, qsConstr' with
                         | true, true =>
                           (UpdateUnConstrRelation qs Ridx
                                                     (EnsembleInsert
                                                        {| tupleIndex := idx;
                                                           indexedTuple := tup |}
                                                        (GetUnConstrRelation qs Ridx)), true)
                           | _, _ => (qs, false)
                         end)
        end.
    unfold QSInsert.
    intros; rewrite QSInsertSpec_UnConstr_refine;
    eauto using
          refine_SatisfiesSchemaConstraints_self,
    refine_SatisfiesSchemaConstraints,
    refine_SatisfiesSchemaConstraints',
    refine_SatisfiesCrossConstraints;
    [
    | intros; eapply refine_SatisfiesCrossConstraints'].
    destruct (schemaConstraints (QSGetNRelSchema qsSchema Ridx)).
    reflexivity.
    f_equiv; unfold pointwise_relation; intros.
    repeat setoid_rewrite refineEquiv_bind_bind.
    repeat setoid_rewrite refineEquiv_bind_unit; f_equiv.
  Qed.

End InsertRefinements.

  (* When we insert a tuple into a relation which has another relation has
     a foreign key into, we need to show that we haven't messed up any
     references (which is, of course, trivial. We should bake this into
     our the [QSInsertSpec_refine'] refinement itself by filtering out the
     irrelevant constraints somehow, but for now we can use the following
     tactic to rewrite them away. *)

  Ltac remove_trivial_insertion_constraints :=
          repeat     match goal with
          |- context[EnsembleInsert _ (GetUnConstrRelation _ _) ] =>
          match goal with
              AbsR : @DropQSConstraints_AbsR ?schm ?or ?nr
              |- context [
                     Pick
                       (fun b =>
                          decides
                            b
                            (forall tup' : @IndexedTuple ?heading,
                               (@GetUnConstrRelation ?schm ?r ?Ridx) tup' ->
                               ForeignKey_P ?attr ?attr' ?tup_map
                                            (indexedTuple tup')
                                            (EnsembleInsert ?tup (GetUnConstrRelation ?r ?Ridx'))))] =>
              let neq := fresh in
              assert (Ridx <> Ridx') by (subst_strings; discriminate);
              let refine_trivial := fresh in
              assert (refine {b' |
                         decides b'
                                 (forall tup' : IndexedTuple,
                                    (GetUnConstrRelation r Ridx) tup' ->
                                    @ForeignKey_P heading
                                                  (schemaHeading (GetNRelSchema (qschemaSchemas schm) Ridx'))
                                                  attr attr' tup_map
                                                  (indexedTuple tup')
                                                  (EnsembleInsert tup (GetUnConstrRelation r Ridx')))}
                      (ret true)) as refine_trivial;
                [ unfold ForeignKey_P;
                  let v := fresh in
                  let Comp_v := fresh in
                  intros v Comp_v;
                    apply computes_to_inv in Comp_v;
                    rewrite <- AbsR; subst;
                    repeat rewrite GetRelDropConstraints;
                    let tup' := fresh in
                    let In_tup' := fresh in
                    econstructor; simpl map; simpl; intros tup' In_tup';
                    unfold EnsembleInsert;
                    let H' := fresh in
                    pose proof (@crossConstr _ or Ridx Ridx' tup' neq In_tup') as H';
                      simpl map in *; simpl in *;
                      destruct H' as [? [? ?]]; eauto
                | subst_strings; setoid_rewrite refine_trivial;
                  clear refine_trivial;
                  pose_string_ids; simplify with monad laws
                ] end end.

Tactic Notation "remove" "trivial" "insertion" "checks" :=
  (* Move all the binds we can outside the exists / computes
   used for abstraction, stopping when we've rewritten
         the bind in [QSInsertSpec]. *)
  repeat rewrite refineEquiv_bind_bind;
  etransitivity;
  [ repeat (apply refine_bind;
            [reflexivity
            | match goal with
                | |- context [Bind (Insert _ into _)%QuerySpec _] =>
                  unfold pointwise_relation; intros
                    end
                 ] );
    (* Pull out the relation we're inserting into and then
     rewrite [QSInsertSpec] *)
    match goal with
        H : DropQSConstraints_AbsR _ ?r_n
        |- context [(Insert ?n into ?R)%QuerySpec] =>
        let H' := fresh in
          (* If we try to eapply [QSInsertSpec_UnConstr_refine] directly
                   after we've drilled under a bind, this tactic will fail because
                   typeclass resolution breaks down. Generalizing and applying gets
                   around this problem for reasons unknown. *)
        let H' := fresh in
        pose proof (@QSInsertSpec_UnConstr_refine_opt
                      _ r_n {| bindex := R |} n _ H) as H';
          apply H'
    end
  | cbv beta; simpl schemaConstraints; cbv iota;
    simpl map; simpl app;
    simpl relName in *; simpl schemaHeading in *;
    pose_string_ids; simpl;
    simplify with monad laws;
    try rewrite <- GetRelDropConstraints;
    repeat match goal with
             | H : DropQSConstraints_AbsR ?qs ?uqs |- _ =>
               rewrite H in *
           end
  ].

Tactic Notation "Split" "Constraint" "Checks" :=
  repeat (let b := match goal with
                     | [ |- context[if ?X then _ else _] ] => constr:(X)
                     | [ H : context[if ?X then _ else _] |- _ ]=> constr:(X)
                   end in
          let b_eq := fresh in
          eapply (@refine_if _ _ b); intros b_eq;
          simpl in *; repeat rewrite b_eq; simpl).

Tactic Notation "implement" "failed" "insert" :=
  repeat (rewrite refine_pick_val, refineEquiv_bind_unit; eauto);
  reflexivity.

Tactic Notation "drop" "constraints" "from" "insert" constr(methname) :=
  hone method methname;
  [ remove trivial insertion checks;
    (* The trivial insertion checks involve the fresh id,
       so we need to drill under the binder before
       attempting to remove them. *)
    rewrite refine_bind;
    [ | reflexivity |
      unfold pointwise_relation; intros;
      repeat remove_trivial_insertion_constraints;
      higher_order_1_reflexivity ];
    finish honing
  | ].


Require Import Coq.Classes.DecidableClass.
Require Import Coq.Lists.List.
Require Import Coq.Bool.Bool.
Require Import SquiggleEq.export.
Require Import SquiggleEq.UsefulTypes.
Require Import SquiggleEq.list.
Require Import SquiggleEq.LibTactics.
Require Import SquiggleEq.tactics.
Require Import SquiggleEq.AssociationList.

(* creating a Prop without using inductives *)
Definition constTrue (T:Type) : Prop := (forall P:Prop, P->P).

Definition constFalse (T:Type) : Prop := (forall P:Prop, P->P).

Definition nonConst (T:Type) : Prop := (exists (t:T), True).

(*
Declare ML Module "paramcoq".
Parametricity Recursive constTrue.
Print constTrue_R.
*)

Definition constTrue_R : forall T₁ T₂ : Type, (T₁ -> T₂ -> Type) -> constTrue T₁ -> constTrue T₂ -> Prop
:=
fun (T₁ T₂ : Type) (_ : T₁ -> T₂ -> Type) (H H0 : forall P : Prop, P -> P) =>
forall (P₁ P₂ : Prop) (P_R : P₁ -> P₂ -> Prop) (H1 : P₁) (H2 : P₂),
P_R H1 H2 -> P_R (H P₁ H1) (H0 P₂ H2).

(* this is hardly a generic proof *)
Lemma constTrue_RP : forall T₁ T₂ : Type, (T₁ -> T₂ -> Type) -> constTrue T₁ <-> constTrue T₂.
Proof using.
  intros ? ? _. unfold constTrue. reflexivity.
Qed.

Print and.

SearchAbout (nat->Prop).
Print Between.between.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
(* Require Import BuiltIn.
Require BuiltIn.
Require HighOrd.
Require set.Set.
Require map.Map.
Require map.Const. *)

Require Import Reals.

(* Axiom rreal : Type. *)
Definition rreal := R.

(* Parameter rreal_WhyType : WhyType rreal. *)
(* Existing Instance rreal_WhyType. *)

Parameter setrreal: rreal -> bool.

Definition rzero:= 0%R.
Definition rone:= 1%R.
Definition rtwo:= 2%R.

Lemma oneIsNotZero : ~ (rone = rzero).
Proof. exact R1_neq_R0. Qed.

Lemma twoIsNotOne : ~ (rtwo = rone).
Proof. apply (not_1_INR 2). auto. Qed.

Lemma twoIsNotZero : ~ (rtwo = rzero).
Proof. apply (not_0_INR 2). auto. Qed.

(* Why3 assumption *)
Definition rel (a:Type) (b:Type) := (a* b)%type -> bool.

Parameter power:
  forall {a:Type} {a_WT:WhyType a}, (a -> bool) -> (a -> bool) -> bool.

Axiom mem_power :
  forall {a:Type} {a_WT:WhyType a},
  forall (x:a -> bool) (y:a -> bool),
  (set.Set.mem x (power y)) <-> (set.Set.subset x y).

(* Parameter leq: (rreal* rreal)%type -> bool. *)
Definition leq (z:rreal*rreal) : Prop:=
  match z with
    | (x,y) => (x<=y)%R
  end.
Definition lt (z:rreal*rreal) : Prop:=
  match z with
    | (x,y) => (x<y)%R
  end.
Definition geq (z:rreal*rreal) : Prop:=
  match z with
    | (x,y) => (x>y)%R
  end.
Definition gt (z:rreal*rreal) : Prop:=
  match z with
    | (x,y) => (x>=y)%R
  end.

Lemma zeroLtOne : set.Set.mem (rzero, rone) lt.
Proof. exact Rlt_0_1. Qed.

Lemma oneLtTwo : set.Set.mem (rone, rtwo) lt.
Proof. apply (lt_1_INR 2). apply (le_n 2). Qed.

Parameter rrealStar: rreal -> bool.
Parameter rrealPlus: rreal -> bool.
Parameter rrealMinus: rreal -> bool.
Parameter rrealPlusStar: rreal -> bool.
Parameter rrealMinusStar: rreal -> bool.

(* Why3 assumption *)
Definition notRzero : Prop := forall (x:rreal), ~ (x = rzero).

(* Why3 assumption *)
Definition isPos : Prop := forall (x:rreal), set.Set.mem (rzero, x) leq.

(* Why3 assumption *)
Definition isNeg : Prop := forall (x:rreal), set.Set.mem (x, rzero) leq.

(* Why3 assumption *)
Definition isStrictPos : Prop := forall (x:rreal), set.Set.mem (rzero, x) lt.

(* Why3 assumption *)
Definition isStrictNeg : Prop := forall (x:rreal), set.Set.mem (x, rzero) lt.

Parameter infix_plmngt:
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b}, (a -> bool) ->
  (b -> bool) -> ((a* b)%type -> bool) -> bool.

Axiom mem_function :
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (f:(a* b)%type -> bool) (s:a -> bool) (t:b -> bool),
  (set.Set.mem f (infix_plmngt s t)) <->
  ((forall (x:a) (y:b), (set.Set.mem (x, y) f) ->
    (set.Set.mem x s) /\ (set.Set.mem y t)) /\
   forall (x:a) (y1:b) (y2:b),
   ((set.Set.mem (x, y1) f) /\ (set.Set.mem (x, y2) f)) -> (y1 = y2)).

Axiom domain_function :
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (f:(a* b)%type -> bool) (s:a -> bool) (t:b -> bool) (x:a) (y:b),
  (set.Set.mem f (infix_plmngt s t)) -> (set.Set.mem (x, y) f) ->
  set.Set.mem x s.

Axiom range_function :
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (f:(a* b)%type -> bool) (s:a -> bool) (t:b -> bool) (x:a) (y:b),
  (set.Set.mem f (infix_plmngt s t)) -> (set.Set.mem (x, y) f) ->
  set.Set.mem y t.

Axiom function_extend_range :
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (f:(a* b)%type -> bool) (s:a -> bool) (t:b -> bool) (u:b -> bool),
  (set.Set.subset t u) -> (set.Set.mem f (infix_plmngt s t)) ->
  set.Set.mem f (infix_plmngt s u).

Axiom function_reduce_range :
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (f:(a* b)%type -> bool) (s:a -> bool) (t:b -> bool) (u:b -> bool),
  (set.Set.subset u t) -> (set.Set.mem f (infix_plmngt s t)) ->
  (forall (x:a) (y:b), (set.Set.mem (x, y) f) -> set.Set.mem y u) ->
  set.Set.mem f (infix_plmngt s u).

Parameter inverse:
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  ((a* b)%type -> bool) -> (b* a)%type -> bool.

Axiom Inverse_def :
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (r:(a* b)%type -> bool), forall (x:a) (y:b),
  (set.Set.mem (y, x) (inverse r)) <-> (set.Set.mem (x, y) r).

Parameter dom:
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  ((a* b)%type -> bool) -> a -> bool.

Axiom dom_def :
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (r:(a* b)%type -> bool), forall (x:a),
  (set.Set.mem x (dom r)) <-> exists y:b, set.Set.mem (x, y) r.

Parameter ran:
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  ((a* b)%type -> bool) -> b -> bool.

Axiom ran_def :
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (r:(a* b)%type -> bool), forall (y:b),
  (set.Set.mem y (ran r)) <-> exists x:a, set.Set.mem (x, y) r.

Parameter infix_mnmngt:
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b}, (a -> bool) ->
  (b -> bool) -> ((a* b)%type -> bool) -> bool.

Axiom mem_total_functions :
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (f:(a* b)%type -> bool) (s:a -> bool) (t:b -> bool),
  (set.Set.mem f (infix_mnmngt s t)) <->
  ((set.Set.mem f (infix_plmngt s t)) /\ (set.Set.infix_eqeq (dom f) s)).

Axiom total_function_is_function :
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (f:(a* b)%type -> bool) (s:a -> bool) (t:b -> bool),
  (set.Set.mem f (infix_mnmngt s t)) -> set.Set.mem f (infix_plmngt s t).

Parameter apply:
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  ((a* b)%type -> bool) -> a -> b.

Axiom apply_def1 :
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (f:(a* b)%type -> bool) (s:a -> bool) (t:b -> bool) (a1:a),
  ((set.Set.mem a1 s) /\ (set.Set.mem f (infix_mnmngt s t))) ->
  set.Set.mem (a1, apply f a1) f.

Axiom apply_def2 :
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (f:(a* b)%type -> bool) (s:a -> bool) (t:b -> bool) (a1:a) (b1:b),
  ((set.Set.mem f (infix_mnmngt s t)) /\ (set.Set.mem (a1, b1) f)) ->
  (b1 = (apply f a1)).

Axiom injection :
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (f:(a* b)%type -> bool) (s:a -> bool) (t:b -> bool),
  forall (x:a) (y:a), (set.Set.mem f (infix_mnmngt s t)) ->
  (set.Set.mem (inverse f) (infix_plmngt t s)) -> (set.Set.mem x s) ->
  (set.Set.mem y s) -> ((apply f x) = (apply f y)) -> (x = y).

Parameter times:
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b}, (a -> bool) ->
  (b -> bool) -> (a* b)%type -> bool.

Axiom times_def :
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (a1:a -> bool) (b1:b -> bool) (x:a) (y:b),
  (set.Set.mem (x, y) (times a1 b1)) <->
  ((set.Set.mem x a1) /\ (set.Set.mem y b1)).

(* Why3 assumption *)
Definition relations {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b}
    (u:a -> bool) (v:b -> bool) : ((a* b)%type -> bool) -> bool :=
  power (times u v).

Axiom break_mem_in_add :
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (c:(a* b)%type) (s:(a* b)%type -> bool) (x:a) (y:b),
  (set.Set.mem c (map.Map.set s (x, y) true)) <->
  ((c = (x, y)) \/ (set.Set.mem c s)).

Axiom break_power_times :
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (r:(a* b)%type -> bool) (u:a -> bool) (v:b -> bool),
  (set.Set.mem r (power (times u v))) <-> (set.Set.subset r (times u v)).

Axiom subset_of_times :
  forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (r:(a* b)%type -> bool) (u:a -> bool) (v:b -> bool),
  (set.Set.subset r (times u v)) <->
  forall (x:a) (y:b), (set.Set.mem (x, y) r) ->
  (set.Set.mem x u) /\ (set.Set.mem y v).

Definition plus (z:rreal*rreal) : rreal:=
  match z with
    | (x,y) => (x+y)%R
  end.

Definition times1 (z:rreal*rreal) : rreal:=
  match z with
    | (x,y) => (x*y)%R
  end.

Definition uminus (z:rreal) : rreal:= (-z)%R.

Definition inverse1 (z:rreal) : rreal:= (/z)%R.

Definition minus (z:rreal*rreal) : rreal:=
  match z with
    | (x,y) => (x-y)%R
  end.

Definition divide (z:rreal*rreal) : rreal:=
  match z with
    | (x,y) => (x/y)%R
  end.

Definition abs (z:rreal) : rreal:= (Rabs z).

Definition sqrt (z:rreal) : rreal:= (sqrt z).

Lemma minusDef :
  forall (x:rreal) (y:rreal), ((minus (x, y)) = (plus (x, uminus y))).
Proof. intros; exact eq_refl. Qed.

Lemma inverseDef :
  forall (x:rreal), ~ (x = rzero) -> ((times1 (x, inverse1 x)) = rone).
Proof. intros; apply Rinv_r; auto. Qed.

Lemma divideDef :
  forall (x:rreal) (y:rreal), ~ (y = rzero) ->
  ((divide (x, y)) = (times1 (x, inverse1 y))).
Proof. intros; exact eq_refl. Qed.

Lemma absPos : forall (x:rreal), set.Set.mem (rzero, abs x) leq.
Proof. intros; apply Rabs_pos. Admitted.

Lemma absZero : forall (x:rreal), (x = rzero) -> ((abs x) = rzero).
Proof. intros x H. rewrite H; exact Rabs_R0. Qed.

Lemma absDef :
  forall (x:rreal),
  ((set.Set.mem (x, rzero) lt) -> ((abs x) = (uminus x))) /\
  ((set.Set.mem (rzero, x) lt) -> ((abs x) = x)).
Proof.
intros x; split.
+ apply Rabs_left.
+ apply Rabs_right.
Admitted.

Lemma absTriangular :
  forall (x:rreal) (y:rreal),
  set.Set.mem (abs (plus (x, y)), plus (abs x, abs y)) leq.
Proof.
intros x y.
apply Rabs_triang.
Admitted.

Lemma absMinus : forall (x:rreal), ((abs (uminus x)) = (abs x)).
Proof. intros x; apply Rabs_Ropp. Qed.

Lemma absMult :
  forall (x:rreal) (y:rreal),
  ((abs (times1 (x, y))) = (times1 (abs x, abs y))).
Proof. intros x y; apply Rabs_mult. Qed.

Lemma sqrtDef :
  forall (x:rreal), (set.Set.mem x rrealPlus) ->
  ((times1 (sqrt x, sqrt x)) = x).
Proof. Admitted.

Lemma twoDef : (rtwo = (plus (rone, rone))).
Proof. apply eq_refl. Qed.

Lemma rzeroLtrtwo : set.Set.mem (rzero, rtwo) lt.
Proof. Admitted.

Lemma uminusOrderInversion :
  forall (x:rreal), (set.Set.mem (rzero, x) leq) ->
  set.Set.mem (uminus x, rzero) leq.
Proof. Admitted.

Lemma uminusInvolutive :
  forall (x:rreal), (set.Set.mem x setrreal) -> ((uminus (uminus x)) = x).
Proof. Admitted.

Lemma uminusNeutrality : ((uminus rzero) = rzero).
Proof. exact Ropp_0. Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import List.
Require Import Zmisc.
Require Import Arith.
Require Import Bool.

Set Implicit Arguments.

(* Should be added to the List Standard Library ... *)

Section MoreLists.

Variable A:Set.

Section Nth.

Lemma nth_overflow : forall (l:list A) n d, length l <= n -> nth n l d = d.
Proof.
induction l; destruct n; simpl; intros; auto.
inversion H.
apply IHl; auto with arith.
Qed.

Lemma nth_indep :
 forall (l:list A) n d d', n < length l -> nth n l d = nth n l d'.
Proof.
induction l; simpl; intros; auto.
inversion H.
destruct n; simpl; auto with arith.
Qed.

End Nth.

Section App.

Lemma app_length : forall l l':list A, length (l++l') = length l + length l'.
Proof.
induction l; simpl; auto.
Qed.

Lemma app_nth1 :
 forall (l l':list A) d n, n < length l -> nth n (l++l') d = nth n l d.
Proof.
induction l.
intros.
inversion H.
intros l' d n.
case n; simpl; auto.
intros; rewrite IHl; auto with arith.
Qed.

Lemma app_nth2 :
 forall (l l':list A) d n, n >= length l -> nth n (l++l') d = nth (n-length l) l' d.
Proof.
induction l.
intros.
simpl.
rewrite <- minus_n_O; auto.
intros l' d n.
case n; simpl; auto.
intros.
inversion H.
intros.
rewrite IHl; auto with arith.
Qed.

Lemma fold_left_app : forall (B: Set)(f : A -> B -> A)(l l':list B)(a:A),
 fold_left f (l++l') a = fold_left f l' (fold_left f l a).
Proof.
induction l.
simpl; auto.
intros.
simpl.
auto.
Qed.

End App.

Section Rev.

Lemma rev_length : forall l:list A, length (rev l) = length l.
Proof.
induction l;simpl; auto.
rewrite app_length.
rewrite IHl.
simpl; rewrite plus_comm; auto.
Qed.

Lemma rev_nth : forall (l: list A)(d:A)(n:nat),  n < length l ->
 nth n (rev l) d = nth (length l - S n) l d.
Proof.
induction l.
intros; inversion H.
intros.
simpl in H.
simpl (rev (a :: l)).
simpl (length (a :: l) - S n).
inversion H.
rewrite <- minus_n_n; simpl.
rewrite <- rev_length.
rewrite app_nth2; auto.
rewrite <- minus_n_n; auto.
rewrite app_nth1; auto.
rewrite (minus_plus_simpl_l_reverse (length l) n 1).
replace (1 + length l) with (S (length l)); auto with arith.
rewrite <- minus_Sn_m; auto with arith; simpl.
apply IHl; auto.
rewrite rev_length; auto.
Qed.

End Rev.

Section Rev_acc.

(* finally not used here, but might be useful some day *)

Fixpoint rev_acc (l l': list A) {struct l} : list A :=
 match l with
  | nil => l'
  | a::l => rev_acc l (a::l')
 end.

Lemma rev_acc_rev : forall l l', rev_acc l l' = rev l ++ l'.
Proof.
induction l; simpl; auto; intros.
rewrite <- ass_app; firstorder.
Qed.

Lemma rev_rev_acc : forall l, rev l = rev_acc l nil.
Proof.
intros; rewrite rev_acc_rev.
apply app_nil_end.
Qed.

End Rev_acc.

Section Seq.

Fixpoint seq (start len:nat) {struct len} : list nat :=
 match len with
  | 0 => nil
  | S len => start :: seq (S start) len
 end.

Lemma seq_length : forall len start, length (seq start len) = len.
Proof.
induction len; simpl; auto.
Qed.

Lemma seq_nth : forall len start n d,
  n < len -> nth n (seq start len) d = start+n.
Proof.
induction len; intros.
inversion H.
simpl seq.
destruct n; simpl.
auto with arith.
rewrite IHlen;simpl; auto with arith.
Qed.

Lemma seq_shift : forall len start,
 map S (seq start len) = seq (S start) len.
Proof.
induction len; simpl; auto.
intros.
rewrite IHlen.
auto with arith.
Qed.

End Seq.

Section Map.

Variable B: Set.
Variable f : A-> B.

Lemma In_map2 : forall l y, In y (map f l) -> exists x, f x = y /\ In x l.
Proof.
induction l; firstorder.
Qed.

Lemma map_length : forall l, length (map f l) = length l.
Proof.
induction l; simpl; auto.
Qed.

Lemma map_nth : forall l d n,
 nth n (map f l) (f d) = f (nth n l d).
Proof.
induction l; simpl map; destruct n; firstorder.
Qed.

Lemma map_app : forall l l',
 map f (l++l') = (map f l) ++ (map f l').
Proof.
induction l; simpl; auto.
intros; rewrite IHl; auto.
Qed.

Lemma map_rev : forall l, map f (rev l) = rev (map f l).
Proof.
induction l; simpl; auto.
rewrite map_app.
rewrite IHl; auto.
Qed.

Lemma map_map : forall (C:Set)(f:A->B)(g:B->C) l,
  map g (map f l) = map (fun x => g (f x)) l.
Proof.
induction l; simpl; auto.
rewrite IHl; auto.
Qed.

Lemma map_ext :
 forall g, (forall a, f a = g a) -> forall l, map f l = map g l.
Proof.
induction l; simpl; auto.
rewrite H; rewrite IHl; auto.
Qed.

End Map.

Section SplitLast.

Fixpoint last (l:list A)(d:A)  {struct l} : A :=
 match l with
  | nil => d
  | a :: nil => a
  | a :: l => last l d
 end.

Fixpoint removelast (l:list A) {struct l} : list A :=
 match l with
  | nil =>  nil
  | a :: nil => nil
  | a :: l => a :: removelast l
 end.

Lemma app_removelast_last :
 forall l d, l<>nil -> l = removelast l ++ (last l d :: nil).
Proof.
induction l.
destruct 1; auto.
intros d _.
destruct l; auto.
pattern (a0::l) at 1; rewrite IHl with d; auto; discriminate.
Qed.

Lemma exists_last :
 forall l, l<>nil -> { l' : list A & { a : A | l = l'++a::nil}}.
Proof.
induction l.
destruct 1; auto.
intros _.
destruct l.
exists (@nil A); exists a; auto.
destruct IHl as [l' (a',H)]; try discriminate.
rewrite H.
exists (a::l'); exists a'; auto.
Qed.

End SplitLast.

Section ConsN.

(* [consn n a l] adds [n] times the element [a] in head position of [l]. *)

Definition consn n a (l:list A) := nat_rect _ l (fun _ => cons a) n.

Lemma consn_length : forall n a l, length (consn n a l) = n + length l.
Proof.
unfold consn; induction n; simpl; auto.
Qed.

Lemma consn_nth1 :
forall n a l k d,  k < n -> nth k (consn n a l) d = a.
Proof.
unfold consn; induction n.
inversion 1.
destruct k; simpl; auto with arith.
Qed.

Lemma consn_nth2 :
forall n a l k d,  n <= k -> nth k (consn n a l) d = nth (k-n) l d.
Proof.
unfold consn; induction n.
intros; rewrite <- minus_n_O; auto.
destruct k; [ inversion 1 | simpl; auto with arith ].
Qed.

End ConsN.

Section Existsb.

 Fixpoint existsb (f:A->bool)(l:list A) {struct l}: bool :=
   match l with
    | nil => false
    | a::l => f a || existsb f l
   end.

 Lemma existsb_nth : forall (f:A->bool)(l:list A) n d, n < length l ->
  existsb f l = false -> f (nth n l d) = false.
 Proof.
 induction l.
 inversion 1.
 simpl; intros.
 destruct (orb_false_elim _ _ H0); clear H0; auto.
 destruct n ; auto.
 rewrite IHl; auto with arith.
 Qed.

End Existsb.

(* finally unused *)
Fixpoint firstn (n:nat)(l:list A) {struct n} : list A :=
 match n with
  | 0 => nil
  | S n => match l with
       | nil => nil
       | a::l => a::(firstn n l)
   end
  end.

End MoreLists.

Implicit Arguments consn [A].

Hint Rewrite
 rev_involutive (* rev (rev l) = l *)
 rev_unit (* rev (l ++ a :: nil) = a :: rev l *)
 map_nth (* nth n (map f l) (f d) = f (nth n l d) *)
 map_length (* length (map f l) = length l *)
 seq_length (* length (seq start len) = len *)
 app_length (* length (l ++ l') = length l + length l' *)
 rev_length (* length (rev l) = length l *)
 consn_length (* length (consn n a l) = n + length l *)
 : list.

Hint Rewrite <-
 app_nil_end (* l = l ++ nil *)
 : list.

Ltac simpl_list := autorewrite with list.
Ltac ssimpl_list := autorewrite with list using simpl.


(* TLC in Coq
 *
 * Module: tlc.operation.periodic_event
 * Purpose: Contains the event type for periodic events.
 *)

Require Import mathcomp.ssreflect.eqtype.
Require Import mathcomp.ssreflect.ssrbool.
Require Import mathcomp.ssreflect.ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* Constant for periodic events
 * Periodic events carry no data.
 *)
Inductive periodic_event := PE.

(* Equality *)
Section eq.

  (* Boolean equality *)
  Definition periodic_event_eq p1 p2 :=
    match p1, p2 with
    | PE, PE => true
    end.

  (* Boolean equality reflection *)
  Lemma periodic_event_eqP : Equality.axiom periodic_event_eq.
  Proof.
    by case; case; constructor.
  Qed.

  (* EqType canonical structures *)
  Definition periodic_event_eqMixin := EqMixin periodic_event_eqP.
  Canonical periodic_event_eqType := EqType periodic_event periodic_event_eqMixin.

End eq.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Bishop.Exp.
Import ExpNotations.
Require Import Blech.Pointed.

Import BishopNotations.
Import PointedNotations.

Definition pt_eqv (A B: Pointed) (x y: A + B) :=
  match (x, y) with
  | (inl x', inl y') => x' == y'
  | (inr x', inr y') => x' == y'

  | (inl x', inr y') => x' == pt ∧ y' == pt
  | (inr x', inl y') => x' == pt ∧ y' == pt
  end.

Require Import Blech.Bishop.Sum.
Require Import Blech.Pointed.
Require Import Blech.Pointed.Exp.

Import ExpNotations.
Import SumNotations.

Close Scope nat.

#[program]
 Definition sum (A B: Pointed): Pointed :=
  point ((A + B) /~ {| equiv := pt_eqv A B |}) (inl pt).

Next Obligation.
Proof.
  admit.
Admitted.

#[program]
Definition fanin {C A B: Pointed} (f: exp A C) (g: exp B C): exp (sum A B) C := fanin f g.

Next Obligation.
Proof.
  intros x y p.
  rewrite p.
  reflexivity.
Qed.

Next Obligation.
Proof.
  intros ? ? p.
  rewrite p.
  reflexivity.
Qed.

Next Obligation.
Proof.
  exists.
  - intros ? ? p.
    destruct x, y.
    all: cbn in *.
    all: try destruct p as [p q].
    all: try rewrite p.
    all: try rewrite q.
    all: repeat rewrite map_pt.
    all: reflexivity.
  - cbn.
    rewrite map_pt.
    reflexivity.
Qed.

#[program]
Definition inl {A B: Pointed}: exp A (sum A B) := inl.

Next Obligation.
Proof.
  exists.
  - intros ? ? p.
    cbn.
    assumption.
  - cbn.
    reflexivity.
Qed.

#[program]
Definition inr {A B: Pointed}: exp B (sum A B) := inr.

Next Obligation.
Proof.
  exists.
  - intros ? ? p.
    cbn.
    assumption.
  - cbn.
    split.
    all: reflexivity.
Qed.

Module SumNotations.
  Infix "+" := sum : pointed_scope.
End SumNotations.


(*********************************************************************)
(*             Stability in Weak Memory Models                       *)
(*                                                                   *)
(*   Jade Alglave INRIA Paris-Rocquencourt, France                   *)
(*                University of Oxford, UK                           *)
(*                                                                   *)
(*  Copyright 2010 Institut National de Recherche en Informatique et *)
(*  en Automatique. All rights reserved. This file is distributed    *)
(*  under the terms of the Lesser GNU General Public License.        *)
(*********************************************************************)

Require Import ZArith.
Require Import Ensembles.
From CoqCat Require Import util.

Set Implicit Arguments.

Ltac decide_equality := decide equality; auto with equality arith.

(** * Basic types *)

(** ** Words

We abstract from word-size and alignment issues for now,
modelling both memory addresses and the values that may be
stored in them by natural numbers. *)

Definition Word := nat.

(** *** Addresses *)

Definition Address := Word.

(** *** Values *)

Definition Value := Word.

(** ** Processors

Processors are indexed by natural numbers. *)

Definition Proc := nat.

Parameter eqProc_dec : forall (x y: Proc), {x=y} + {x <> y}.
Hint Resolve eqProc_dec : equality.

(** The model is expressed in terms of allowable orderings on events: individual
    reads and writes to memory.  Each instance of an instruction in a program
    execution may give rise to multiple events, as described by the instruction
    semantics.  We abstract from the details of instructions, but we record in
    each event the instruction instance id (an iiid) that gave rise to it, so
    that we can refer to the program order over the instruction instances. *)

(** ** Index in program order *)

Definition program_order_index := nat.
Lemma eqPoi_dec : forall (x y: program_order_index), {x=y} + {x <> y}.
Proof.
decide_equality.
Defined.
Hint Resolve eqPoi_dec : equality.

(** ** Iiid: instruction identifier

An instruction instance id specifies the processor
on which the instruction was executed together with the index of
the program-order point at which it was executed (represented by
a natural number). *)

Record Iiid  : Set := mkiiid {
  proc : Proc;
  poi: program_order_index }.
Lemma eqIiid_dec : forall (x y: Iiid), {x=y} + {x <> y}.
Proof.
decide_equality.
Defined.
Hint Resolve eqIiid_dec : equality.

(** ** Eiid: a unique identifier associated to each event *)

Definition Eiid := nat.
Lemma eqEiid_dec : forall (x y: Eiid), {x=y} + {x<>y}.
Proof.
decide_equality.
Defined.
Hint Resolve eqEiid_dec : equality.

(** ** Directions: an memory event is either a read or a write *)

Inductive Dirn : Set :=
  | R : Dirn
  | W : Dirn.
Lemma eqDirn_dec : forall (x y: Dirn), {x=y} + {x <> y}.
Proof.
decide_equality.
Defined.
Hint Resolve eqDirn_dec.

(** ** Location:

A memory location is specified by an address *)

Definition Location := Address.

Lemma eqLoc_dec : forall (x y: Location), {x=y} + {x <> y}.
Proof.
decide_equality.
Defined.
Hint Resolve eqLoc_dec : equality.

(** ** Action:

An access specified by a direction, a location and a value *)

Inductive Action : Set :=
  | Access : Dirn -> Location -> Value -> Action.
Lemma eqAction_dec : forall (x y: Action), {x=y} + {x <> y}.
Proof.
decide_equality.
Defined.
Hint Resolve eqAction_dec : equality.

(** ** Event:

- an unique identifier;
- the associated index in program order and the proc;
- the associated action *)

Record Event : Set := mkev {
  eiid : Eiid;
  iiid : Iiid;
  action : Action}.

Lemma eqEv_dec : forall (x y: Event), {x=y} + {x <> y}.
Proof.
decide_equality.
Defined.
Hint Resolve eqEv_dec : equality.

Lemma eqEvc_dec : forall (x y: Event*Event), {x=y} + {x <> y}.
Proof.
decide_equality.
Defined.
Hint Resolve eqEvc_dec : equality.

(** ** Order Extension of events relation

We admit that we can extend any partial order on events to a total order.
This extension is called a linear extension. The module [OEEvt] specifies
the properties of linear extension of events, and satisfies the general
module type [OrdExt].
*)

Module OEEvt <: OrdExt.

Definition Elt := Event.

(** This extension is called a linear extension (LE) *)

Parameter LE : Rln Event -> Rln Event.

(** A relation is included in its linear extension and this extension is
a strict linear order (i.e. it is total) *)

Parameter OE : forall (s S:set Event) (r:Rln Event),
  Included _ s S ->
  partial_order r s ->
  rel_incl r (LE r) /\
  linear_strict_order (LE r) S.

(** The linear extension of a strict linear order on events is itself *)

Parameter le_lso : forall (s:set Event) (r:Rln Event),
  linear_strict_order r s -> LE r = r.
End OEEvt.

Import OEEvt.

(** ** Synchronization

We have a type for syncronisations.

NOTE: this doesn't seem to be used anywhere, so it might be better to just
remove it.
*)

Parameter Synchronization : Set.
Hypothesis eqSynchronization_dec : forall (x y: Synchronization), {x=y} + {x<>y}.
Hint Resolve eqSynchronization_dec : equality.

(** ** Event structure:

Finally, an event structure collects the events of a candidate execution.

An event structure is composed of:
- a set of events;
- the intra causality relation between events from a same instruction
*)

(* Note that we have to work in Type if we use Ensemble. *)
Record Event_struct : Type := mkes {
  events : set Event;
  iico : Rln Event}.

(** * Program order

We define program order as a relation over two events e1 and e2,
w.r.t. to an event structure es; two events are in program order if:

- both e1 and e2 are in the events of es;
- both events have same processor;
- the program order index of e1 is less than the program order index of e2.

We define two po relations, one as a set of pairs of events, and one as a
predicate of type [Rln] [Evt]. *)

Definition po (es: Event_struct) : set (Event*Event) :=
  fun c => match c with (e1,e2) =>
   (* both events have same processor *)
  (e1.(iiid).(proc) = e2.(iiid).(proc)) /\
  (* the program order index of e1 is less than the program order index of e2 *)
  (le e1.(iiid).(poi) e2.(iiid).(poi)) /\
  (* both e1 and e2 are in the events of e *)
  (In _ es.(events) e1) /\
  (In _ es.(events) e2)
  end.

Definition po_strict (es: Event_struct) : Rln Event :=
  fun e1 => fun e2 =>
   (* both events have same processor *)
  (e1.(iiid).(proc) = e2.(iiid).(proc)) /\
  (* the program order index of e1 is less than the program order index of e2 *)
  (lt e1.(iiid).(poi) e2.(iiid).(poi)) /\
  (* both e1 and e2 are in the events of e *)
  (In _ es.(events) e1) /\
  (In _ es.(events) e2).

(** Our final notion of program order will be the union of the program order
    relation as defined above, and of the intra-instruction order. Indeed,
    events might share the same iiid if they are the result of the same
    instruction, we need to take iico into account.
*)

Definition po_iico (E:Event_struct) : Rln Event :=
  fun e1 => fun e2 =>
    (po_strict E) e1 e2 \/ (iico E) e1 e2.

(** ** State constraints *)

Definition State_constraint := Location -> Value.

(** * Basic operations on data types *)

(** Extract the location of an event *)

 Definition loc (e:Event) : (*option*) Location :=
  match e.(action) with
  | Access _ l _ => (*Some*) l
  end.

(** Extract the value read or written during an event *)

Definition value_of (e:Event) : option Value :=
  match e.(action) with
  | Access _ _ v => Some v
  end.

(** ** Processors *)

(** *** Extract the processor on which the event is occuring *)

Definition proc_of (e:Event) : Proc := e.(iiid).(proc).

(** *** Extract the set of processors on which the events from an event
structure are occuring *)

Definition procs (es: Event_struct) : set Proc :=
   fun p => exists e,
     In _ es.(events) e /\
     p = proc_of e.

(** ** Particular events of an event structure *)
(* I comment this, because it is used nowhere and this definition really
   disturbes me. [exists l, exists a, l = a] is always true for me. And so is
   [loc e = l] *)

(*
Definition to_shared (s:set Event) : set (Event) :=
  fun e => In _ s e /\ exists l, exists a, l = a /\ loc e = l.
*)

(** *** Reads

Extract the set of read events *)

Definition reads (es:Event_struct) : set Event :=
  fun e => (In _ es.(events) e) /\
           (exists l, exists v, e.(action) = Access R l v).

(** *** Writes

Extract the set of write events *)

Definition writes (es:Event_struct) : set Event :=
  fun e => (In _ es.(events) e) /\
           (exists l, exists v, e.(action) = Access W l v).

(** * Processor issue order *)

(** Restrict the program order to events reading from or writing to a same
    location *)

Definition pio (E:Event_struct) : Rln Event :=
  fun e1 => fun e2 =>
    loc e1 = loc e2 /\ po_iico E e1 e2.

(** Restrict the processor issue order to pairs of events for which at least one
    of the two events is a write *)

Definition pio_llh (E:Event_struct) : Rln Event :=
  fun e1 => fun e2 =>
    loc e1 = loc e2 /\ po_iico E e1 e2 /\
    ~(reads E e1 /\ reads E e2).

(** * Well-formedness of an event structure

An event structure is well-formed if:

- Two events ordered by the program ordered are executed on the same processor;
- If two events of the event structure have the same event id and the same
  instruction id, they are the same event;
- The domain of intra-instruction order is included in the set of events of the
  event structure;
- The range of intra-instruction order is included in the set of events of the
  event structure;
- The intra-instruction order is acyclic;
- If two events of the event structure have the same iiid, they are related by
  the intra-instruction order;
- Conversely, two events ordered by the intra-instruction order must have the
  same iiid;
- The intra-instruction order is a transitive relation
*)

Definition well_formed_event_structure (E:Event_struct) : Prop :=
  (forall x y, po_iico E x y -> proc_of x = proc_of y) /\
  (forall e1 e2, In _ E.(events) e1 -> In _ E.(events) e2 ->
   (e1.(eiid) = e2.(eiid)) /\ (e1.(iiid) = e2.(iiid)) -> (e1 = e2)) /\
   Included _ (dom (iico E)) E.(events) /\
   Included _ (ran (iico E)) E.(events) /\
   acyclic (iico E) /\ (forall x y, events E x /\ events E y /\
   poi (iiid x) = poi (iiid y) -> iico E x y) /\
   (forall e1 e2, (iico E) e1 e2 -> (e1.(iiid) = e2.(iiid))) /\
   trans (iico E).

(** * Write serializations

Write Serialization (also called coherence order (co)) orders all pairs of
writes to a same location *)

Definition Write_serialization := Rln Event.

(** Takes an event and a location as parameters, and is true if
    the event is a write to that location *)

Definition write_to (e:Event) (l:Location) : Prop :=
  exists v, action e = Access W l v.

(** Takes a set of events and a location as parameters, and is true if all the
    events are writes to that location *)
Definition writes_to_same_loc_l (s:set Event) (l:Location) : set Event :=
  fun e => In _ s e /\ write_to e l.

(** Write serialization relation is well formed if:

- For each location, the relation is a total order on the writes to this
  relation;
- The relation relates pairs of writes to a same location *)

Definition write_serialization_well_formed (s:set Event) (ws:Write_serialization) : Prop :=
  (forall l, linear_strict_order
     (rrestrict ws (writes_to_same_loc_l s l))
       (writes_to_same_loc_l s l)) (* Hws_tot *) /\
  (forall x e, ws x e ->
   (exists l : Location,
    In _ (writes_to_same_loc_l s l) x /\
    In _ (writes_to_same_loc_l s l) e)) (* Hws_cands *).

Ltac destruct_ws H :=
  destruct H as [Hws_tot Hws_cands].

(** * Read-from

The read-from (rf) relation orders a write event to the read events that
read the value written by the write event *)

Definition Rfmap := Rln Event.

(** Takes an event and location as parameters, and is true if the event is a read
    event *)

Definition read_from (e:Event) (l:Location) : Prop :=
  exists v, action e = Access R l v.

(** Takes a set of events as a parameter, and returns a relation that relates any
    write to the reads to the same location reading the value written by the
   write event *)

Definition rfmaps (s:set Event) : Rln Event :=
  fun e1 => fun e2 =>
  In _ s e1 /\ In _ s e2 /\
  exists l, write_to e1 l /\ read_from e2 l /\
    value_of e1 = value_of e2.

(* I comment this, because it is used nowhere and this definition disturbes me *)
(*
Definition no_intervening_write (e1 e2:Event) (s:Rln Event): Prop :=
  s e1 e2 /\
  forall l, write_to e1 l ->
    ~(exists e3, write_to e3 l /\ s e1 e3 /\ s e3 e2).
*)

(** Takes an event structure as a parameter and returns a relation that relates
    any read from a given location to the writes following it in program
    order affecting the same location
*)

Definition ls (E:Event_struct) : Rln Event :=
  fun e1 => fun e2 =>
    In _ (reads E) e1 /\ In _ (writes E) e2 /\ (po_iico E) e1 e2.

(** A read-from relation produced by [rfmaps] is well-formed if:

- For any read event, there is a write event such that the write event is
  related to the read event by the read-from relation
- If two write events are related to a same read event, the two writes are the
  the same write event.
*)

Definition rfmaps_well_formed (E:Event_struct) (s:set Event) (rf:Rfmap) : Prop :=
  (forall er, In _ (reads E) er -> exists ew,
     ((In _ s ew) /\ rf ew er)) /\ (*Hrf_init*)
  (forall e1 e2, rf e1 e2 -> (rfmaps s) e1 e2) /\ (*Hrf_cands*)
   (forall x w1 w2, rf w1 x -> rf w2 x ->
    w1 = w2).  (*Hrf_uni*)

Ltac destruct_rf H :=
  destruct H as [Hrf_init [Hrf_cands Hrf_uni]].

(** * From-read

The from-read (fr) relation orders a read event to all the write events that
occur after (w.r.t. the write serialization order) the write that the read-from
relation relates to the read we consider.
*)

Definition Frmap := Rln Event.

(** Takes a set of events, a read-from relation and a write serialization, and
compute the corresponding from-read relation *)

Definition frmaps (s:set Event) (rf:Rfmap) (ws:Write_serialization) : Frmap :=
  fun er => fun ew =>
    In _ s er /\ In _ s ew /\
    exists wr, rf wr er /\ ws wr ew.

(** * AB orderings

AB is a relation on events, that encodes the execution order constraints issued
by barries in our program *)

Definition AB := Rln Event.

(** An order AB is well-formed on a set of events if it relates only events of
this set, and it never imposes an order between two events that are identical *)

Definition ab_well_formed (s:set Event) (abc : AB) :=
  (forall x y, abc x y -> In _ s x /\ In _ s y /\ x<>y).

(** * Execution Witness

An execution witness characterizes an execution and is composed of:

- a write seralization order
- a read-from relation
*)

Record Execution_witness : Type := mkew {
  ws : Write_serialization;
  rf : Rfmap }.

(** Extracts a from-read relation from an event structure and an execution
    witness *)

Definition fr (E:Event_struct) (X:Execution_witness) : Frmap :=
  frmaps (events E) (rf X) (ws X).

(** Extracts the subset of a read-from relation where the write and the read
    are executed on different processors *)

Definition rf_intra (X:Execution_witness) : Rfmap :=
  fun ew => fun er => (rf X) ew er /\ proc_of ew = proc_of er.

(** Extracts the subset of a read-from relation where the write and the read
    are executed on the same processor *)

Definition rf_inter (X:Execution_witness) : Rfmap :=
  fun ew => fun er => (rf X) ew er /\ proc_of ew <> proc_of er.

(*Definition sync_ws X :=
  acyclic (rel_union (sync X) (ws X)).
Definition sync_fr E X :=
  acyclic (rel_union (sync X) (fr E X)).
(*Definition sync_po E X :=
  acyclic (rel_union (po_iico E) (sync X)).
  (*rel_incl (*(A2.ppo E)*) (ppo_sub E) (sync X).*)
Definition sync_rf(*sub*) X :=
  acyclic (rel_union (sync X) (rf(*_sub*) X)).*)
Definition sync_ac X :=
  acyclic (sync X).
Definition sync_trans X :=
  trans (sync X).

Definition wf_sync E X :=
  sync_ws X /\ sync_fr E X /\ (*sync_rf X /\ sync_po E X /\*)
  sync_ac X /\ sync_trans X.*)

(*
Axiom init_rf :
  forall E X s w r,
  init E w -> rf X w r ->
    rf (mkew (rrestrict (ws X) s) (rrestrict (rf X) s)) w r.
Axiom init_ws :
  forall E X s w w',
  init E w -> ws X w w' ->
    ws (mkew (rrestrict (ws X) s) (rrestrict (rf X) s)) w w'.
Axiom init_po :
  forall E i,
  init E i ->
  (forall e, events E e -> proc_of e = proc_of i -> po_iico E i e).
Axiom final_po :
  forall E f,
  final E f ->
  forall e, events E e -> proc_of e = proc_of f -> po_iico E e f.
*)

Ltac destruct_wfs H :=
   destruct H as [Hsws [Hsfr (*[Hsrf [Hspo*) [Hsac Hstrans]]](*]]*).

(* (** ** Initial and final states *) *)

(*Definition init (X:Execution_witness) : set Event :=
  fun x => exists wx, (rf X) wx x /\ ~(exists ew, (ws X) ew wx).

Definition final (X:Execution_witness) : set Event :=
  fun x => ~(exists e, (ws X) x e).*)

(** * Valid execution *)

(** ** Happens Before

The communication relation is the union of the read-from, from-read and write
serialization relations. It is called communication relation in (A Shared Memory
Poetics, 2010, Jade Alglave)
 *)

Definition com (E:Event_struct) (X:Execution_witness) : Rln Event :=
  rel_union (rel_union (rf X) (fr E X)) (ws X).

(** An execution is valid in the sequentially consistent memory model if the
union of its program order and of its communication relation is acyclic *)

Definition sc_check (E:Event_struct) (X:Execution_witness) : Prop :=
  acyclic (rel_union (po_iico E) (com E X)).

(** Two events from an event structure are competing if:

- They are executed on different processors;
- They affect the same location;
- At least one of them is a write event *)

Definition compete E : Rln Event :=
  fun e1 => fun e2 =>
  (events E) e1 /\ (events E) e2 /\
  loc e1 = loc e2 /\ proc_of e1 <> proc_of e2 /\
  (writes E e1 \/ writes E e2).

(** * Dependencies

This type describes the properties that a module describing the dependencies
between the instructions must respect
*)

Module Type Dp.

(** We have a function that takes an event structure as a parameter and returns
a relation that orders events according to the dependencies between them *)

Parameter dp : Event_struct -> Rln Event.

(** A dependency relation is valid only if:

- It is included in the program order
- It is a transitive relation
- It only relates read events to other events *)

Parameter dp_valid : forall (E:Event_struct),
  rel_incl (dp E) (po_iico E) /\ trans (dp E) /\
  forall x y, dp E x y -> reads E x.

(** Given an event structure and a subset of its events, we can restrict the
dependency relation to the elements of this event structure that belong to this
subset *)

Hypothesis dp_fun :
  forall E s x y,
  dp E x y /\ s x /\ s y <->
  dp (mkes (Intersection Event (events E) s) (rrestrict (iico E) s)) x y.
End Dp.

(** * Architecture

An architecture is represented by three things:

- Its preserved program order : the part of the program order that the
architecture guarantees will be respected in the execution
- Its global read-from: depending on the architecture, some writes might no be
directly available to all threads immediatly after they are executed, and thus
some parts of the read-from relation might not be visible globally.
- Its barriers : each architecture has its own barriers, and we must encode how
they affect the execution order of events
*)

Module Type Archi.

(** Associates to an event structure, an order on its events *)

Parameter ppo : Event_struct -> Rln Event.

(** This order is a subset of the program order. Thus, it represents the part of
the program order that the architecture guarantees to respect *)

Hypothesis ppo_valid : forall (E:Event_struct),
  rel_incl (ppo E) (po_iico E).

(** Given an event structure and a subset of its events, we can restrict the
preserved program order to the elements of the event structure that belong to
this subset *)

Hypothesis ppo_fun :
  forall E s x y,
  ppo E x y /\ s x /\ s y <->
  ppo (mkes (Intersection Event (events E) s) (rrestrict (iico E) s)) x y.

(** If [intra] is true, the subset of read-from defined by [rf_intra], i.e. the
subset of read-from where the write and the read are executed on the same
thread, is visible globally *)

Parameter intra : bool.

(** If [inter] is true, the subset of read-from defined by [rf_inter], i.e. the
subset of read-from where the write and the read are executed on different
threads, is visible globally *)

Parameter inter : bool.

(** The barrier relation associates to an event structure and an execution
witness a relation on its events *)

Parameter abc : Event_struct -> Execution_witness -> Rln Event.

(** If the event structure is well-formed and if the read-from relation of the
execution witness is well-formed, then events related by the barrier relation
are events from the event structure *)

Hypothesis ab_evts : forall (E:Event_struct) (X:Execution_witness),
  forall x y, well_formed_event_structure E ->
  rfmaps_well_formed E (events E) (rf X) ->
  abc E X x y -> In _ (events E) x /\ In _ (events E) y.

(** Our barriers can't contradict the program order (event structure) or the
communication relation (execution witness). *)

Hypothesis ab_incl :
  forall E X, rel_incl (abc E X) (tc (rel_union (com E X) (po_iico E))).

(** It is not exactly clear what this represents, and it seems to be left as
a parameter everywhere. Needs further documentation *)

(* Hypothesis ab_fun :
  forall E X init final s x y,
  well_formed_event_structure E ->
  rfmaps_well_formed E (events E) (rf X) ->
  (abc E X x y /\ s x /\ s y <->
  abc (mkes init (Intersection Event (events E) s) (rrestrict (iico E) s) final)
    (mkew (rrestrict (ws X) s) (rrestrict (rf X) s)) x y). *)

Parameter stars : Event_struct -> set Event.
End Archi.

(** * Memory Model

A memory model defines the notion of validity of an execution, based on an
architecture module and a dependencies module
*)

Module Wmm (A : Archi) (dp : Dp).
Import A.
Import dp.

(** ** Global Happens Before

The global happens-before relation is the union of:

- The subsets of read-from that are global on the architecture
- The barriers relation
- The write serialization relation
- The from-read relation
- The preserved program order *)

Definition ghb (E:Event_struct) (X:Execution_witness) :
  Rln Event :=
  match inter,intra with
  | true,true =>
    rel_union (rf_inter X) (rel_union (rf_intra X) (rel_union (abc E X)
      (rel_union (rel_union (ws X) (fr E X)) (ppo E))))
  | true,false =>
    rel_union (rf_inter X) (rel_union (abc E X) (rel_union (rel_union (ws X) (fr E X))
      (ppo E)))
  | false,true =>
    rel_union (rf_intra X) (rel_union (abc E X) (rel_union (rel_union (ws X) (fr E X))
      (ppo E)))
  | false,false =>
    rel_union (abc E X) (rel_union (rel_union (ws X) (fr E X))
      (ppo E))
  end.

(** ** Uniprocessor

The uniprocessor condition on executions states that the communication relation must be compatible with processor issue order restricted to pairs of event where at least one of the events is the write.

Concretely, this means that :

- If two writes are ordered by the write serialization order, they must occur in this order;
- If a read reads the value written by a specific write, the write event must occur before the read event;
- If a read reads the value written by a first write preceding a second write, this read event must occur before the second event
 *)

Definition uniproc E X :=
  (*if llh then*) acyclic (rel_union (com E X) (pio_llh E))
  (*else acyclic (rel_union (com E X) (pio E))*).

(** ** Out of thin air

The out of thin air condition on executions states that the read-from relation
must be compatible with the dependency relation.

Concretely, this means that a write cannot depend on a read that read its value
from this same write *)

Definition thin E X :=
  acyclic (rel_union (rf X) (dp E)).

(** ** Execution validity

An execution (i.e. an event structure and an execution witness) is valid when:

- The read-from and write serialization relations are well-formed
- The execution respects the uniprocessor condition (see [uniproc])
- The execution respects the out of thin air condition (see [thin])
- The global happens-before relation is acyclic *)

Definition valid_execution (E:Event_struct) (X:Execution_witness) : Prop :=
  write_serialization_well_formed (events E) (ws X) /\
  rfmaps_well_formed E (events E) (rf X) /\
  acyclic (rel_union (com E X) (pio_llh E)) /\ (* uniproc: per location coherence *)
  acyclic (rel_union (rf X) (dp E)) /\ (* out-of-thin-air condition *)
  acyclic (ghb E X).

(** Corresponds to [rf_intra] when [intra] is true, and to the empty relation
otherwise *)

Definition mrfi X :=
  mrel intra (rf_intra X).

(** Corresponds to [rf_inter] when [inter] is true, and to the empty relation
otherwise *)

Definition mrfe X :=
  mrel inter (rf_inter X).

(** Union of [mrfi] and of [mrfe] *)

Definition mrf X :=
  rel_union (mrfi X) (mrfe X).

(** Happens-before relation where we consider only the global read-from relation

NOTE:
This looks a little bit more complicated than it should ? What is the difference
between [mhb] and [mhb'] ? They both end up containing [ws], [fr] and [grf].

In the end couldn't we just write:

<<
Definition mhb (E:Event_struct) (X:Execution_witness) : Rln_Event :=
  rel_union (mrf X) (rel_union (ws X) (fr E X)).
>>
*)

Definition mhb (E:Event_struct) (X:Execution_witness) :
  Rln Event :=
  match inter,intra with
  | true,true =>
    rel_union (rf_inter X) (rel_union (rf_intra X) (rel_union (ws X) (fr E X)))
  | true,false =>
    rel_union (rf_inter X) (rel_union (ws X) (fr E X))
  | false,true =>
    rel_union (rf_intra X) (rel_union (ws X) (fr E X))
  | false,false =>
    (rel_union (ws X) (fr E X))
  end.

(** [mhb'] is the union of:

- The [mhb] relation
- The sequence of write serialization and global read-from. This relation is, in
some sense, the opposite of from-read. From-read relates reads with the writes
that occured after the write of the value that the read event reads. The
sequence of write serialization and read-from relates a write to a read such
that the write occured _before_ the write of the value that the read reads.
- The sequence of from-read and global read-from. This relation relates to read
events that read from the same location, but values written by two different
read events.

NOTE: This relation corresponds to the [hb'] relation in which we consider only
the global parts of read-from.
*)

Definition mhb' (E:Event_struct) (X:Execution_witness) : Rln Event :=
  fun e1 => fun e2 =>
    (rel_union (rel_union (mhb E X) (rel_seq (ws X) (mrf X))) (rel_seq (fr E X) (mrf X))) e1 e2.

Ltac destruct_valid H :=
  destruct H as [[Hws_tot Hws_cands]
                 [[Hrf_init [Hrf_cands Hrf_uni]] (*[Hwfs*)
                  [Hsp [Hth Hvalid]]]](*]*);
  unfold write_serialization_well_formed in Hws_tot(*; unfold uniproc in Hsp*).

(*
Goal forall E X, valid_execution E X -> True.
intros E X Hvalid.
destruct_valid Hvalid.
*)

End Wmm.


Require Export Coq.Classes.Morphisms.

Require Export NamelessUTLC.Core.

Class FunctorMap (F: Type -> Type) := fmap: forall {A B}, (A -> B) -> F A -> F B.
Arguments fmap F FunctorMap A B f !x /.

Unset Implicit Arguments.
Class Functor (F: Type -> Type) `{FunctorMap_F: FunctorMap F}
      `{Proper_fmap: forall {A B}, Proper ((@eqfun B A) ==> eq ==> eq) fmap} :=
  { fmap_id: forall {A}, left_id (@id A) fmap;
    fmap_comp: forall {A B C} (f: B -> C) (g: A -> B) x, fmap f (fmap g x) = fmap (f \o g) x }.

Lemma comp_rw : forall {A B C} {f: B -> C} {g: A -> B} {x}, f (g x) = (f \o g) x.
Proof. done. Qed.

Instance option_FunctorMap : FunctorMap option := omap.

Instance omap_proper {A B} : Proper ((@eqfun B A) ==> eq ==> eq) (@omap A B).
Proof. move=> f g eq x y {y} <-. by case: x => /=. Qed.

Instance option_Functor : Functor option.
Proof. split.
  - move=> ?. by case.
  - move=> ? ? ? ? ?. by case.
Qed.

Instance const_FunctorMap A : FunctorMap (fun _ => A) := fun _ _ _ => id.

Instance const_fmap_Proper A B C : Proper (@eqfun B C ==> @eq A ==> @eq A) (fun _ => id).
Proof. by move=> _ _ _ ? _ <-. Qed.

Instance const_Functor A : Functor (fun _ => A).
Proof. split.
  - move=> ? ?. by rewrite /fmap /const_FunctorMap.
  - move=> *. by rewrite /fmap /const_FunctorMap.
Qed.


Require Import Coq.Lists.List.
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Named.Syntax.

Local Open Scope list_scope.

Section language.
  Context {base_type_code}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}
          {Name : Type}.

  Local Notation exprf := (@exprf base_type_code op Name).
  Local Notation expr := (@expr base_type_code op Name).

  Fixpoint get_names_of_type {t} : interp_flat_type (fun _ : base_type_code => Name) t -> list Name
    := match t with
       | Tbase T => fun n => n::nil
       | Unit => fun _ => nil
       | Prod A B => fun ab : interp_flat_type _ A * interp_flat_type _ B
                     => @get_names_of_type _ (fst ab) ++ @get_names_of_type _ (snd ab)
       end.

  Fixpoint get_namesf {t} (e : exprf t) : list Name
    := match e with
       | TT => nil
       | Var _ x => x::nil
       | Op _ _ opc args => @get_namesf _ args
       | LetIn tx nx ex tC eC
         => get_names_of_type nx ++ (* @get_namesf _ ex ++ *) @get_namesf _ eC
       | Pair _ ex _ ey
         => @get_namesf _ ex ++ @get_namesf _ ey
       end.

  Fixpoint get_names {t} (e : expr t) : list Name
    := match e with
       | Abs _ _ n f => get_names_of_type n ++ get_namesf f
       end.
End language.


Require Import Coqlib.
Require Import ITreelib.
Require Import ImpPrelude.
Require Import STS.
Require Import Behavior.
Require Import ModSem.
Require Import Skeleton.
Require Import PCM.
Require Import Imp.
Require Import ImpNotations.

Set Implicit Arguments.

Section G.
  Context `{Σ: GRA.t}.

  Import ImpNotations.
  Local Open Scope expr_scope.
  Local Open Scope stmt_scope.

  Definition gF :=
    mk_function
      ["n"]
      ["f_ret"]
      (if# "n"
       then# "f_ret" =@ "f" ["n" - 1%Z : expr] ;#
             return# "n" + "f_ret"
       else# return# 0%Z
       fi#).

  Definition g_prog : program :=
    mk_program
      "G"
      []
      [("f", 1)]
      []
      [("g", gF)]
  .

  Definition GSem ge: ModSem.t := ImpMod.modsem g_prog ge.
  Definition G : Mod.t := ImpMod.get_mod g_prog.

End G.


(* begin hide *)
From Coq Require Import
     Arith.PeanoNat
     Logic.FunctionalExtensionality
     Logic.Decidable
     Lists.List
     Lia
     Classes.RelationClasses
     Classes.Morphisms
     FSets.FMaps.

From Heapster Require Import
     Utils
     RoseTree.

Import ListNotations.
Open Scope list_scope.
(* end hide *)

(* Lifetime keys *)
Variant status := current | finished.

Definition status_lte (s1 s2 : status) : Prop :=
  match s1, s2 with
  | finished, current => False
  | _, _ => True
  end.

(* (** [s1] subsumes [s2]: [s1] cannot finish before [s2] *) *)
(* Definition status_subsumes (s1 s2 : status) : Prop := *)
(*   match s1, s2 with *)
(*   | finished, current => False *)
(*   | _, _ => True *)
(*   end. *)

Global Instance status_lte_preorder : PreOrder status_lte.
Proof.
  constructor; repeat intro; subst; auto.
  - destruct x; constructor.
  - destruct x, y, z; auto.
Qed.

Definition statusOf_lte (s1 s2 : option status) : Prop :=
  match s1, s2 with
  | Some s1, Some s2 => status_lte s1 s2
  | Some _, None => False
  | _, _ => True
  end.
Global Instance statusOf_lte_preorder : PreOrder statusOf_lte.
Proof.
  constructor; repeat intro; subst; auto.
  - destruct x; cbn; auto. reflexivity.
  - destruct x, y, z; cbn in *; intuition.
    etransitivity; eauto.
Qed.

(** [s1] subsumes [s2], now with unstarted lifetimes (None) *)
Definition statusOf_subsumes (s1 s2 : option status) : Prop :=
  match s1, s2 with
  (* [s1] can't end before [s2] *)
  | Some finished, Some finished => True
  | Some finished, _ => False
    (* [s2] can't start before [s1] *)
  | None, Some _ => False
  | _, _ => True
  end.

Global Instance statusOf_subsumes_preorder : PreOrder statusOf_subsumes.
Proof.
  constructor; repeat intro; subst; auto.
  - destruct x; [destruct s |]; cbn; auto.
  - destruct x, y, z; cbn in *; intuition; destruct s, s0; intuition.
Qed.

(** a [Lifetime] contains a number for disambiguation and its direct parent [Lifetime]s *)
Definition Lifetime := rose.

Definition parent_of (l1 l2 : Lifetime) : Prop :=
  l1 = l2 \/
    parent l1 l2 = true.

Global Instance parent_of_trans : Transitive parent_of.
Proof.
  repeat intro. destruct H, H0; subst; unfold parent_of; auto.
  right. eapply parent_trans; eauto.
Qed.

Definition index (l : Lifetime) : nat :=
  match l with
  | node index _ => index
  end.

(* Definition parents (l : Lifetime) : Parents := *)
(*   match l with *)
(*   | node _ parents => parents *)
(*   end. *)

Module K <: DecidableType.
  Definition t := Lifetime.
  Definition eq := @eq Lifetime.
  Definition eq_refl := @eq_refl Lifetime.
  Definition eq_sym := @eq_sym Lifetime.
  Definition eq_trans := @eq_trans Lifetime.
  Definition eq_dec := rose_eq_dec.
End K.

Module Import M := FMapWeakList.Make(K).
Module P := WProperties_fun K M.
Module F := P.F.

Definition mapT := M.t status.

Record Lifetimes : Type :=
  {
    m : mapT;

    (** Properties *)
    (* (* maybe not needed *) *)
    (* acyclic_keys : forall l, In l m -> acyclic l; *)

    parents_exist : forall l p, In l m ->
                           parent_of p l ->
                           In p m;

    parents_subsume : forall l p, In l m ->
                             parent_of p l ->
                             statusOf_subsumes (find p m) (find l m);
  }.

Definition Lifetimes_In (l : Lifetime) (ls : Lifetimes) : Prop :=
    In l (m ls).

(* Maybe do a lookup on l for its parents' statuses. This will implicitly end all children lifetimes hwen you end a parent lifetime *)

(* Alternatively make ls a total map, so we can keep track of *all* children *)
Definition statusOf (l : Lifetime) (ls : Lifetimes) : option status :=
  (* map through the parnets of l, and look for any that are in ls. If any of those are finished, then we should return finished too *)
  find l (m ls).

Definition Lifetimes_lte (ls ls' : Lifetimes) : Prop :=
  forall l, (In l (m ls) -> In l (m ls')) /\ statusOf_lte (statusOf l ls) (statusOf l ls').

Global Instance Lifetimes_lte_preorder : PreOrder Lifetimes_lte.
Proof.
  constructor; repeat intro.
  - split; auto. reflexivity.
  - split.
    + intros. apply H0. apply H; auto.
    + edestruct H, H0. etransitivity; eauto.
Qed.

(*
  Program Definition newLifetime (ls : Lifetimes) (ps : list Lifetime) (H : forall p, In p parents -> inL p ls) :
    (Lifetime * Lifetimes) :=
    let i := length (lst ls) in
    let parentIndices := map index parents in
    (
      node i parents,
      {|
        lst := lst ls ++ [(current, parentIndices)];
      |}
    ).
  Next Obligation.
  Admitted.
  Next Obligation.
    pose proof parents_subsumption.
  Admitted.
  Next Obligation.
  Admitted.
 *)

Program Definition endLifetime (l : Lifetime) (ls : Lifetimes) (* and some proof that all the parents are finished? *) : Lifetimes.
Admitted.

(** [l1] subsumes [l2] *)
Definition subsumes (l1 l2 : Lifetime) : Prop :=
  l1 = l2 \/ parent_of l1 l2.

#[global] Instance subsumes_preorder : PreOrder subsumes.
Proof.
  constructor; repeat intro; cbn; auto.
  - left; auto.
  - unfold subsumes in *. destruct H, H0; subst; auto. right.
    etransitivity; eauto.
Qed.

Lemma parent_find l1 l2 l s :
  parent_of l1 l2 ->
  @find status l1 (m l) = Some s ->
  @find status l2 (m l) = Some s.
Proof.
  intros.
  destruct l. cbn in *.
Admitted.

Lemma subsumes_status l :
  forall l1 l2, subsumes l1 l2 ->
           statusOf_subsumes (statusOf l1 l) (statusOf l2 l).
Proof.
    intros. unfold subsumes in H. destruct H; subst; auto.
    reflexivity.
    destruct (F.In_dec (m l) l2).
    - apply parents_subsume; auto.
    - unfold statusOf. apply F.not_find_in_iff in n. rewrite n.
      destruct (find l1 (m l)) eqn:?; cbn; auto.
      destruct s; auto. erewrite parent_find in n; eauto. inversion n.
Qed.

(*
Variant Lifetime := current | finished.

Definition Lifetimes := list Lifetime.

(** lifetime helpers **)

Definition lifetime : Lifetimes -> nat -> option Lifetime :=
  @nth_error Lifetime.

(* Definition replace_lifetime (l : Lifetimes) (n : nat) (new : Lifetime) : Lifetimes := *)
(*   replace_list_index l n new. *)

(* Lemma replace_lifetime_same c n l : *)
(*   lifetime c n = Some l -> replace_lifetime c n l = c. *)
(* Proof. *)
(*   apply replace_list_index_eq. *)
(* Qed. *)

(* Lemma lifetime_replace_lifetime c n l : *)
(*   lifetime (replace_lifetime c n l) n = Some l. *)
(* Proof. *)
(*   apply nth_error_replace_list_index_eq. *)
(* Qed. *)

(** [n1] in the lifetime list [x1] subsumes [n2] in the lifetime list [x2] *)
Definition subsumes n1 n2 x1 x2 :=
  (Some current = lifetime x2 n2 -> Some current = lifetime x1 n1) /\
  (Some finished = lifetime x1 n1 -> Some finished = lifetime x2 n2) /\
  (None = lifetime x1 n1 -> None = lifetime x2 n2).

(* TODO: generalize to a single lemma *)
Instance subsumes_preorder x : PreOrder (fun a b => subsumes a b x x).
Proof.
  unfold subsumes.
  constructor; [repeat intro; auto |].
  intros n1 n2 n3. intros (? & ? & ?) (? & ? & ?). split; [| split]; intros.
  - apply H. apply H2; auto.
  - apply H3. apply H0; auto.
  - apply H4. apply H1; auto.
Qed.
Instance subsumes_preorder' x : PreOrder (subsumes x x).
Proof.
  unfold subsumes.
  constructor; [repeat intro; auto |].
  intros n1 n2 n3. intros (? & ? & ?) (? & ? & ?). split; [| split]; intros.
  - apply H. apply H2; auto.
  - apply H3. apply H0; auto.
  - apply H4. apply H1; auto.
Qed.

Lemma subsumes_decidable n1 n2 l1 l2 : decidable (subsumes n1 n2 l1 l2).
Proof.
  unfold subsumes.
Admitted.

Lemma not_subsumes n1 n2 n3 l :
  ~subsumes n1 n3 l l -> ~subsumes n1 n2 l l \/ ~subsumes n2 n3 l l.
Proof.
  intro H. red in H.
  destruct (lifetime l n1) eqn:Hl1; [destruct l0 |];
    (destruct (lifetime l n2) eqn:Hl2; [destruct l0 |]);
    (destruct (lifetime l n3) eqn:Hl3; [destruct l0 |]).
  all: try solve [exfalso; apply H; split; [| split];
                  rewrite Hl1, Hl3; auto; intro Hc; discriminate Hc].
  all: try solve [left; intro H'; red in H'; rewrite Hl1, Hl2 in H';
                  destruct H' as (H1 & H2 & H3);
                  try solve [discriminate H1; auto];
                  try solve [discriminate H2; auto];
                  try solve [discriminate H3; auto]].
  all: try solve [right; intro H'; red in H'; rewrite Hl2, Hl3 in H';
                  destruct H' as (H1 & H2 & H3);
                  try solve [discriminate H1; auto];
                  try solve [discriminate H2; auto];
                  try solve [discriminate H3; auto]].
Qed.

(** Lifetime ordering **)
Definition lifetime_lte (l1 l2 : option Lifetime) : Prop :=
  match l1, l2 with
  | None, _ => True
  | Some current, None => False
  | Some current, _ => True
  | Some finished, Some finished => True
  | _, _ => False
  end.

Instance lifetime_lte_preorder : PreOrder lifetime_lte.
Proof.
  constructor; repeat intro.
  - destruct x as [[] |]; simpl; auto.
  - destruct x as [[] |], y as [[] |], z as [[] |]; simpl; intuition.
Qed.

*)


Require Import trees.

Set Implicit Arguments.

(* Deallocate one tree *)
Definition dealloc_def := FunDef "deallocate" ["t"]
  (SIf ("t"=0)
    SReturnVoid
   {{SCall "deallocate" ["t"->>"left"]
    ;SCall "deallocate" ["t"->>"right"]
    ;HDealloc "t"
    ;SReturnVoid
    }}).
(* Deallocate a whole list of trees *)
Definition iter_dealloc_def := FunDef "iter_deallocate" ["l"]
  {{Decl "lt";
    SWhile ("l" <> 0)
     {{SCall "deallocate" ["l"->>"val"]
      ;"lt" <- "l"
      ;"l" <- "l"->>"next"
      ;HDealloc "lt"
      }};
    SReturnVoid}}.

Inductive dealloc_spec : Spec kcfg :=
  dealloc_claim : forall t p, heap_void_fun dealloc_spec nil
  dealloc_def [Int p] (rep_tree t p) emptyP
 |iter_dealloc_claim : forall l p, heap_void_fun dealloc_spec [dealloc_def]
  iter_dealloc_def [Int p] (rep_prop_list rep_tree l p) (emptyP)
 |iter_dealloc_loop_claim : forall v l p, heap_void_loop dealloc_spec [dealloc_def]
  iter_dealloc_def 0 ("l" s|-> KInt p :* "lt" s|-> v)
  (rep_prop_list rep_tree l p) (emptyP).

Lemma dealloc_proof : sound kstep dealloc_spec.
Proof. tree_solver. Qed.