(** This file implements normalization for separation lgoic formulas.
 ** The normal form is:
 **   (a /\ b /\ c) /\ (P * Q * R [* true]?)
 ** The final [* true] is optional and is likely to never occur in
 ** practice but is necessary to make the algorithm total.
 **
 ** In this format, all of [a], [b], and [c] are pure which means that
 ** the above equation is equivalent to:
 **  Inj a * Inj b * Inj c * P * Q * R [* true]?
 ** where [Inj p = p /\ emp]
 **)
Require Import Coq.Classes.Morphisms.
Require Import ExtLib.Data.Positive.
Require Import ExtLib.Data.HList.
Require Import ExtLib.Tactics.
Require Import BILogic ILogic Pure.
Require Import MirrorCore.EnvI.
Require Import MirrorCore.SymI.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.TypesI.
Require Import MirrorCore.ExprSem.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.Lambda.AppN.
Require Import MirrorCore.Lambda.TypedFoldApp.
Require Import MirrorCharge.Iterated.
Require Import MirrorCharge.ILogicFunc MirrorCharge.SepLogFoldEx.
Require Import MirrorCharge.SynSepLog.

Set Implicit Arguments.
Set Strict Implicit.

(** TODO: These should really be moved to Charge! **)
Section lemmas.
  Variable P : Type.
  Variable ILogicOps_P : ILogicOps P.
  Variable ILogic_P : ILogic P.
  Variable BILOperators_P : BILOperators P.
  Variable BILogic_P : BILogic P.
  Variable PureOp_P : @PureOp P.
  Variable Pure_P : Pure PureOp_P.

  Lemma ltrue_sep : pure ltrue -> ltrue ** ltrue -|- ltrue.
  Proof.
    constructor.
    { apply ltrueR. }
    { rewrite <- pureandsc by eauto with typeclass_instances.
      apply landR; reflexivity. }
  Qed.

  Lemma pure_star_and_true
  : forall a b,
      Pure.pure a ->
      a ** b -|- a //\\ b ** ltrue.
  Proof.
    intros.
    rewrite <- (landtrueR a) at 1.
    rewrite pureandscD by eauto with typeclass_instances.
    rewrite sepSPC. reflexivity.
  Qed.

  Lemma lequiv_sep_cancel : forall a b c,
                              a -|- b -> a ** c -|- b ** c.
  Proof.
    split; apply bilsep; eapply H.
  Qed.

  Lemma land_cancel : forall a b c, b -|- c -> a //\\ b -|- a //\\ c.
  Proof.
    intros. rewrite H. reflexivity.
  Qed.
End lemmas.

Section conjunctives.
  Variable typ : Type.
  Variable RType_typ : RType typ.
  Variable Typ2_Fun : Typ2 _ Fun.
  Variable sym : Type.
  Variable RSym_sym : RSym sym.

  Let Expr_expr : Expr _ (expr typ sym) := Expr_expr.
  Local Existing Instance Expr_expr.

  Record conjunctives : Type :=
  { exs : list typ
  ; spatial : list (expr typ sym * list (expr typ sym))
  ; star_true : bool
  ; pure : list (expr typ sym)
  }.

  Definition mkEmpty : option conjunctives :=
    Some
  {| exs := nil
   ; spatial := nil
   ; star_true := false
   ; pure := nil
   |}.

  Definition mkPure e : option conjunctives :=
    Some
  {| exs := nil
   ; spatial := nil
   ; star_true := true
   ; pure := e :: nil
   |}.

  Definition mkSpatial e es : option conjunctives :=
    Some
  {| exs := nil
   ; spatial := (e,es) :: nil
   ; star_true := false
   ; pure := nil
   |}.

  Require Import MirrorCore.Lambda.ExprLift.

  Definition mkStar (l r : conjunctives) : option conjunctives :=
    let ll := length l.(exs) in
    let lr := length r.(exs) in
    Some
    {| exs := l.(exs) ++ r.(exs)
     ; spatial := l.(spatial) ++ map (fun e_es =>
                                        let '(e,es) := e_es in
                                        (lift 0 ll e,
                                         map (lift 0 ll) es)) r.(spatial)
     ; star_true := orb l.(star_true) r.(star_true)
     ; pure := l.(pure) ++ map (lift 0 ll) r.(pure)
     |}.

  Definition mkEx (t : typ) (l : conjunctives) : option conjunctives :=
    Some
  {| exs := l.(exs) ++ t :: nil
   ; spatial := l.(spatial)
   ; star_true := l.(star_true)
   ; pure := l.(pure)
   |}.

  Definition mkAnd (l r : conjunctives) : option conjunctives :=
    let ll := length l.(exs) in
    let lr := length r.(exs) in
    match l.(spatial) with
      | nil =>
        Some
          {| exs := l.(exs) ++ r.(exs)
           ; spatial := map (fun e_es =>
                               let '(e,es) := e_es in
                               (lift 0 ll e,
                                map (lift 0 ll) es)) r.(spatial)
           ; star_true := r.(star_true)
           ; pure := l.(pure) ++ map (lift 0 ll) r.(pure)
          |}
      | _ => match r.(spatial) with
               | nil =>
                 Some
                   {| exs := l.(exs) ++ r.(exs)
                    ; spatial := l.(spatial)
                    ; star_true := l.(star_true)
                    ; pure := l.(pure) ++ map (lift 0 ll) r.(pure)
                   |}
               | _ => None
             end
    end.

  Variable as_ex : expr typ sym -> option typ.

  Definition SepLogArgs_normalize : SepLogArgs typ sym (option conjunctives) :=
  {| do_emp := mkEmpty
   ; do_star := fun l r =>
                  match l , r with
                    | Some l , Some r => mkStar l r
                    | _ , _ => None
                  end
   ; do_and := fun l r =>
                 match l , r with
                    | Some l , Some r => mkAnd l r
                    | _ , _ => None
                  end
   ; do_other := fun f xs => mkSpatial f (List.map fst xs)
   ; do_ex := fun t e => match e with
                           | Some e => mkEx t e
                           | None => None
                         end
   ; do_pure := mkPure
   |}.

  Variable SL : typ.

  Section conjunctivesD.
    Variable ILO : ILogicOps (typD SL).
    Variable BILO : BILOperators (typD SL).
    Variable IL : @ILogic _ ILO.
    Variable BIL : @BILogic _ ILO BILO.

    Definition well_formed (PO : PureOp)
               (c : conjunctives) (us vs : env) : Prop :=
      List.Forall (fun e =>
                     exists val, exprD us vs e SL  = Some val
                              /\ @Pure.pure _ PO val) c.(pure).

    Variable SSL : SynSepLog typ sym.
    Variable SSLO : @SynSepLogOk typ _ _ sym _ SL _ _ SSL.

    Definition conjunctives_to_expr (c : conjunctives) : expr typ sym :=
      let spa := iterated_base SSL.(e_emp) SSL.(e_star) (map (fun x => apps (fst x) (snd x)) c.(spatial)) in
      let pur := iterated_base SSL.(e_true) SSL.(e_and) c.(pure) in
      SSL.(e_and) pur (SSL.(e_star) spa (if c.(star_true) then SSL.(e_true) else SSL.(e_emp))).

    Definition conjunctives_to_expr_star (c : conjunctives) : expr typ sym :=
      let spa := iterated_base SSL.(e_emp) SSL.(e_star) (map (fun x => apps (fst x) (snd x)) c.(spatial)) in
      let pur := iterated_base SSL.(e_emp) SSL.(e_star) (map (SSL.(e_and) SSL.(e_emp)) c.(pure)) in
      SSL.(e_star) pur (SSL.(e_star) spa (if c.(star_true) then SSL.(e_true) else SSL.(e_emp))).

    Section with_pure.

    Variable PureOp_it : @PureOp (typD SL).
    Variable Pure_it : @Pure _ _ _ PureOp_it.
    Hypothesis pure_ltrue : Pure.pure ltrue.
    Hypothesis pure_land : forall p q, Pure.pure p -> Pure.pure q -> Pure.pure (land p q).

    Lemma iterated_base_true_and_pure
    : forall us vs ps x1,
        exprD us vs (iterated_base (e_true SSL) (e_and SSL) ps) SL = Some x1 ->
        List.Forall
          (fun e : expr typ sym =>
             exists val : typD SL,
               exprD us vs e SL = Some val /\ Pure.pure val) ps -> Pure.pure x1.
    Proof.
(*
      intros.
      generalize dependent x1.
      induction H0; simpl.
      { unfold iterated_base. simpl. intros.
        destruct (exprD_e_trueOk SSLO us vs) as [ ? [ ? ? ] ].
        go_crazy SSL SSLO.
        inv_all; subst.
        eapply pure_proper; eauto. }
      { intros.
        generalize (@iterated_base_cons _ SSL.(e_true) SSL.(e_and)
                      (Sem_equiv _ SL lequiv us vs)
                      (@Reflexive_Sem_equiv _ _ _ _ SL lequiv _ us vs)
                      (@Transitive_Sem_equiv _ _ _ _ SL lequiv _ us vs)
                      (@Sem_equiv_e_and_assoc _ _ _ SL _ _ _ SSL SSLO us vs)
                      (@Sem_equiv_Proper_e_and _ _ _ SL _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_true_e_and_unitLL _ _ _ SL _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_true_e_and_unitLR _ _ _ SL _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_true_e_and_unitRL _ _ _ SL _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_true_e_and_unitRR _ _ _ SL _ _ _ _ SSLO us vs)
                      x l).
        unfold Sem_equiv. rewrite H1.
        intros; forward.
        repeat go_crazy SSL SSLO.
        destruct H as [ ? [ ? ? ] ].
        inv_all; subst.
        specialize (IHForall _ eq_refl).
        eapply pure_proper. rewrite H5 in H3. apply H3.
        eapply pure_land; eauto. }
    Qed.
*)
    Admitted.

(*
    Lemma iterated_base_true_and_star_emp'
    : forall tus tvs ps,
        match
            exprD' tus tvs (iterated_base SSL.(e_true) SSL.(e_and) ps) SL
          , exprD' tus tvs (iterated_base SSL.(e_emp) SSL.(e_star) (map (SSL.(e_and) SSL.(e_emp)) ps)) SL
        with
          | Some x , Some x' =>
            forall Q us vs,
              List.Forall
                (fun e : expr sym =>
                   exists val : typD nil SL,
                        exprD (join_env us) (join_env vs) e SL = Some val
                     /\ Pure.pure val)
                ps ->
              (x us vs //\\ Q -|- x' us vs ** Q)
          | None , None => True
          | _ , _ => False
        end.
    Proof.
      induction ps; simpl; intros.
      { unfold iterated_base in *; simpl in *.
        destruct (SSLO.(e_empOk) tus tvs) as [ ? [ ? ? ] ].
        destruct (e_trueOk SSLO tus tvs) as [ ? [ ? ? ] ].
        Cases.rewrite_all_goal; intros.
        rewrite H0. rewrite H2.
        rewrite empSPL. rewrite ltrue_unitL; eauto. }
      { (*
generalize (@iterated_base_cons _ SSL.(e_true) SSL.(e_and)
                      (Sem_equiv' _ SL lequiv us vs)
                      (@Reflexive_Sem_equiv' _ _ _ SL lequiv _ us tvs)
                      (@Transitive_Sem_equiv' _ _ _ SL lequiv _ us tvs)
                      (@Sem_equiv'_e_and_assoc _ _ _ SL _ _ _ SSL SSLO us tvs)
                      (@Sem_equiv'_Proper_e_and _ _ _ SL _ _ _ _ SSLO us tvs)
                      (@Sem_equiv'_e_true_e_and_unitLL _ _ _ SL _ _ _ _ SSLO us tvs)
                      (@Sem_equiv'_e_true_e_and_unitLR _ _ _ SL _ _ _ _ SSLO us tvs)
                      (@Sem_equiv'_e_true_e_and_unitRL _ _ _ SL _ _ _ _ SSLO us tvs)
                      (@Sem_equiv'_e_true_e_and_unitRR _ _ _ SL _ _ _ _ SSLO us tvs)
                   a ps).
        generalize (@iterated_base_cons _ SSL.(e_emp) SSL.(e_star)
                      (Sem_equiv _ SL lequiv us vs)
                      (@Reflexive_Sem_equiv _ _ _ SL lequiv _ us vs)
                      (@Transitive_Sem_equiv _ _ _ SL lequiv _ us vs)
                      (@Sem_equiv_e_star_assoc _ _ _ SL _ _ _ _ SSL SSLO us vs)
                      (@Sem_equiv_Proper_e_star _ _ _ SL _ _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_emp_e_star_unitLL _ _ _ SL _ _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_emp_e_star_unitLR _ _ _ SL _ _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_emp_e_star_unitRL _ _ _ SL _ _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_emp_e_star_unitRR _ _ _ SL _ _ _ _ _ SSLO us vs)
                   (e_and SSL (e_emp SSL) a) (map (e_and SSL (e_emp SSL)) ps)).
        unfold Sem_equiv.
        intros.
        repeat match goal with
                 | |- match ?X with _ => _ end =>
                   consider X; intros
               end; forward; repeat go_crazy SSL SSLO.
        { inv_all; subst.
          rewrite H5; clear H5.
          rewrite H4; clear H4.
          rewrite H9; clear H9.
          rewrite H7; clear H7.
          rewrite H11; clear H11.
          inversion H3; subst.
          specialize (IHps Q H7).
          destruct (exprD_e_empOk SSLO us vs) as [ ? [ ? ? ] ].
          rewrite H1 in *. inv_all; subst.
          rewrite H4.
          destruct H5. rewrite H10 in *. destruct H2.
          inv_all; subst.
          rewrite (landC empSP).
          rewrite sepSPA.
          rewrite pureandscD by eauto with typeclass_instances.
          rewrite empSPL.
          rewrite landA. rewrite IHps. reflexivity.
        { destruct (exprD_e_empOk SSLO us vs) as [ ? [ ? ? ] ].
          congruence. } }
*) admit. }
    Qed.

    Lemma iterated_base_true_and_star_emp
    : forall us vs ps,
        match
            exprD us vs (iterated_base SSL.(e_true) SSL.(e_and) ps) SL
          , exprD us vs (iterated_base SSL.(e_emp) SSL.(e_star) (map (SSL.(e_and) SSL.(e_emp)) ps)) SL
        with
          | Some x , Some x' =>
            forall Q,
              List.Forall
                (fun e : expr sym =>
                   exists val : typD ts nil SL, exprD us vs e SL = Some val /\ Pure.pure val)
                ps ->
              x //\\ Q -|- x' ** Q
          | None , None => True
          | _ , _ => False
        end.
    Proof.
      induction ps; simpl; intros.
      { unfold iterated_base in *; simpl in *.
        destruct (exprD_e_empOk SSLO us vs) as [ ? [ ? ? ] ].
        destruct (exprD_e_trueOk SSLO us vs) as [ ? [ ? ? ] ].
        Cases.rewrite_all_goal; intros.
        rewrite H0. rewrite H2.
        rewrite empSPL. rewrite ltrue_unitL; eauto. }
      { generalize (@iterated_base_cons _ SSL.(e_true) SSL.(e_and)
                      (Sem_equiv _ SL lequiv us vs)
                      (@Reflexive_Sem_equiv _ _ _ _ SL lequiv _ us vs)
                      (@Transitive_Sem_equiv _ _ _ _ SL lequiv _ us vs)
                      (@Sem_equiv_e_and_assoc _ _ _ SL _ _ _ SSL SSLO us vs)
                      (@Sem_equiv_Proper_e_and _ _ _ SL _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_true_e_and_unitLL _ _ _ SL _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_true_e_and_unitLR _ _ _ SL _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_true_e_and_unitRL _ _ _ SL _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_true_e_and_unitRR _ _ _ SL _ _ _ _ SSLO us vs)
                   a ps).
        generalize (@iterated_base_cons _ SSL.(e_emp) SSL.(e_star)
                      (Sem_equiv _ SL lequiv us vs)
                      (@Reflexive_Sem_equiv _ _ _ _ SL lequiv _ us vs)
                      (@Transitive_Sem_equiv _ _ _ _ SL lequiv _ us vs)
                      (@Sem_equiv_e_star_assoc _ _ _ SL _ _ _ _ SSL SSLO us vs)
                      (@Sem_equiv_Proper_e_star _ _ _ SL _ _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_emp_e_star_unitLL _ _ _ SL _ _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_emp_e_star_unitLR _ _ _ SL _ _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_emp_e_star_unitRL _ _ _ SL _ _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_emp_e_star_unitRR _ _ _ SL _ _ _ _ _ SSLO us vs)
                   (e_and SSL (e_emp SSL) a) (map (e_and SSL (e_emp SSL)) ps)).
        unfold Sem_equiv.
        intros.
        repeat match goal with
                 | |- match ?X with _ => _ end =>
                   consider X; intros
               end; forward; repeat go_crazy SSL SSLO.
        { inv_all; subst.
          rewrite H5; clear H5.
          rewrite H4; clear H4.
          rewrite H9; clear H9.
          rewrite H7; clear H7.
          rewrite H11; clear H11.
          inversion H3; subst.
          specialize (IHps Q H7).
          destruct (exprD_e_empOk SSLO us vs) as [ ? [ ? ? ] ].
          rewrite H1 in *. inv_all; subst.
          rewrite H4.
          destruct H5. rewrite H10 in *. destruct H2.
          inv_all; subst.
          rewrite (landC empSP).
          rewrite sepSPA.
          rewrite pureandscD by eauto with typeclass_instances.
          rewrite empSPL.
          rewrite landA. rewrite IHps. reflexivity. }
        { destruct (exprD_e_empOk SSLO us vs) as [ ? [ ? ? ] ].
          congruence. } }
    Qed.
*)

(*
    Lemma iterated_base_true_and_star_emp
    : forall us vs ps x,
        exprD us vs (iterated_base SSL.(e_true) SSL.(e_and) ps) SL = Some x ->
        exists x',
          exprD us vs (iterated_base SSL.(e_emp) SSL.(e_star) (map (SSL.(e_and) SSL.(e_emp)) ps)) SL = Some x' /\
          forall Q,
            List.Forall
              (fun e : expr sym =>
                 exists val : typD ts nil SL, exprD us vs e SL = Some val /\ Pure.pure val)
              ps ->
            x //\\ Q -|- x' ** Q.
    Proof.

      induction ps; simpl; intros.
      { unfold iterated_base in *; simpl in *.
        destruct (exprD_e_empOk SSLO us vs) as [ ? [ ? ? ] ].
        destruct (exprD_e_trueOk SSLO us vs) as [ ? [ ? ? ] ].
        eexists; split; eauto. intros.
        rewrite H1. rewrite H in *. inv_all; subst.
        rewrite H3. rewrite empSPL. rewrite ltrue_unitL; eauto. }
      { generalize (@iterated_base_cons _ SSL.(e_true) SSL.(e_and)
                      (Sem_equiv _ SL lequiv us vs)
                      (@Reflexive_Sem_equiv _ _ _ SL lequiv _ us vs)
                      (@Transitive_Sem_equiv _ _ _ SL lequiv _ us vs)
                      (@Sem_equiv_e_and_assoc _ _ _ SL _ _ _ SSL SSLO us vs)
                      (@Sem_equiv_Proper_e_and _ _ _ SL _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_true_e_and_unitLL _ _ _ SL _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_true_e_and_unitLR _ _ _ SL _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_true_e_and_unitRL _ _ _ SL _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_true_e_and_unitRR _ _ _ SL _ _ _ _ SSLO us vs)
                   a ps).
        generalize (@iterated_base_cons _ SSL.(e_emp) SSL.(e_star)
                      (Sem_equiv _ SL lequiv us vs)
                      (@Reflexive_Sem_equiv _ _ _ SL lequiv _ us vs)
                      (@Transitive_Sem_equiv _ _ _ SL lequiv _ us vs)
                      (@Sem_equiv_e_star_assoc _ _ _ SL _ _ _ _ SSL SSLO us vs)
                      (@Sem_equiv_Proper_e_star _ _ _ SL _ _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_emp_e_star_unitLL _ _ _ SL _ _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_emp_e_star_unitLR _ _ _ SL _ _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_emp_e_star_unitRL _ _ _ SL _ _ _ _ _ SSLO us vs)
                      (@Sem_equiv_e_emp_e_star_unitRR _ _ _ SL _ _ _ _ _ SSLO us vs)
                   (e_and SSL (e_emp SSL) a) (map (e_and SSL (e_emp SSL)) ps)).
        unfold Sem_equiv.
        rewrite H. intros; forward.
        go_crazy SSL SSLO.
        generalize (iterated_base_true_and_pure _ _ H3); intro.
        eapply IHps in H3; clear IHps H.
        destruct H3 as [ ? [ ? ? ] ].
        consider (exprD us vs
               (e_star SSL (e_and SSL (e_emp SSL) a)
                  (iterated_base (e_emp SSL) (e_star SSL)
                     (map (e_and SSL (e_emp SSL)) ps))) SL).
        { intros.
          forward. eexists; split; eauto.
          intros. specialize (H3 Q).
          inversion H8. subst.
          destruct (exprD_e_empOk SSLO us vs) as [ ? [ ? ? ] ].
          repeat go_crazy SSL SSLO.
          inv_all; subst.
          specialize (H5 H12).
          destruct H11 as [ ? [ ? ? ] ]; inv_all; subst.
          specialize (H3 H12); clear H6 H12.
          subst.
          rewrite H2. rewrite H4. rewrite H7. rewrite H14. rewrite H16. rewrite H10.
          rewrite (landC empSP).
          rewrite sepSPA.
          rewrite pureandscD by eauto with typeclass_instances.
          rewrite empSPL.
          rewrite landA. rewrite H3. reflexivity. }
        { intros. forward.
          exfalso. repeat go_crazy SSL SSLO.
          destruct (exprD_e_empOk SSLO us vs) as [ ? [ ? ? ] ].
          congruence. } }
    Qed.

    Theorem conjunctives_to_expr_conjunctives_to_expr_star
    : forall tvs us c cE,
        exprD' us tvs (conjunctives_to_expr c) SL = Some cE ->
        exists cE',
          exprD' us tvs (conjunctives_to_expr_star c) SL = Some cE' /\
          forall (vs : hlist (typD ts nil) tvs),
            well_formed _ c us (join_env vs) ->
            cE vs -|- cE' vs.
    Proof.
      intros.
      consider (exprD' us tvs (conjunctives_to_expr_star c) SL); intros.
      { eexists; split; eauto; intros.
        destruct c.
        unfold well_formed, conjunctives_to_expr, conjunctives_to_expr_star in *.
        simpl in *.
        generalize dependent (e_star SSL
               (iterated_base (e_emp SSL) (e_star SSL)
                  (map
                     (fun x : expr sym * list (expr sym) =>
                      apps (fst x) (snd x)) spatial0))
               (if star_true0 then e_true SSL else e_emp SSL)).
        intros.
        repeat go_crazy SSL SSLO.
        generalize (@iterated_base_true_and_star_emp us (join_env vs) pure0).
        unfold exprD. rewrite split_env_join_env.
        rewrite H.
        intro. specialize (H6 _ eq_refl).
        destruct H6. destruct H6.
        forward. inv_all; subst.
        rewrite H3; clear H3.
        rewrite H5; clear H5.
        eapply H7; eauto.
        clear - H1.
        unfold exprD in H1.
        rewrite split_env_join_env in H1. assumption. }
      { exfalso.
        destruct c.
        unfold well_formed, conjunctives_to_expr, conjunctives_to_expr_star in *.
        simpl in *.
        generalize dependent (e_star SSL
               (iterated_base (e_emp SSL) (e_star SSL)
                  (map
                     (fun x : expr sym * list (expr sym) =>
                      apps (fst x) (snd x)) spatial0))
               (if star_true0 then e_true SSL else e_emp SSL)).
        intros.
        repeat go_crazy SSL SSLO.
        clear H2.
        generalize dependent x.
        generalize dependent pure0.
        induction pure0; intros.
        { unfold iterated_base in *. simpl in *.
          destruct (SSLO.(e_empOk) us tvs) as [ ? [ ? ? ] ].
          congruence. }
        { unfold iterated_base in *.
          simpl in *.
          consider ( iterated (e_and SSL) pure0); intros.
          { consider (iterated (e_star SSL) (map (e_and SSL (e_emp SSL)) pure0)); intros.
            { repeat go_crazy SSL SSLO.
              destruct (SSLO.(e_empOk) us tvs) as [ ? [ ? ? ] ].
              congruence.
              eapply IHpure0; reflexivity. }
            { repeat go_crazy SSL SSLO.
              destruct (SSLO.(e_empOk) us tvs) as [ ? [ ? ? ] ].
              congruence. } }
          { consider (iterated (e_star SSL) (map (e_and SSL (e_emp SSL)) pure0)); intros.
            { repeat go_crazy SSL SSLO.
              destruct (SSLO.(e_empOk) us tvs) as [ ? [ ? ? ] ].
              congruence.
              destruct (SSLO.(e_trueOk) us tvs) as [ ? [ ? ? ] ].
              eapply H4; eauto. }
            { repeat go_crazy SSL SSLO.
              destruct (SSLO.(e_empOk) us tvs) as [ ? [ ? ? ] ].
              congruence. } } } }
    Qed.
*)

    Theorem conjunctives_to_expr_conjunctives_to_expr_star_iff
    : forall tvs tus c,
        match
            exprD' tus tvs SL (conjunctives_to_expr c)
          , exprD' tus tvs SL (conjunctives_to_expr_star c)
        with
          | Some cE , Some cE' =>
            forall us (vs : hlist typD tvs),
            well_formed _ c (join_env us) (join_env vs) ->
            cE us vs -|- cE' us vs
          | None , None => True
          | _ , _ => False
        end.
    Proof.
(*
      intros.
      unfold conjunctives_to_expr, conjunctives_to_expr_star.
      generalize (e_star SSL
                 (iterated_base (e_emp SSL) (e_star SSL)
                    (map
                       (fun x : expr sym * list (expr sym) =>
                        apps (fst x) (snd x)) (spatial c)))
                 (if star_true c then e_true SSL else e_emp SSL)); intros.
(*
      consider (exprD' us tvs (conjunctives_to_expr_star c) SL); intros; forward.
      { consider (exprD' us tvs (conjunctives_to_expr c) SL); intros.
        { admit. }
        { unfold conjunctives_to_expr, conjunctives_to_expr_star in *.
          generalize dependent ((e_star SSL
              (iterated_base (e_emp SSL) (e_star SSL)
                 (map
                    (fun x : expr sym * list (expr sym) =>
                     apps (fst x) (snd x)) (spatial c)))
              (if star_true c then e_true SSL else e_emp SSL))).
          intros.
          repeat go_crazy SSL SSLO.
          destruct c; simpl in *.
          clear - H H0.
          generalize dependent x.

      { eexists; split; eauto; intros.
        destruct c.
        unfold well_formed, conjunctives_to_expr, conjunctives_to_expr_star in *.
        simpl in *.
        generalize dependent (e_star SSL
               (iterated_base (e_emp SSL) (e_star SSL)
                  (map
                     (fun x : expr sym * list (expr sym) =>
                      apps (fst x) (snd x)) spatial0))
               (if star_true0 then e_true SSL else e_emp SSL)).
        intros.
        repeat go_crazy SSL SSLO.
        generalize (@iterated_base_true_and_star_emp us (join_env vs) pure0).
        unfold exprD. rewrite split_env_join_env.
        rewrite H.
        intro. specialize (H6 _ eq_refl).
        destruct H6. destruct H6.
        forward. inv_all; subst.
        rewrite H3; clear H3.
        rewrite H5; clear H5.
        eapply H7; eauto.
        clear - H1.
        unfold exprD in H1.
        rewrite split_env_join_env in H1. assumption. }
      { exfalso.
        destruct c.
        unfold well_formed, conjunctives_to_expr, conjunctives_to_expr_star in *.
        simpl in *.
        generalize dependent (e_star SSL
               (iterated_base (e_emp SSL) (e_star SSL)
                  (map
                     (fun x : expr sym * list (expr sym) =>
                      apps (fst x) (snd x)) spatial0))
               (if star_true0 then e_true SSL else e_emp SSL)).
        intros.
        repeat go_crazy SSL SSLO.
        clear H2.
        generalize dependent x.
        generalize dependent pure0.
        induction pure0; intros.
        { unfold iterated_base in *. simpl in *.
          destruct (SSLO.(e_empOk) us tvs) as [ ? [ ? ? ] ].
          congruence. }
        { unfold iterated_base in *.
          simpl in *.
          consider ( iterated (e_and SSL) pure0); intros.
          { consider (iterated (e_star SSL) (map (e_and SSL (e_emp SSL)) pure0)); intros.
            { repeat go_crazy SSL SSLO.
              destruct (SSLO.(e_empOk) us tvs) as [ ? [ ? ? ] ].
              congruence.
              eapply IHpure0; reflexivity. }
            { repeat go_crazy SSL SSLO.
              destruct (SSLO.(e_empOk) us tvs) as [ ? [ ? ? ] ].
              congruence. } }
          { consider (iterated (e_star SSL) (map (e_and SSL (e_emp SSL)) pure0)); intros.
            { repeat go_crazy SSL SSLO.
              destruct (SSLO.(e_empOk) us tvs) as [ ? [ ? ? ] ].
              congruence.
              destruct (SSLO.(e_trueOk) us tvs) as [ ? [ ? ? ] ].
              eapply H4; eauto. }
            { repeat go_crazy SSL SSLO.
              destruct (SSLO.(e_empOk) us tvs) as [ ? [ ? ? ] ].
              congruence. } } } }
*)
*)
    Admitted.

(*
    Definition conjunctives_to_expr (c : conjunctives) : expr sym :=
      let ps := iterated e_and c.(pure) in
      let sp := iterated e_star (map (fun x => apps (fst x) (snd x)) c.(spatial)) in
      match ps , sp with
        | None , None => if c.(star_true) then e_true else e_emp
        | None , Some sp => if c.(star_true) then e_star sp e_true else sp
        | Some p , None => if c.(star_true) then p else e_and p e_emp
        | Some p , Some sp =>
          e_and p (if c.(star_true) then
                     e_star sp e_true
                   else
                     sp)
      end.
*)

(*
    Definition R_conjunctives
               (e : expr typ sym) (c : conjunctives) (tus tvs : tenv typ) : Prop :=
      forall val,
        exprD' (ts := ts) tus tvs e SL = Some val ->
        exists val',
             exprD' tus tvs (conjunctives_to_expr c) SL = Some val'
          /\ (forall us vs,
                (val us vs -|- val' us vs) /\ well_formed _ c (join_env us) (join_env vs)).

    Ltac forward_ex_and :=
      repeat match goal with
               | H : exists x, _ |- _ => destruct H
               | H : _ /\ _ |- _ => destruct H
             end.

    Local Instance Reflexive_lentails : Reflexive lentails.
    Proof.
      destruct IL. destruct lentailsPre. auto.
    Qed.

    Lemma something_smart
    : forall a b c d,
        Pure.pure a -> Pure.pure b ->
        (a //\\ b) //\\ c ** d -|- (a //\\ c) ** b //\\ d.
    Proof.
      clear - BIL IL Pure_it. intros.
      symmetry.
      rewrite pureandscD by eauto with typeclass_instances.
      rewrite sepSPC.
      rewrite pureandscD by eauto with typeclass_instances.
      rewrite <- landA.
      rewrite sepSPC. reflexivity.
    Qed.

    Lemma well_formed_pure
    : forall x us vs,
        well_formed _ x us vs ->
        forall x7,
          exprD us vs (iterated_base SSL.(e_true) SSL.(e_and) (pure x)) SL = Some x7 ->
          Pure.pure x7.
    Proof.
      unfold well_formed. destruct x; simpl.
      induction 1; simpl; intros.
(*
      { unfold iterated_base in H. simpl in *.
        destruct (SSLO.(e_trueOk) us tvs).
        rewrite H in *. destruct H0.
        inv_all; subst. eapply Pure.pure_proper. eapply H1.
        eapply pure_ltrue; eauto with typeclass_instances. }
      { unfold iterated_base in *. simpl in *.
        destruct (iterated SSL.(e_and) l); intros.
        { go_crazy SSL SSLO.
          eapply Pure.pure_proper. eapply H3.
          destruct H. destruct H.
          eapply pure_land; eauto with typeclass_instances.
          unfold exprD in *. rewrite split_env_join_env in *.
          rewrite H1 in *. inv_all. rewrite H. auto. }
        { destruct H. destruct H.
          unfold exprD in H. rewrite split_env_join_env in *.
          rewrite H1 in *. inv_all; subst.
          auto. } }
    Qed. *)
    Admitted.

    Lemma Forall_app
    : forall T (P : T -> Prop) xs ys,
        List.Forall P (xs ++ ys) <-> (List.Forall P xs /\ List.Forall P ys).
    Proof.
      clear. induction xs; simpl; intros.
      { intuition. }
      { split; intros.
        { inversion H; subst. rewrite IHxs in H3. intuition. }
        { intuition. inversion H0; subst. constructor; eauto. eapply IHxs. auto. } }
    Qed.

    Lemma something_smart'
    : forall a b c d e f g,
        Pure.pure a -> Pure.pure b ->
        e -|- f ** g ->
        (a //\\ b) //\\ (c ** d) ** e -|-
                   (a //\\ c ** f) ** b //\\ d ** g.
    Proof.
      clear - BIL pure_land pure_ltrue. intros. rewrite H1. clear H1.
      transitivity ((a //\\ b) //\\ (c ** f) ** d ** g).
      { apply land_cancel; eauto with typeclass_instances.
        repeat rewrite sepSPA.
        rewrite (sepSPC c).
        rewrite (sepSPC c).
        apply lequiv_sep_cancel; eauto with typeclass_instances.
        repeat rewrite <- sepSPA.
        rewrite (sepSPC d f). reflexivity. }
      { rewrite something_smart by eauto. reflexivity. }
    Qed.

    Lemma cte_mkStar
    : forall tus tvs r_res l_res rval lval,
        exprD' tus tvs (conjunctives_to_expr r_res) SL = Some rval ->
        exprD' tus tvs (conjunctives_to_expr l_res) SL = Some lval ->
        exists val,
          exprD' tus tvs (conjunctives_to_expr (mkStar l_res r_res)) SL = Some val /\
          forall us vs,
            well_formed _ l_res (join_env us) (join_env vs) ->
            well_formed _ r_res (join_env us) (join_env vs) ->
            (val us vs -|- lval us vs ** rval us vs) /\
            well_formed _ (mkStar l_res r_res) (join_env us) (join_env vs).
    Proof.
(*
      intros.
      consider (exprD' us tvs (conjunctives_to_expr (mkStar l_res r_res)) SL);
        intros; unfold conjunctives_to_expr, mkStar in *; simpl in *.
      { eexists; split; eauto. intros.
        split.
        { destruct (SSLO.(e_empOk) us tvs).
          destruct (SSLO.(e_trueOk) us tvs).
          rewrite map_app in *.
          forward_ex_and.
          generalize (@iterated_base_app _ SSL.(e_true) SSL.(e_and)
                        (Sem_equiv _ SL lequiv us (join_env vs))
                 (@Reflexive_Sem_equiv _ _ _ SL lequiv _ us (join_env vs))
                 (@Transitive_Sem_equiv _ _ _ SL lequiv _ us (join_env vs))
                 (Sem_equiv_e_and_assoc _ SSLO) Sem_equiv_Proper_e_and
                 Sem_equiv_e_true_e_and_unitLL
                 Sem_equiv_e_true_e_and_unitLR
                 Sem_equiv_e_true_e_and_unitRL
                 Sem_equiv_e_true_e_and_unitRR r_res.(pure) l_res.(pure) us tvs).
          generalize (@iterated_base_app _ e_emp e_star (Sem_equiv _ SL lequiv)
                (@Reflexive_Sem_equiv _ _ _ SL lequiv _)
                (@Transitive_Sem_equiv _ _ _ SL lequiv _)
                Sem_equiv_e_star_assoc Sem_equiv_Proper_e_star
                Sem_equiv_e_emp_e_star_unitLL
                Sem_equiv_e_emp_e_star_unitLR
                Sem_equiv_e_emp_e_star_unitRL
                Sem_equiv_e_emp_e_star_unitRR
                (map (fun x : expr sym * list (expr sym) => apps (fst x) (snd x)) r_res.(spatial))
                (map (fun x : expr sym * list (expr sym) => apps (fst x) (snd x)) l_res.(spatial))
                us tvs).
          repeat go_crazy.
          intros; forward.
          inv_all; subst.
          repeat match goal with
                   | H : forall x, _ -|- _ |- _ => rewrite H
                 end.
          assert (Pure.pure (x8 vs)).
          { eapply well_formed_pure; [ | eauto ]; eauto. }
          assert (Pure.pure (x9 vs)).
          { eapply well_formed_pure; [ | eauto ]; eauto. }
          destruct l_res.(star_true); destruct r_res.(star_true);
          intros; simpl in *; repeat go_crazy; inv_all; subst;
          repeat match goal with
                   | H : forall x, _ -|- _ |- _ => rewrite H
                 end; eapply something_smart'; auto.
          { rewrite ltrue_sep. reflexivity. }
          { rewrite empSPR. reflexivity. }
          { rewrite empSPL. reflexivity. }
          { rewrite empSPL. reflexivity. } }
        { red. simpl.
          apply Forall_app. split; assumption. } }
      { exfalso.
        generalize (@iterated_base_app _ e_true e_and (Sem_equiv _ SL lequiv)
                                     (@Reflexive_Sem_equiv _ _ _ SL lequiv _)
                                     (@Transitive_Sem_equiv _ _ _ SL lequiv _)
                                     Sem_equiv_e_and_assoc Sem_equiv_Proper_e_and
                 Sem_equiv_e_true_e_and_unitLL
                 Sem_equiv_e_true_e_and_unitLR
                 Sem_equiv_e_true_e_and_unitRL
                 Sem_equiv_e_true_e_and_unitRR r_res.(pure) l_res.(pure) us tvs).
        generalize (@iterated_base_app _ e_emp e_star (Sem_equiv _ SL lequiv)
           (@Reflexive_Sem_equiv _ _ _ SL lequiv _)
           (@Transitive_Sem_equiv _ _ _ SL lequiv _)
           Sem_equiv_e_star_assoc Sem_equiv_Proper_e_star
           Sem_equiv_e_emp_e_star_unitLL
           Sem_equiv_e_emp_e_star_unitLR
           Sem_equiv_e_emp_e_star_unitRL
           Sem_equiv_e_emp_e_star_unitRR
           (map (fun x : expr sym * list (expr sym) => apps (fst x) (snd x)) r_res.(spatial))
           (map (fun x : expr sym * list (expr sym) => apps (fst x) (snd x)) l_res.(spatial))
           us tvs).
        rewrite map_app in *.
        repeat go_crazy.
        inv_all; subst. intros; forward.
        destruct l_res.(star_true); destruct r_res.(star_true); simpl in *;
        repeat go_crazy; congruence. }
    Qed.
*) Admitted.
*)
    End with_pure.
(*
    Variable SLS : SepLogSpec sym.
    Variable slsok : SepLogSpecOk RSym_sym SL SLS ILO BILO.

(*
    Theorem SepLogArgsOk_conjunctives
    : SepLogArgsOk RSym_sym SL SepLogArgs_normalize SLS R_conjunctives.
    Proof.
      constructor; unfold R_conjunctives; simpl; intros.
      { unfold mkSpatial, conjunctives_to_expr. simpl.
        unfold iterated_base. simpl.
        consider (exprD' (join_env us) tvs (SSL.(e_and) SSL.(e_true) (SSL.(e_star) (apps e (map fst es)) SSL.(e_emp))) SL); intros;
        repeat (go_crazy SSL SSLO); inv_all; subst.
        { eexists; split; eauto.
          intros.
          destruct (SSLO.(e_empOk) (join_env us) tvs).
          destruct (SSLO.(e_trueOk) (join_env us) tvs).
          forward_ex_and.
          repeat (go_crazy SSL SSLO).
          inv_all; subst.
          repeat match goal with
                   | H : forall x, _ -|- _ |- _ =>
                     rewrite H
                 end.
          rewrite empSPR; eauto with typeclass_instances.
          rewrite landtrueL. split.
          reflexivity. constructor. }
        { destruct (SSLO.(e_trueOk) (join_env us) tvs) as [ ? [ ? ? ] ]. congruence. }
        { destruct (SSLO.(e_empOk) (join_env us) tvs) as [ ? [ ? ? ] ]. congruence. } }
      { unfold conjunctives_to_expr, mkPure; simpl.
        unfold iterated_base. simpl.
        destruct (SSLO.(e_empOk) (join_env us) tvs).
        destruct (SSLO.(e_trueOk) (join_env us) tvs).
        forward_ex_and.
        consider (exprD' (join_env us) tvs (SSL.(e_and) e (SSL.(e_star) SSL.(e_emp) SSL.(e_true))) SL);
          intros; do 5 (go_crazy SSL SSLO); try congruence.
        { eexists; split; eauto.
          intros. inv_all; subst.
          rewrite H8. rewrite H10. rewrite H4. rewrite H5.
          rewrite empSPL. rewrite landtrueR. split.
          { reflexivity. }
          { red. constructor. 2: constructor.
            unfold exprD. rewrite split_env_join_env. rewrite H1.
            eexists; split; eauto.
            eapply His_pure. eassumption.
            instantiate (1 := join_env vs).
            instantiate (1 := join_env us).
            unfold exprD. rewrite split_env_join_env. rewrite H1. reflexivity. } } }
      { unfold conjunctives_to_expr, mkEmpty; simpl.
        destruct (SSLO.(e_empOk) (join_env us) tvs).
        destruct (SSLO.(e_trueOk) (join_env us) tvs).
        forward_ex_and. unfold iterated_base. simpl.
        consider (exprD' (join_env us) tvs (SSL.(e_and) SSL.(e_true) (SSL.(e_star) SSL.(e_emp) SSL.(e_emp))) SL);
          intros; repeat (go_crazy SSL SSLO); try congruence.
        { eexists; split; eauto.
          inv_all; subst. intros.
          split; try solve [ constructor ].
          eapply His_emp  with (us := join_env us) (vs := join_env vs) in H0; eauto.
          unfold exprD in *. rewrite split_env_join_env in *.
          rewrite H1 in *. inv_all; subst. rewrite H0.
          rewrite H8. rewrite H10. rewrite H4. rewrite H5.
          rewrite empSPL. rewrite landtrueL. reflexivity. } }
      { red_exprD.
        generalize (slsok.(His_star) _ H2 (join_env us)).
        rewrite H in *.
        unfold type_of_apply in *.
        forward.
        inv_all. subst t. subst t4. subst p. subst val.
        red_exprD. rewrite H in H8.
        forward. inv_all.
        subst p t2.
        specialize (H3 _ _ H8).
        subst t0 t1.
        specialize (H4 _ _ H9).
        forward_ex_and.
        specialize (@cte_mkStar (join_env us) tvs _ _ _ _ H4 H3); intros.
        forward_ex_and.
        eexists; split; eauto.
        intros.
        uip_all'.
        specialize (H7 (join_env vs)).
        unfold exprD in *.
        rewrite split_env_join_env in *.
        rewrite H5 in *. inv_all; subst.
        rewrite H7.
        specialize (H10 vs). specialize (H11 vs).
        forward_ex_and.
        specialize (H13 _ H16 H14).
        forward_ex_and. split; auto.
        symmetry. rewrite H11. rewrite H10. auto. }
    Qed.
*)
*)
  End conjunctivesD.

  Definition normalize (sls : SepLogSpec typ sym) (e : expr typ sym) : option conjunctives :=
    StrongFoldApp.wf_app_fold_args (AppFullFoldArgs_SepLogArgs SepLogArgs_normalize sls) e tt.

(*
  Theorem normalizeOk
          (ILO : ILogicOps (typD nil SL))
          (BILO : BILOperators (typD nil SL))
          (IL : @ILogic _ ILO)
          (BIL : @BILogic _ ILO BILO)
          (sls : SepLogSpec _ sym) (slsOk : SepLogSpecOk _ _ _ sls _ _)
          (ssl : SynSepLog _ sym) (sslo : SynSepLogOk _ _ _ _ _ ssl)
  : forall (e : expr typ sym) tus tvs,
      match exprD' nil tus tvs SL e
          , exprD' nil tus tvs SL (conjunctives_to_expr ssl (normalize sls nil tus tvs e))
      with
        | Some l , Some r =>
          forall us vs,
            (l us vs -|- r us vs) /\
            well_formed (slsOk.(_PureOp)) (normalize sls e tus tvs) (join_env us) (join_env vs)
        | None , None => True
        | _ , _ => False
      end.
  Proof.
  Admitted.
*)
End conjunctives.

(*
Module demo.
  Definition is_emp (i : ilfunc) : bool :=
    match i with
      | ilf_true _ => true
      | _ => false
    end.
  Definition is_star (e : ilfunc) : bool :=
    match e with
      | fref 1%positive => true
      | _ => false
    end.

  Definition SepLogSpec_demo : SepLogSpec ilfunc :=
    Build_SepLogSpec (fun _ => false) is_emp is_star.

  Definition inj_emp := Inj (ilf_true (tyType 1)).
  Definition inj_star a b :=
    Eval compute in apps (Inj (fref 1%positive)) (a :: b :: nil).
  Definition inj_and a b :=
    Eval compute in apps (Inj (fref 2%positive)) (a :: b :: nil).

  Definition test := fun x => normalize SepLogSpec_demo x nil nil.
  Eval compute in  test inj_emp.
  Eval compute in  test (inj_star inj_emp inj_emp).
  Eval compute in  test (inj_star (Var 0) (inj_star inj_emp (inj_and (Var 1) (Var 3)))).
End demo.
*)


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl 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 General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export per_props.

Lemma mkc_pertype_equality_in_uni {p} :
  forall lib (R1 R2 : @CTerm p) i,
    equality lib (mkc_pertype R1) (mkc_pertype R2) (mkc_uni i)
    <=> (forall x y, member lib (mkc_apply2 R1 x y) (mkc_uni i))
      # (forall x y, member lib (mkc_apply2 R2 x y) (mkc_uni i))
      # (forall x y,
           inhabited_type lib (mkc_apply2 R1 x y)
           <=>
           inhabited_type lib (mkc_apply2 R2 x y))
      # is_per_type lib R1.
Proof.
  introv; split; intro equ; repnd.

  - unfold equality, nuprl in equ; exrepnd.
    inversion equ1; subst; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    rw h0 in equ0; exrepnd.
    inversion equ2; subst; try not_univ.
    dest_per.
    allfold (@nuprl p); allfold (@nuprli p lib j0).
    computes_to_value_isvalue.

    dands; introv.

    generalize (typ1 x y); intro k.
    unfold member, equality.
    exists eq; sp.
    allrw.
    exists (eq1 x y); sp.

    generalize (typ2 x y); intro k.
    unfold member, equality.
    exists eq; sp.
    allrw.
    exists (eq2 x y); sp.

    generalize (typ1 x y); intro k1.
    generalize (typ2 x y); intro k2.
    allapply @nuprli_implies_nuprl.

    generalize (inhabited_type_iff lib (mkc_apply2 R0 x y) (mkc_apply2 R3 x y) (eq1 x y) (eq2 x y)); intro iff; repeat (dest_imp iff hyp).
    rw <- iff; sp.

    generalize (is_per_type_iff_is_per lib R0 eq1); introv iff.
    dest_imp iff hyp.
    intros.
    generalize (typ1 x y); intro k1.
    allapply @nuprli_implies_nuprl; sp.
    rw <- iff; sp.

  - repnd.
    unfold equality, nuprl.

    exists (fun A A' => {eqa : per(p) , close lib (univi lib i) A A' eqa}); sp.
    apply CL_init.
    exists (S i); simpl; left; sp; spcast; try computes_to_value_refl.

    fold (@nuprli p lib i).

    assert (forall x y : CTerm,
              {eq : per
               , nuprli lib i (mkc_apply2 R1 x y) (mkc_apply2 R1 x y) eq}) as f1.
    (* begin proof of the assert *)
    intros.
    unfold member, equality in equ0.
    generalize (equ0 x y); intro k; exrepnd.
    inversion k1; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    rw h0 in k0; exrepnd.
    allfold (@nuprli p lib j0).
    exists eqa; sp.
    (* end of proof of the assert *)

    assert (forall x y : CTerm,
              {eq : per
               , nuprli lib i (mkc_apply2 R2 x y) (mkc_apply2 R2 x y) eq}) as f2.
    (* begin proof of the assert *)
    intros.
    unfold member, equality in equ1.
    generalize (equ1 x y); intro k; exrepnd.
    inversion k1; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    rw h0 in k0; exrepnd.
    allfold (@nuprli p lib j0).
    exists eqa; sp.
    (* end of proof of the assert *)

    generalize (choice_spteqi lib i (mkc_apply2 R1) (mkc_apply2 R1)); intro fn1.
    generalize (choice_spteqi lib i (mkc_apply2 R2) (mkc_apply2 R2)); intro fn2.
    dest_imp fn1 hyp.
    dest_imp fn2 hyp.
    exrepnd.

    exists (fun t t' => inhabited (f0 t t')).
    apply CL_pertype.
    fold (@nuprli p lib i).
    unfold per_pertype.
    exists R1 R2
           (fun t t' => f0 t t')
           (fun t t' => f t t');
      sp; try (spcast; computes_to_value_refl); try (fold nuprl).

    generalize (fn0 x y); intro n1.
    generalize (fn2 x y); intro n2.
    allapply @nuprli_implies_nuprl.
    generalize (inhabited_type_iff lib (mkc_apply2 R1 x y) (mkc_apply2 R2 x y) (f0 x y) (f x y)); intro iff; repeat (dest_imp iff hyp).
    rw iff; sp.

    generalize (is_per_type_iff_is_per lib R1 f0); introv iff.
    dest_imp iff hyp.
    intros.
    generalize (fn2 x y); intro k1.
    allapply @nuprli_implies_nuprl; sp.
    rw iff; sp.
Qed.
(*
(*Error: Universe inconsistency.*)
Admitted.
*)

Lemma mkc_ipertype_equality_in_uni {p} :
  forall lib (R1 R2 : @CTerm p) i,
    equality lib (mkc_ipertype R1) (mkc_ipertype R2) (mkc_uni i)
    <=> (forall x y, equality lib (mkc_apply2 R1 x y) (mkc_apply2 R2 x y) (mkc_uni i))
        # is_per_type lib R1.
Proof.
  introv; split; intro equ; repnd.

  - unfold equality, nuprl in equ; exrepnd.
    inversion equ1; subst; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    rw h0 in equ0; exrepnd.
    inversion equ2; subst; try not_univ.
    dest_per.
    allfold (@nuprl p lib); allfold (@nuprli p lib j0).
    computes_to_value_isvalue.

    dands; introv.

    generalize (eqtyps x y); intro k.
    exists eq; sp; allrw.
    exists (eq1 x y); sp.

    generalize (is_per_type_iff_is_per lib R0 eq1); introv iff.
    dest_imp iff hyp.
    intros.
    generalize (eqtyps x y); intro k1.
    allapply @nuprli_implies_nuprl; sp.
    apply nuprl_refl in k1; sp.
    rw <- iff; sp.

  - repnd.
    unfold equality, nuprl.

    exists (fun A A' => {eqa : per(p) , close lib (univi lib i) A A' eqa}); sp.
    apply CL_init.
    exists (S i); simpl; left; sp; spcast; try computes_to_value_refl.

    fold (@nuprli p lib i).

    assert (forall x y : CTerm,
              {eq : term-equality
               , nuprli lib i (mkc_apply2 R1 x y) (mkc_apply2 R2 x y) eq}) as f1.
    (* begin proof of the assert *)
    intros.
    unfold member, equality in equ0.
    generalize (equ0 x y); intro k; exrepnd.
    inversion k1; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    rw h0 in k0; exrepnd.
    allfold (@nuprli p lib j0).
    exists eqa; sp.
    (* end of proof of the assert *)

    generalize (choice_spteqi lib i (mkc_apply2 R1) (mkc_apply2 R2)); intro fn1.
    dest_imp fn1 hyp.
    exrepnd.

    exists (pertype_eq f).
    apply CL_ipertype.
    fold (@nuprli p lib i).
    unfold per_ipertype.
    exists R1 R2 f;
      sp; try (spcast; computes_to_value_refl); try (fold nuprl).

    generalize (is_per_type_iff_is_per lib R1 f); introv iff.
    dest_imp iff hyp.
    intros.
    generalize (fn0 x y); intro k1.
    allapply @nuprli_implies_nuprl; sp.
    apply nuprl_refl in k1; sp.
    rw iff; sp.
Qed.
(*
(*Error: Universe inconsistency.*)
Admitted.
*)

Lemma equality_nuprli {p} :
  forall lib (A B C : @CTerm p) i eq,
    equality lib A B (mkc_uni i)
    -> nuprli lib i A C eq
    -> nuprli lib i A B eq.
Proof.
  introv e n.
  unfold equality, nuprl in e; exrepnd.
  inversion e1; try not_univ.
  duniv j h.
  allrw @univi_exists_iff; exrepnd.
  computes_to_value_isvalue; GC.
  discover; exrepnd.
  allfold (@nuprli p lib j0).
  generalize (nuprli_uniquely_valued lib j0 j0 A A eqa eq); intro k.
  repeat (autodimp k hyp).
  apply nuprli_refl in h2; auto.
  apply nuprli_refl in n; auto.
  apply (nuprli_ext lib j0 A B eqa eq); auto.
Qed.

Lemma mkc_spertype_equality_in_uni {p} :
  forall lib (R1 R2 : @CTerm p) i,
    equality lib (mkc_spertype R1) (mkc_spertype R2) (mkc_uni i)
    <=> (forall x y, equality lib (mkc_apply2 R1 x y) (mkc_apply2 R2 x y) (mkc_uni i))
        # (forall x y z,
             inhabited_type lib (mkc_apply2 R1 x z)
             -> equality lib (mkc_apply2 R1 x y) (mkc_apply2 R1 z y) (mkc_uni i))
        # (forall x y z,
             inhabited_type lib (mkc_apply2 R1 y z)
             -> equality lib (mkc_apply2 R1 x y) (mkc_apply2 R1 x z) (mkc_uni i))
        # is_per_type lib R1.
Proof.
  introv; split; intro equ; repnd.

  - unfold equality, nuprl in equ; exrepnd.
    inversion equ1; subst; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    rw h0 in equ0; exrepnd.
    inversion equ2; subst; try not_univ.
    dest_per.
    allfold (@nuprl p); allfold (@nuprli p lib j0).
    computes_to_value_isvalue.

    dands; introv.

    generalize (eqtyps1 x y); intro k.
    exists eq; sp; allrw.
    exists (eq1 x y); sp.

    intro inh.
    generalize (eqtyps1 x z); intro n.
    apply inhabited_if_inhabited_type_i in n; auto.
    generalize (eqtyps2 x y z n); intro ni.
    exists eq; sp.
    allrw; exists (eq1 x y); sp.

    intro inh.
    generalize (eqtyps1 y z); intro n.
    apply inhabited_if_inhabited_type_i in n; auto.
    generalize (eqtyps3 x y z n); intro ni.
    exists eq; sp.
    allrw; exists (eq1 x y); sp.

    generalize (is_per_type_iff_is_per lib R0 eq1); introv iff.
    dest_imp iff hyp.
    intros.
    generalize (eqtyps1 x y); intro k1.
    allapply @nuprli_implies_nuprl; sp.
    apply nuprl_refl in k1; sp.
    rw <- iff; sp.

  - repnd.
    unfold equality, nuprl.

    exists (fun A A' => {eqa : per(p) , close lib (univi lib i) A A' eqa}); sp.
    apply CL_init.
    exists (S i); simpl; left; sp; spcast; try computes_to_value_refl.

    fold (@nuprli p lib i).

    assert (forall x y : CTerm,
              {eq : term-equality
               , nuprli lib i (mkc_apply2 R1 x y) (mkc_apply2 R2 x y) eq}) as f1.
    (* begin proof of the assert *)
    intros.
    unfold member, equality in equ0.
    generalize (equ0 x y); intro k; exrepnd.
    inversion k1; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    rw h0 in k0; exrepnd.
    allfold (@nuprli p lib j0).
    exists eqa; sp.
    (* end of proof of the assert *)

    generalize (choice_spteqi lib i (mkc_apply2 R1) (mkc_apply2 R2)); intro fn1.
    dest_imp fn1 hyp.
    exrepnd.

    exists (pertype_eq f).
    apply CL_spertype.
    fold (@nuprli p lib i).
    unfold per_spertype.
    exists R1 R2 f;
      dands; introv;
      try (spcast; computes_to_value_refl);
      try (fold nuprl);
      try (complete sp).

    intro inh.
    generalize (fn0 x z); intro ni.
    apply inhabited_type_if_inhabited_i in ni; auto.
    generalize (equ1 x y z ni); intro e.
    generalize (fn0 x y); intro n.
    apply equality_nuprli with (C := mkc_apply2 R2 x y); auto.

    intro inh.
    generalize (fn0 y z); intro ni.
    apply inhabited_type_if_inhabited_i in ni; auto.
    generalize (equ2 x y z ni); intro e.
    generalize (fn0 x y); intro n.
    apply equality_nuprli with (C := mkc_apply2 R2 x y); auto.

    generalize (is_per_type_iff_is_per lib R1 f); introv iff.
    dest_imp iff hyp.
    intros.
    generalize (fn0 x y); intro k1.
    allapply @nuprli_implies_nuprl; sp.
    apply nuprl_refl in k1; sp.
    rw iff; sp.
Qed.
(*
(*Error: Universe inconsistency.*)
Admitted.
*)

Lemma mkc_uni_in_nuprl {p} :
  forall lib (i : nat),
    nuprl lib (mkc_uni i)
          (mkc_uni i)
          (fun A A' => {eqa : per(p) , close lib (univi lib i) A A' eqa}).
Proof.
  introv.
  apply CL_init.
  exists (S i); simpl.
  left; sp; spcast; apply computes_to_valc_refl; sp.
Qed.

Lemma nuprl_mkc_uni {p} :
  forall lib (i : nat),
    {eq : per(p) , nuprl lib (mkc_uni i) (mkc_uni i) eq}.
Proof.
  intros.
  exists (fun A A' => {eqa : per(p) , close lib (univi lib i) A A' eqa}).
  apply mkc_uni_in_nuprl.
Qed.

Lemma tequality_mkc_uni {p} :
  forall lib (i : nat), @tequality p lib (mkc_uni i) (mkc_uni i).
Proof.
  generalize (@nuprl_mkc_uni p); sp.
Qed.
(*
(*Error: Universe inconsistency.*)
Admitted.
*)

Lemma mkc_cequiv_equality_in_uni {p} :
  forall lib (a b c d : @CTerm p) i,
    equality lib (mkc_cequiv a b) (mkc_cequiv c d) (mkc_uni i)
    <=>
    (ccequivc lib a b <=> ccequivc lib c d).
Proof.
  sp; sp_iff Case; intro e.

  - Case "->".
    unfold equality in e; exrepnd.
    allunfold @nuprl.
    inversion e1; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    rw h0 in e0; exrepnd.
    inversion e2; try not_univ.

  - Case "<-".
    exists (fun A A' => {eqa : per(p) , close lib (univi lib i) A A' eqa}); sp.
    apply CL_init.
    exists (S i); simpl; left; sp;
    spcast; try computes_to_value_refl.
    exists (fun t t' : @CTerm p => t ===>(lib) mkc_axiom
                      # t' ===>(lib) mkc_axiom
                      # ccequivc lib a b).
    apply CL_cequiv; unfold per_cequiv.
    exists a b c d; sp; spcast; try computes_to_value_refl.
Qed.
(*
(*Error: Universe inconsistency.*)
Admitted.
*)

Lemma mkc_approx_equality_in_uni {p} :
  forall lib (a b c d : @CTerm p) i,
    equality lib (mkc_approx a b) (mkc_approx c d) (mkc_uni i)
    <=>
    (capproxc lib a b <=> capproxc lib c d).
Proof.
  sp; sp_iff Case; intro e.

  - Case "->".
    unfold equality in e; exrepnd.
    unfold nuprl in e1.
    inversion e1; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    rw h0 in e0; exrepnd.
    inversion e2; try not_univ.

  - Case "<-".
    exists (fun A A' => {eqa : per(p) , close lib (univi lib i) A A' eqa}); sp.
    apply CL_init.
    exists (S i); simpl; left; sp;
    spcast; try computes_to_value_refl.
    exists (fun t t' : @CTerm p => t ===>(lib) mkc_axiom
                      # t' ===>(lib) mkc_axiom
                      # capproxc lib a b).
    apply CL_approx; unfold per_approx.
    exists a b c d; sp; spcast; try computes_to_value_refl.
Qed.
(*
(*Error: Universe inconsistency.*)
Admitted.
*)

(*
Lemma tequality_in_uni_iff_tequality {p} :
  forall (T1 T2 : @CTerm p) i,
    tequality lib (mkc_member T1 (mkc_uni i))
              (mkc_member T2 (mkc_uni i))
    <=> equorsq T1 T2 (mkc_uni i).
Proof.
  introv.
  allrw <- @fold_mkc_member.
  rw @tequality_mkc_equality.
  split; intro k; repnd; try (complete sp).

  dands; try (complete sp).
  apply tequality_mkc_uni.
  split; intro e.
  generalize (cequorsq_equality_trans2 T1 T1 T2 (mkc_uni i)); intro e1.
  repeat (dest_imp e1 hyp).
  apply equality_sym in e1.
  apply equality_refl in e1; sp.
  generalize (cequorsq_equality_trans1 T1 T2 T2 (mkc_uni i)); intro e1.
  repeat (dest_imp e1 hyp).
  apply equality_refl in e1; sp.
Qed.
*)

Lemma equality_in_uni_mkc_halts {p} :
  forall lib i (a b : @CTerm p),
    equality lib (mkc_halts a) (mkc_halts b) (mkc_uni i)
    <=>
    (chaltsc lib a <=> chaltsc lib b).
Proof.
  intros; repeat (rewrite <- fold_mkc_halts).
  rw @mkc_approx_equality_in_uni.
  allrw @chasvaluec_as_capproxc; sp.
Qed.

Lemma cequorsq_mkc_halts_implies {p} :
  forall lib i (a b : @CTerm p),
    equorsq lib (mkc_halts a) (mkc_halts b) (mkc_uni i)
    -> (chaltsc lib a <=> chaltsc lib b).
Proof.
  unfold equorsq; intros; sp;
  allrw @equality_in_uni_mkc_halts; sp.
  uncast; allrw @cequivc_decomp_halts; sp;
  split; sp; spcast; discover; sp.
Qed.

Lemma cequorsq_mkc_halts {p} :
  forall lib i (a b : @CTerm p),
    equorsq lib (mkc_halts a) (mkc_halts b) (mkc_uni i)
    <=>
    (chaltsc lib a <=> chaltsc lib b).
Proof.
  unfold equorsq; intros; split; sp; try right;
  allrw @equality_in_uni_mkc_halts; sp; uncast;
  allrw @cequivc_decomp_halts; try split; sp; spcast;
  discover; sp.
Abort.
(* This is not true in Prop with Cast around hasvalue *)
(*Qed.*)


Require Import Arith.
Require Import Omega.
Require Import String.
Require Import List.
Import ListNotations.

Require Import OrderedType OrderedTypeEx.
Require FMapList.
Require FMapFacts.
Module NatMap := FMapList.Make Nat_as_OT.
Module NatMapFacts := FMapFacts.WFacts_fun Nat_as_OT NatMap.

Require Import ast.

(* ************************************************************ *)
(* ************************************************************ *)
(*                                                              *)
(*                          semantics                           *)
(*                                                              *)
(* ************************************************************ *)
(* ************************************************************ *)

(*
 * We define the semantics in terms of an abstract machine, which
 * includes the evaluation state as well as the program.
 *
 * A machine has a heap and a list of threads.
 * A thread is a lits of stack frames.
 * A stack frame is a local store plus a statement to execute.
 *
 * Statements are executed destructively.
 *)

(**************************************************************)
(* stores *)

Section Stores.

Inductive LockState: Set :=
| LockHeld: LockState (* XXX: keep track of who holds it? *)
| LockAvailable: LockState
.

(* old form that used coq types directly
Inductive val: Type := mkval (t: Type) (a : t): val.

Definition Heap := NatMap.t val.
Definition Locals := NatMap.t val.
*)

Inductive Heap :=
| mkheap (memory: NatMap.t value)
         (lockenv: NatMap.t LockState)
         (disks: NatMap.t (NatMap.t value)):
       Heap
.

Definition Locals := NatMap.t value.

Definition get_locals (rho : Locals) (v : var) : option value :=
  match v with
  | mkvar t n => NatMap.find n rho
  end.
Definition set_locals (v : var) (val : value) (rho : Locals) : Locals :=
  match v with
  | mkvar t n => NatMap.add n val rho
  end.

Definition heap_get_data (whichheap: WhichHeap) (index: nat) (h: Heap):
                                option value :=
   match h with
   | mkheap memory _ disks =>
        match whichheap with
        | MemoryHeap => NatMap.find index memory
        | DiskHeap disknum =>
             match NatMap.find disknum disks with
             | Some disk => NatMap.find index disk
             (* XXX we should have something that prevents getting here *)
             | None => None
             end
        end
   end.

Definition heap_set_data (whichheap: WhichHeap) (index: nat)
                         (val: value) (h: Heap): Heap :=
   match h with
   | mkheap memory lockenv disks =>
        match whichheap with
        | MemoryHeap =>
             mkheap (NatMap.add index val memory) lockenv disks
        | DiskHeap disknum =>
             match NatMap.find disknum disks with
             | Some disk =>
                  let disk' := (NatMap.add index val disk) in
                  mkheap memory lockenv (NatMap.add disknum disk' disks)
             | None => mkheap memory lockenv disks
             end
        end
   end.

Definition get_heap (rho : Heap) (a : addr) : option value :=
  match a with
  | mkaddr t n which => heap_get_data which n rho
  end.
  (*
  match rho with
  | mkheap mem lk disks =>
    match a with
    | mkaddr t n which =>
      match which with
      | MemoryHeap => NatMap.find n mem
      | DiskHeap d =>
        match NatMap.find d disks with
        | None => None
        | Some disk => NatMap.find n disk
        end
      end
    end
  end.*)

Definition set_heap (a : addr) (val : value) (rho : Heap) : Heap :=
  match a with
  | mkaddr t n which => heap_set_data which n val rho
  end.
  (*
  match rho with
  | mkheap mem lk disks =>
    match a with
    | mkaddr t n which =>
      match which with
      | MemoryHeap => mkheap (NatMap.add n val mem) lk disks
      | DiskHeap d =>
        match NatMap.find d disks with
        (* XXX write errors for missing disks? *)
        | None => rho
        | Some disk => mkheap mem lk (NatMap.add d (NatMap.add n val disk) disks)
        end
      end
    end
  end.*)

Definition heap_get_lockstate (index: nat) (h: Heap): option LockState :=
   match h with
   | mkheap _ lockenv _ => NatMap.find index lockenv
   end.

Definition heap_set_lockstate (index: nat) (val: LockState) (h: Heap): Heap :=
   match h with
   | mkheap memory lockenv disks =>
        mkheap memory (NatMap.add index val lockenv) disks
   end.

End Stores.

(**************************************************************)
(* expressions *)

Section Expressions.

Inductive ExprYields: forall t, Locals -> expr -> value -> Prop :=
| value_yields: forall loc t a,
    ExprYields t loc (e_value t a) a
(* XXX THERE'S NOTHING HERE FOR GETLOCKADDR *)
| read_yields: forall loc t (x : var) id a,
    (* XXX tidy this *)
    type_of_value a = t ->
    x = mkvar t id -> NatMap.find id loc = Some a ->
    ExprYields t loc (e_read x) a
| cond_true_yields: forall t loc e et ef a,
    ExprYields t_bool loc e v_true ->
    ExprYields t loc et a ->
    ExprYields t loc (e_cond t e et ef) a
| cond_false_yields: forall t loc e et ef a,
    ExprYields t_bool loc e v_false ->
    ExprYields t loc ef a ->
    ExprYields t loc (e_cond t e et ef) a
| natbinop_yields: forall loc e1 e2 f n1 n2,
    ExprYields t_nat loc e1 (v_nat n1) ->
    ExprYields t_nat loc e2 (v_nat n2) ->
    ExprYields t_nat loc (e_natbinop f e1 e2) (v_nat (f n1 n2))
.

End Expressions.

(**************************************************************)
(* statements *)

Section Statements.

(* call, return, and start appear at higher levels *)
Inductive StmtSteps: Heap -> Locals -> stmt ->
                     Heap -> Locals -> stmt -> Prop :=
| step_in_seq: forall h loc s1 s2 h' loc' s1',
     StmtSteps h loc s1 h' loc' s1' ->
     StmtSteps h loc (s_seq s1 s2) h' loc' (s_seq s1' s2)
| step_next: forall h loc s2,
     StmtSteps h loc (s_seq s_skip s2) h loc s2
| step_assign: forall h loc id type e a,
     ExprYields type loc e a ->
     StmtSteps h loc (s_assign (mkvar type id) e)
               h (NatMap.add id a loc) s_skip
| step_load: forall h loc t lid e heapaddr whichheap a,
     ExprYields (t_addr t) loc e (v_addr (mkaddr t heapaddr whichheap)) ->
     heap_get_data whichheap heapaddr h = Some a ->
     StmtSteps h loc (s_load (mkvar t lid) e)
               h (NatMap.add lid a loc) s_skip
| step_store: forall h loc lid hid whichheap e t'a a,
     ExprYields t'a loc e a ->
     ExprYields (t_addr t'a) loc (e_read (mkvar (t_addr t'a) lid))
                                 (v_addr (mkaddr t'a hid whichheap)) ->
     StmtSteps h loc (s_store (mkvar (t_addr t'a) lid) e)
               (heap_set_data whichheap hid a h) loc s_skip
| step_if_true: forall h loc e st sf,
     ExprYields t_bool loc e v_true ->
     StmtSteps h loc (s_if e st sf) h loc st
| step_if_false: forall h loc e st sf,
     ExprYields t_bool loc e v_false ->
     StmtSteps h loc (s_if e st sf) h loc sf
| step_while_true: forall h loc e body,
     ExprYields t_bool loc e v_true ->
     StmtSteps h loc (s_while e body)
               h loc (s_seq body (s_while e body))
| step_while_false: forall h loc e body,
     ExprYields t_bool loc e v_false ->
     StmtSteps h loc (s_while e body) h loc s_skip
| step_getlock: forall h loc t id heapaddr,
     NatMap.find id loc = Some (v_lock (mkaddr t heapaddr MemoryHeap)) ->
     heap_get_lockstate heapaddr h = Some LockAvailable ->
     StmtSteps h loc (s_getlock (mkvar (t_lock t) id))
               (heap_set_lockstate heapaddr LockHeld h) loc (s_skip)
| step_putlock: forall h loc t id heapaddr,
     NatMap.find id loc = Some (v_lock (mkaddr t heapaddr MemoryHeap)) ->
     (* XXX shouldn't we require that we hold the lock? *)
     (* (XXX: maybe we can't; see notes elsewhere *)
     heap_get_lockstate heapaddr h = Some LockHeld ->
     StmtSteps h loc (s_putlock (mkvar (t_lock t) id))
               (heap_set_lockstate heapaddr LockAvailable h) loc (s_skip)
.

End Statements.

(**************************************************************)
(* vardecls *)

Section Vardecls.

Inductive VardeclsSteps: Locals -> list vardecl -> Locals -> Prop :=
| vardecls_steps_nil: forall loc,
     VardeclsSteps loc [] loc
| vardecls_steps_cons: forall loc t id e a decls loc',
     ExprYields t loc e a ->
     VardeclsSteps (NatMap.add id a loc) decls loc' ->
     VardeclsSteps loc ((mkvardecl (mkvar t id) e) :: decls) loc'
.

End Vardecls.

(**************************************************************)
(* stacks *)

Section Stacks.

Inductive Stack: Type :=
| stack_empty: Stack
| stack_frame: Locals -> Stack -> stmt -> Stack
.

Inductive StackSteps: Heap -> Stack ->
                      Heap -> Stack -> Prop :=

| stack_steps_stmt: forall h loc stk s h' loc' s',
     StmtSteps h loc s
               h' loc' s' ->
     StackSteps h (stack_frame loc stk s)
                h' (stack_frame loc' stk s')

| stack_steps_call_final: forall h loc stk x proc arg,
     (* gross but avoids duplicating the call frame logic *)
     StackSteps h (stack_frame loc stk (s_call x proc arg))
                h (stack_frame loc stk (s_seq (s_call x proc arg) s_skip))

| stack_steps_call_seq: forall
                            h loc stk s s2
                            rt retid pt paramid decls body arg argval
                            s' new'loc,
     (* restrict the form of the call statement *)
     s = (s_seq (s_call (mkvar rt retid)
                    (mkproc rt (mkvar pt paramid) decls body)
                    arg)
                 s2) ->
     (* the new statement for the outer frame *)
     s' = s_seq (s_assign (mkvar rt retid) (e_value rt v_undef)) s2 ->

     (* evaluate the arg in the outer frame *)
     ExprYields pt loc arg argval ->

     (* create the locals for the new inner frame *)
     VardeclsSteps (NatMap.add paramid argval (NatMap.empty value))
                   decls
                   new'loc ->

     (* make a new frame to evaluate the procedure body *)
     StackSteps h (stack_frame loc stk s)
                h (stack_frame new'loc (stack_frame loc stk s') body)

| stack_steps_return_seq: forall h loc stk e s2,
     (* return followed by crap is just return *)
     StackSteps h (stack_frame loc stk (s_seq (s_return e) s2))
                h (stack_frame loc stk (s_return e))

| stack_steps_return_final: forall h
                                loc loc' stk' s' s''
                                rt ret retval
                                x ejunk,
     (* evaluate the return expression in the inner frame *)
     ExprYields rt loc ret retval ->

     (* the statement in the outer frame must be an assignment *)
     s' = s_assign x ejunk ->

     (* and gets updated with the return value *)
     s'' = s_assign x (e_value rt retval) ->

     (* pop the frame *)
     StackSteps h (stack_frame loc (stack_frame loc' stk' s') (s_return ret))
                h (stack_frame loc' stk' s'')
.

(* this is its own thing because it needs a different signature *)
(* XXX make sure the constraint that started procs return unit gets into the types *)
Inductive StackStepsStart: Stack -> Stack -> Stack -> Prop :=
| stack_steps_start: forall pt loc stk proc arg newloc argval,
     ExprYields pt loc arg argval ->
     newloc = NatMap.add 0 v_unit (NatMap.empty value) ->
     StackStepsStart
        (stack_frame loc stk (s_start proc arg))
        (stack_frame loc stk s_skip)
        (stack_frame newloc stack_empty (s_call (mkvar t_unit 0) proc (e_value pt argval)))
.

Inductive StackDone: Stack -> Prop :=
| stack_done: forall loc,
     StackDone (stack_frame loc stack_empty s_skip)
.

End Stacks.

(**************************************************************)
(* threads *)

Section Threads.

Inductive Thread: Type :=
| thread: Stack -> Thread
.

Inductive ThreadSteps: Heap -> Thread ->
                       Heap -> Thread -> Prop :=
| thread_steps: forall h s h' s',
     StackSteps h s h' s' ->
     ThreadSteps h (thread s) h' (thread s')
.

Inductive ThreadStepsStart: Thread -> Thread -> Thread -> Prop :=
| thread_steps_start: forall s s' s2,
     StackStepsStart s s' s2 ->
     ThreadStepsStart (thread s) (thread s') (thread s2)
.

Inductive ThreadDone: Thread -> Prop :=
| thread_done: forall stk,
     StackDone stk ->
     ThreadDone (thread stk)
.

End Threads.

(**************************************************************)
(* machines *)

Section Machines.

Inductive Machine: Type :=
| machine: Heap -> list Thread -> Machine
.

(*
 * XXX: how do we reason about properties like "a thread may not exit
 * while it holds locks"?
 *)

Inductive MachineSteps: Machine -> Machine -> Prop :=
| machine_steps_plain: forall h t h' t' ts1 ts2,
     ThreadSteps h t h' t' ->
     MachineSteps (machine h (ts1 ++ [t] ++ ts2))
                  (machine h' (ts1 ++ [t'] ++ ts2))
| machine_steps_start: forall h t t1 t2 ts1 ts2,
     ThreadStepsStart t t1 t2 ->
     MachineSteps (machine h (ts1 ++ [t] ++ ts2))
                  (machine h (ts1 ++ [t1; t2] ++ ts2))
| machine_steps_exit: forall h t ts1 ts2,
     ThreadDone t ->
     MachineSteps (machine h (ts1 ++ [t] ++ ts2))
                  (machine h (ts1 ++ ts2))
.

End Machines.