(** 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 Charge.Tactics.Iterated.
Require Import Charge.Tactics.SepLogFold.
Require Import Charge.Tactics.SepLogFoldWithAnd.
Require Import Charge.Tactics.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 :=
  { spatial : list (expr typ sym * list (expr typ sym))
  ; star_true : bool
  ; pure : list (expr typ sym)
  }.

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

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

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

  Definition mkStar (l r : conjunctives) : conjunctives :=
  {| spatial := l.(spatial) ++ r.(spatial)
   ; star_true := orb l.(star_true) r.(star_true)
   ; pure := l.(pure) ++ r.(pure)
   |}.

  Definition SepLogArgs_normalize : SepLogArgs typ sym conjunctives :=
  {| SepLogFold.do_emp := mkEmpty
   ; SepLogFold.do_star := mkStar
   ; SepLogFold.do_other := fun f xs => mkSpatial f (List.map fst xs)
   ; SepLogFold.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.
*)
*)

    Definition mkAnd (l r : conjunctives) : conjunctives :=
      match l.(spatial) with
        | nil => {| spatial := r.(spatial)
                    ; pure := r.(pure) ++ l.(pure)
                    ; star_true := r.(star_true)
                 |}
        | _ :: _ =>
          match r.(spatial) with
            | nil => {| spatial := l.(spatial)
                        ; pure := l.(pure) ++ r.(pure)
                        ; star_true := l.(star_true)
                     |}
            | _ :: _ =>
              (** This is sub-optimal on several levels *)
              mkSpatial (SSL.(e_and) (conjunctives_to_expr l) (conjunctives_to_expr r)) nil
          end
      end.

    Definition SepLogAndArgs_normalize : SepLogAndArgs typ sym conjunctives :=
    {| do_emp := mkEmpty
     ; do_star := mkStar
     ; do_other := fun f xs => mkSpatial f (List.map fst xs)
     ; do_pure := mkPure
     ; do_and := mkAnd
     |}.

  End conjunctivesD.

  Definition normalize (sls : SepLogSpec typ sym) :=
    lazy_typed_mfold _ _ (AppFullFoldArgs_SepLogArgs SepLogArgs_normalize sls).

  Definition normalize_and (ssl : SynSepLog typ sym) (sls : SepLogAndSpec typ sym) :=
    lazy_typed_mfold _ _ (AppFullFoldArgs_SepLogAndArgs (SepLogAndArgs_normalize ssl) sls).

(*
  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.
*)


Set Warnings "-notation-overridden,-parsing".
Require Import Tweetnacl_verif.init_tweetnacl.
Require Import Tweetnacl.Libs.Export.
Require Import Tweetnacl.ListsOp.Export.
Require Import Tweetnacl.Low.Car25519.
Require Import Tweetnacl.Low.Carry_n.
Require Import Tweetnacl.Low.BackCarry.
Require Import Tweetnacl.Mid.Car25519.
Require Import Tweetnacl.Mid.Reduce.
Local Open Scope Z.

Lemma car_low_level: forall contents_o,
  Forall (fun x : ℤ => - 2 ^ 62 < x < 2 ^ 62) contents_o ->
  Zlength contents_o = 16 -> forall i, 0 <= i < 15 -> 0 <= i < Zlength (map Int64.repr (Carrying_n 16 (nat_of_Z i) 0 contents_o)) ->
mVI64 (Carrying_n 16 (nat_of_Z (i + 1)) 0 contents_o) =
upd_Znth i
  (upd_Znth (i + 1) (mVI64 (Carrying_n 16 (nat_of_Z i) 0 contents_o))
     (Vlong
        (Int64.add (Int64.repr (Znth (i + 1) (Carrying_n 16 (nat_of_Z i) 0 contents_o) 0))
           (Int64.shr (Int64.repr (Znth i (Carrying_n 16 (nat_of_Z i) 0 contents_o) 0)) (Int64.repr 16)))))
  (force_val
     (sem_cast_l2l
        (force_val
           (sem_and tlg tint
              (Znth i
                 (upd_Znth (i + 1) (mVI64 (Carrying_n 16 (nat_of_Z i) 0 contents_o))
                    (Vlong
                       (Int64.add (Int64.repr (Znth (i + 1) (Carrying_n 16 (nat_of_Z i) 0 contents_o) 0))
                          (Int64.shr (Int64.repr (Znth i (Carrying_n 16 (nat_of_Z i) 0 contents_o) 0)) (Int64.repr 16)))))
                 Vundef) (Vint (Int.repr 65535)))))).
Proof.
  intros contents_o Hcontents_o Hlengthcontents_o i Hi HiL.
  assert(Hlength2: 0 <= i + 1 < Zlength (Carrying_n 16 (nat_of_Z i) 0 contents_o)).
  {
    assert(exists i', nat_of_Z i = i') by eauto.
    destruct H as [i' Hi'].
    assert(0 <= Z.of_nat i' < 15).
    rewrite -Hi' /nat_of_Z Z2Nat.id ; omega.
    rewrite Carrying_n_Zlength ; [ |rewrite Zlength_correct in Hlengthcontents_o] ; go.
  }
  rewrite upd_Znth_map.
  repeat rewrite Int64.shr_div_two_p.
  rewrite (Int64.unsigned_repr 16).
  2: solve_bounds_by_values.
  rewrite add64_repr.
  rewrite upd_Znth_map.
  rewrite (Znth_map Int64.zero).
  2: rewrite Zlength_map upd_Znth_Zlength ; omega.
  rewrite (Znth_map 0).
  2: rewrite upd_Znth_Zlength ; omega.
  rewrite (Int64.signed_repr (Znth i (Carrying_n 16 (nat_of_Z i) 0 contents_o) 0)).
  2: {
  apply Forall_Znth ; try omega.
  eapply list.Forall_impl.
  rewrite Zlength_correct in Hlengthcontents_o;
  eapply Zcarry_n_bounds_length ; go.
  intros ; simpl in H ; solve_bounds_by_values.
  }
  rewrite /sem_and /tint /sem_binarith /classify_binarith.
  simpl sem_cast.
  rewrite /sem_cast_i2l /sem_cast_l2l /both_long /force_val.
  rewrite /cast_int_long.
  rewrite and64_repr.
  rewrite upd_Znth_map.
  rewrite upd_Znth_map.
  f_equal.
  f_equal.
  rewrite Int.signed_repr.
  2: solve_bounds_by_values.
  change 65535 with (Z.ones 16).
  rewrite Z.land_comm.
  repeat orewrite upd_Znth_upd_nth.
  repeat orewrite Znth_nth.
  unfold nat_of_Z.
  assert(Hi': exists i', Z.to_nat i = i') by eauto.
  destruct Hi' as [i' Hi'].
  assert_gen_hyp_ Hid i 14 14.
  omega.
  rewrite Zlength_correct in Hlengthcontents_o.
  assert(Ho' : (length contents_o = 16)%nat) by go.
  repeat (destruct contents_o ; tryfalse).

  repeat match goal with
      | [H : _ \/ _ |- _ ] => destruct H ; subst
      | _ => idtac
    end; Grind_add_Z; repeat change_Z_to_nat ; repeat rewrite Carry_n_step ; repeat rewrite Carry_n_step_0 ; unfold upd_nth ; unfold nth;
  unfold getResidue ;
  unfold getCarry ;
  repeat orewrite Int64.Zshiftl_mul_two_p ; repeat orewrite Int64.Zshiftr_div_two_p ; reflexivity.
Qed.

Lemma car25519low_level: forall o, Forall (fun x : ℤ => - 2 ^ 62 < x < 2 ^ 62) o ->
Zlength o = 16 ->
forall c, Vlong c = Vlong (Int64.repr (Znth 15 (Carrying_n 16 15 0 o) 0)) ->
forall d, Vlong d = Vlong (Int64.repr (Znth 0 (Carrying_n 16 15 0 o) 0)) ->
mVI64 (car25519 o) =
upd_Znth 15
  (upd_Znth 0 (mVI64 (Carrying_n 16 (Pos.to_nat 15) 0 o))
     (Vlong (Int64.add d (Int64.mul (Int64.repr 38) (Int64.shr c (Int64.repr 16))))))
  (force_val
     (sem_cast_l2l
        (force_val
           (sem_and tlg tint
              (Znth 15
                 (upd_Znth 0 (mVI64 (Carrying_n 16 (Pos.to_nat 15) 0 o))
                    (Vlong (Int64.add d (Int64.mul (Int64.repr 38) (Int64.shr c (Int64.repr 16)))))) Vundef)
              (Vint (Int.repr 65535)))))).
Proof.
  intros o Ho Hlengtho c Hc d Hd.
  assert(HZl: Zlength (Carrying_n 16 15 0 o) = 16).
    rewrite Carrying_n_Zlength ; [omega |rewrite Zlength_correct in Hlengtho] ; rewrite Hlengtho ; compute ; reflexivity.
  change (Pos.to_nat 15) with (15%nat) in *.
  change (nat_of_Z 15) with (15%nat) in *.
  change (Z.to_nat 15) with (15%nat) in *.
  assert(Hlength': Datatypes.length o = 16%nat).
    rewrite Zlength_correct in Hlengtho ; omega.
  assert(Hlength: 0 <= 15 < Zlength (Carrying_n 16 15 0 o)).
    rewrite Carrying_n_Zlength; try omega ; rewrite Hlength'; reflexivity.
  assert(H1516: 0 <= 15 < 16) by omega.
  assert(H016: 0 <= 0 < 16) by omega.
  assert(Hcorrolary15 := Zcarry_n_bounds_length o Hlength' Ho 15 H1516).
  assert(Hcorrolary0 := Zcarry_n_bounds_length o Hlength' Ho 0 H016).
  change (Z.to_nat 15) with 15%nat in Hcorrolary15.
  change (Z.to_nat 0) with 0%nat in Hcorrolary0.
  assert(Vlong_inv: forall a b, Vlong a = Vlong b -> a = b) by congruence.
  apply Vlong_inv in Hc.
  apply Vlong_inv in Hd.
  subst c d.
  repeat rewrite Int64.shr_div_two_p.
  rewrite (Int64.unsigned_repr 16).
  2: solve_bounds_by_values.
  rewrite mul64_repr.
  rewrite add64_repr.
  rewrite upd_Znth_map.
  rewrite (Znth_map Int64.zero).
  2: rewrite upd_Znth_Zlength Zlength_map ; omega.
  rewrite /sem_and /tint /sem_binarith /classify_binarith.
  simpl sem_cast.
  rewrite /sem_cast_i2l /sem_cast_l2l /both_long /force_val /cast_int_long.
  rewrite upd_Znth_map.
  rewrite upd_Znth_map.
  rewrite (Znth_map 0).
  2: rewrite upd_Znth_Zlength ; omega.
  rewrite and64_repr.
  rewrite upd_Znth_map.
  f_equal.
  f_equal.
  unfold car25519.
  remember (Carrying_n 16 15 0 o) as carr_list.
  assert(Hlength_car: (length carr_list = 16)%nat).
    subst ; rewrite Carrying_n_length ; rewrite Zlength_correct in Hlengtho ; omega.
  rewrite Int.signed_repr.
  2: solve_bounds_by_values.
  rewrite Int64.signed_repr.
  2:{
    apply Forall_Znth.
    omega.
    eapply Forall_impl ; eauto;
    let Hx := fresh in intros ? Hx ;
    simpl in Hx;
    solve_bounds_by_values.
  }
  repeat (destruct carr_list ; tryfalse).
  simpl backCarry;
  repeat orewrite upd_Znth_upd_nth;
  repeat orewrite Znth_nth;
  unfold nat_of_Z;
  repeat change_Z_to_nat;
  unfold nth;
  unfold upd_nth;
  unfold getResidue;
  unfold getCarry.
  change 65535 with (Z.ones 16).
  rewrite Z.land_comm.
  orewrite Int64.Zshiftr_div_two_p => //.
Qed.

Close Scope Z.


(* an abstract structured pools contract *)

From PhD.Specifications.FA2Spec Require FA2Spec.
From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import BuildUtils.
From ConCert.Execution Require Import Containers.
From ConCert.Execution Require Import ContractCommon.
From ConCert.Execution Require Import Monad.
From ConCert.Execution Require Import ResultMonad.
From ConCert.Execution Require Import Serializable.
From ConCert.Utils Require Import RecordUpdate.
From ConCert.Utils Require Import Extras.
From Coq Require Import Ensembles.
From Coq Require Import ZArith_base.
From Coq Require Import QArith_base.
From Coq Require Import String.
From Coq Require Import List.
From Coq Require Import Fin.
From Coq.Init Require Import Byte.

Import ListNotations.
Open Scope N_scope.
Open Scope string.

(* =============================================================================
 * Defintions:
      We begin with some type and auxiliary definitions which we use for the
      contract specification.
 * ============================================================================= *)

Section Definitions.
Context {Base : ChainBase}.

(* ConCert specific types *)
Definition error : Type := N.

    Section ErrorCodes.

    Definition error_PERMISSIONS_DENIED : error := 1.
    Definition error_CONTRACT_NOT_FOUND : error := 2.
    Definition error_TOKEN_NOT_FOUND : error := 3.
    Definition error_INSUFFICIENT_BALANCE : error := 4.
    Definition error_CALL_VIEW_FAILED : error := 5.
    Definition error_FAILED_ASSERTION : error := 6.
    Definition error_FAILED_DIVISION : error := 7.
    Definition error_FAILED_TO_INITIALIZE : error := 8.

    End ErrorCodes.

Definition token : Type := FA2Spec.token. (* token_address and token_id fields *)
Definition exchange_rate := N. (* always divided by 1_000_000n in the code  *)

Definition transfer_to := FA2Spec.transfer_to.
Definition transfer_data := FA2Spec.transfer_data.

Definition mint_data := FA2Spec.mint_data.
Definition mint := FA2Spec.mint.

Record pool_data := {
    token_pooled : token ;
    qty_pooled : N ; (* the qty of tokens to be pooled *)
}.

Record unpool_data := {
    token_unpooled : token ;
    qty_unpooled : N ; (* the qty of pool tokens being turned in *)
}.

Record trade_data := {
    token_in_trade : token ;
    token_out_trade : token ;
    qty_trade : N ; (* the qty of token_in going in *)
}.

Inductive entrypoint :=
(* pooling and trading *)
| Pool : pool_data -> entrypoint
| Unpool : unpool_data -> entrypoint
| Trade : trade_data -> entrypoint.

Definition calc_delta_y (rate_in : N) (rate_out : N) (qty_trade : N) (k : N) (x : N) : N :=
    (* calculate ell *)
    let l := N.sqrt (k * (1_000_000 * 1_000_000) / (rate_in * rate_out)) in
    (* calculate the exchange rate *)
    l * rate_in / 1_000_000 - k / ((l * rate_out) / 1_000_000 + qty_trade).

Definition calc_rate_in (rate_in : N) (rate_out : N) (qty_trade : N) (k : N) (x : N) : N :=
    let delta_y := calc_delta_y rate_in rate_out qty_trade k x in
    (rate_in * x / 1_000_000 + rate_out * delta_y / 1_000_000) / (x + qty_trade).

(* a function to get a balance from an FMap *)
Definition get_bal (t : token) (tokens_held : FMap token N) :=
    match FMap.find t tokens_held with | Some b => b | None => 0 end.

(* the same function, but named differently for the sake of clarity *)
Definition get_rate (t : token) (rates : FMap token N) : N :=
    match FMap.find t rates with | Some r => r | None => 0 end.

End Definitions.

(* the abstract specification *)
Section AbstractSpecification.
Context {Base : ChainBase}

(* =============================================================================
 * The Contract Specification:
      We detail a list of propositions of a contract's behavior which can be
      proven true of a given contract.
 * ============================================================================= *)

    { Setup Msg State Error : Type }
    `{Serializable Msg}  `{Serializable Setup}  `{Serializable State} `{Serializable Error}.

(* Specification of the Msg type:
  - A Pool entrypoint, whose interface is defined by the pool_data type
  - An Unpool entrypoint, whose interface is defined by the unpool_data type
  - A Trade entrypoint, whose interface is defined by the trade_data type
*)
Class Msg_Spec (T : Type) :=
  build_msg_spec {
    pool : pool_data -> T ;
    unpool : unpool_data -> T ;
    trade : trade_data -> T ;
}.

(* specification of the State type:
  - keeps track of:
    - the exchange rates
    - tokens held
    - pool token address
    - number of outstanding pool tokens
*)
Class State_Spec (T : Type) :=
  build_state_spec {
    stor_rates : T -> FMap token exchange_rate ;
    stor_tokens_held : T -> FMap token N ;
    stor_pool_token : T -> token ;
    stor_outstanding_tokens : T -> N ;
}.

(* specification of the Setup type
  to initialize the contract, we need:
    - the initial rates
    - the pool token
*)
Class Setup_Spec (T : Type) :=
  build_setup_spec {
    init_rates : T -> FMap token exchange_rate ;
    init_pool_token : T -> token ;
}.

(* specification of the Error type *)
Class Error_Spec (T : Type) :=
  build_error_type {
    error_to_Error : error -> T ;
}.

(* we assume that our contract types satisfy the type specifications *)
Context `{Msg_Spec Msg}  `{Setup_Spec Setup}  `{State_Spec State} `{Error_Spec Error}.

(* Specification of the POOL entrypoint *)
(* When the POOL entrypoint is called, the contract call fails if
    the token to be pooled is not in the family of semi-fungible tokens. *)
Definition pool_entrypoint_check (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* forall calls to the Pool entrypoint *)
    msg = pool (msg_payload) ->
    (* the receive function returns an error if the token to be pooled is not in the
       rates map held in the storage (=> is not in the semi-fungible family) *)
    FMap.find msg_payload.(token_pooled) (stor_rates cstate) = None ->
    receive contract chain ctx cstate (Some msg) =
      Err(error_to_Error error_TOKEN_NOT_FOUND).

Definition pool_entrypoint_check_2 (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate cstate' chain ctx msg msg_payload acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* forall calls to the Pool entrypoint *)
    msg = pool (msg_payload) ->
    (* the receive function returns an error if the token to be pooled is not in the
       rates map held in the storage (=> is not in the semi-fungible family) *)
    receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
    exists r_x,
    FMap.find msg_payload.(token_pooled) (stor_rates cstate) = Some r_x.

(* When the POOL entrypoint is successfully called, it emits a TRANSFER call to the
    token in storage, with q tokens in the payload of the call *)
Definition pool_emits_transfer (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload cstate' acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the call to POOL was successful *)
    msg = pool (msg_payload) ->
    receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
    (* in the acts list there is a transfer call with q tokens as the payload *)
    exists transfer_to transfer_data transfer_payload,
    (* there is a transfer call *)
    In
    (act_call
        (msg_payload.(token_pooled).(FA2Spec.token_address)) (* call to the token address *)
        0 (* with amount = 0 *)
        (serialize (FA2Spec.Transfer transfer_payload)))
    acts /\
    (* with a transfer in it *)
    In transfer_data transfer_payload /\
    (* which itself has transfer data *)
    In transfer_to transfer_data.(FA2Spec.txs) /\
    (* whose quantity is the quantity pooled *)
    transfer_to.(FA2Spec.amount) = msg_payload.(qty_pooled).

(* When the POOL entrypoint is successfully called, it emits a MINT call to the
    pool_token, with q * r_x / 1_000_000 in the payload *)
Definition pool_emits_mint (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload cstate' acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the call to POOL was successful *)
    msg = pool msg_payload ->
    receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
    (* in the acts list there is a MINT call with q * r_x / 1_000_000 in the payload *)
    exists mint_data mint_payload,
    (* there is a mint call in acts *)
    In
    (act_call
        (stor_pool_token cstate).(FA2Spec.token_address) (* calls the pool token address *)
        0 (* with amount 0 *)
        (serialize (FA2Spec.Mint mint_payload)))
    acts /\
    (* with has mint_data in the payload *)
    In mint_data mint_payload /\
    (* and the mint data has these properties: *)
    let r_x := get_rate msg_payload.(token_pooled) (stor_rates cstate) in
    mint_data.(FA2Spec.qty) = msg_payload.(qty_pooled) * r_x / 1_000_000 /\
    (* TODO perhaps also specify that the minted tokens go to pooler *)
    mint_data.(FA2Spec.mint_owner) = ctx.(ctx_from).

(* When the POOL entrypoint is successfully called, the TRANSFER and MINT transactions
    are the only transactions emitted by the contract *)
Definition pool_atomic (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload cstate' acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the call to POOL was successful *)
    msg = pool msg_payload ->
    receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
    (* we have a MINT call in acts and a TRANSFER call *)
    length acts = 2%nat.

(* When the POOL entrypoint is successfully called, tokens_held goes up appropriately *)
Definition pool_increases_tokens_held (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload qty token cstate' acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the call to POOL was successful *)
    msg = pool msg_payload ->
    qty = msg_payload.(qty_pooled) ->
    token = msg_payload.(token_pooled) ->
    receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
    (* in cstate', tokens_held has increased at token *)
    let old_bal := get_bal token (stor_tokens_held cstate) in
    let new_bal := get_bal token (stor_tokens_held cstate') in
    new_bal = old_bal + qty.

(* Specification of the UNPOOL entrypoint *)
(* When the UNPOOL entrypoint is called, the contract call fails if
    the token to be pooled is not in the family of semi-fungible tokens. *)
Definition unpool_entrypoint_check (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* forall calls to the Pool entrypoint *)
    msg = unpool (msg_payload) ->
    (* the receive function returns an error if the token to be pooled is not in the
       rates map held in the storage (=> is not in the semi-fungible family) *)
    FMap.find msg_payload.(token_unpooled) (stor_rates cstate) = None ->
    receive contract chain ctx cstate (Some msg) =
      Err(error_to_Error error_TOKEN_NOT_FOUND).

Definition unpool_entrypoint_check_2 (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate cstate' chain ctx msg msg_payload acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* forall calls to the Pool entrypoint *)
    msg = unpool (msg_payload) ->
    (* the receive function returns an error if the token to be pooled is not in the
       rates map held in the storage (=> is not in the semi-fungible family) *)
    receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
    exists r_x,
    FMap.find msg_payload.(token_unpooled) (stor_rates cstate) = Some r_x.

(* When the UNPOOL entrypoint is successfully called, it emits a BURN call to the
    pool_token, with q in the payload *)
Definition unpool_emits_burn (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload cstate' acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the call to UNPOOL was successful *)
    msg = unpool msg_payload ->
    receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
    (* in the acts list there is a BURN call with q in the payload *)
    exists burn_data burn_payload,
    (* there is a mint call in acts *)
    In
    (act_call
        (stor_pool_token cstate).(FA2Spec.token_address) (* calls the pool token address *)
        0 (* with amount 0 *)
        (serialize (FA2Spec.Retire burn_payload)))
    acts /\
    (* with has burn_data in the payload *)
    In burn_data burn_payload /\
    (* and burn_data has these properties: *)
    burn_data.(FA2Spec.retire_amount) = msg_payload.(qty_unpooled) /\
    (* the burned tokens go from the unpooler *)
    burn_data.(FA2Spec.retiring_party) = ctx.(ctx_from).

(* When the UNPOOL entrypoint is successfully called, it emits a TRANSFER call to the
    token in storage, with q * 1_000_000 / r_x tokens in the payload of the call *)
Definition unpool_emits_transfer (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload cstate' acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the call to UNPOOL was successful *)
    msg = unpool (msg_payload) ->
    receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
    (* in the acts list there is a transfer call with q tokens as the payload *)
    exists transfer_to transfer_data transfer_payload,
    (* there is a transfer call *)
    In
    (act_call
        (msg_payload.(token_unpooled).(FA2Spec.token_address)) (* call to the token address *)
        0 (* with amount = 0 *)
        (serialize (FA2Spec.Transfer transfer_payload)))
    acts /\
    (* with a transfer in it *)
    In transfer_data transfer_payload /\
    (* which itself has transfer data *)
    In transfer_to transfer_data.(FA2Spec.txs) /\
    (* whose quantity is the quantity pooled *)
    let r_x := get_rate msg_payload.(token_unpooled) (stor_rates cstate) in
    transfer_to.(FA2Spec.amount) = msg_payload.(qty_unpooled) * 1_000_000 / r_x.

(* When the UNPOOL entrypoint is successfully called, tokens_held goes down appropriately *)
Definition unpool_decreases_tokens_held (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload qty token cstate' acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the call to UNPOOL was successful *)
    msg = unpool msg_payload ->
    qty = msg_payload.(qty_unpooled) ->
    token = msg_payload.(token_unpooled) ->
    receive contract chain ctx cstate (Some msg) =
      Ok(cstate', acts) ->
    (* in cstate', tokens_held has increased at token *)
    let old_bal := get_bal token (stor_tokens_held cstate) in
    let new_bal := get_bal token (stor_tokens_held cstate') in
    new_bal = old_bal - qty.

(* If the TRADE entrypoint is called, token_in_trade and token_out_trade must both be
    part of the semi-fungible family for the trade to succeed. *)
Definition trade_entrypoint_check (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* forall calls to the Pool entrypoint *)
    msg = trade (msg_payload) ->
    (* the receive function returns an error if the token to be pooled is not in the
       rates map held in the storage (=> is not in the semi-fungible family) *)
    ((FMap.find msg_payload.(token_in_trade) (stor_rates cstate) = None) \/
    (FMap.find msg_payload.(token_out_trade) (stor_rates cstate) = None)) ->
    receive contract chain ctx cstate (Some msg) =
      Err(error_to_Error error_TOKEN_NOT_FOUND).

Definition trade_entrypoint_check_2 (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload cstate' acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* forall calls to the Pool entrypoint *)
    msg = trade (msg_payload) ->
    (* the receive function returns an error if the token to be pooled is not in the
       rates map held in the storage (=> is not in the semi-fungible family) *)
    receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
    exists x r_x r_y,
    ((FMap.find msg_payload.(token_in_trade) (stor_tokens_held cstate) = Some x) /\
    (FMap.find msg_payload.(token_in_trade) (stor_rates cstate) = Some r_x) /\
    (FMap.find msg_payload.(token_out_trade) (stor_rates cstate) = Some r_y)).

(* Specification of the TRADE entrypoint *)
(* When TRADE is successfully called, the trade is priced using the correct formula
    given by calculate_trade. The updated rate is also priced using the formula from
    calculate_trade. *)
Definition trade_pricing_formula (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload t_x t_y q cstate' acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the TRADE entrypoint was called succesfully *)
    msg = trade msg_payload ->
    t_x = msg_payload.(token_in_trade) ->
    t_y = msg_payload.(token_out_trade) ->
    t_x <> t_y ->
    q = msg_payload.(qty_trade) ->
    receive contract chain ctx cstate (Some msg) =
      Ok(cstate', acts) ->
    (* calculate the diffs delta_x and delta_y *)
    let delta_x :=
        (get_bal t_x (stor_tokens_held cstate')) - (get_bal t_x (stor_tokens_held cstate)) in
    let delta_y :=
        (get_bal t_y (stor_tokens_held cstate)) - (get_bal t_y (stor_tokens_held cstate')) in
    let rate_in := (get_rate t_x (stor_rates cstate)) in
    let rate_out := (get_rate t_y (stor_rates cstate)) in
    let k := (stor_outstanding_tokens cstate) in
    let x := get_bal t_x (stor_tokens_held cstate) in
    (* the diff delta_x and delta_y are correct *)
    delta_x = q /\
    delta_y = calc_delta_y rate_in rate_out q k x.

Definition trade_update_rates_formula (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload t_x t_y q cstate' acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the TRADE entrypoint was called succesfully *)
    msg = trade msg_payload ->
    t_x = msg_payload.(token_in_trade) ->
    t_y = msg_payload.(token_out_trade) ->
    t_x <> t_y ->
    q = msg_payload.(qty_trade) ->
    receive contract chain ctx cstate (Some msg) =
      Ok(cstate', acts) ->
    (* calculate the diffs delta_x and delta_y *)
    let rate_in := (get_rate t_x (stor_rates cstate)) in
    let rate_out := (get_rate t_y (stor_rates cstate)) in
    let k := (stor_outstanding_tokens cstate) in
    let x := get_bal t_x (stor_tokens_held cstate) in
    (* the new rate of t_x is correct *)
    let r_x' := calc_rate_in rate_in rate_out q k x in
    FMap.find t_x (stor_rates cstate') = Some r_x' /\
    (forall t, t <> t_x ->
        FMap.find t (stor_rates cstate') =
        FMap.find t (stor_rates cstate)).

(* When TRADE is successfully called, it emits a TRANSFER action of t_x in quantity q *)
Definition trade_emits_transfer_tx (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate cstate' chain ctx msg msg_payload acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the call to TRADE was successful *)
    msg = trade (msg_payload) ->
    receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
    (* in the acts list there is a transfer call with q tokens as the payload *)
    exists transfer_to transfer_data transfer_payload,
    (* there is a transfer call *)
    In
    (act_call
        (msg_payload.(token_in_trade).(FA2Spec.token_address)) (* call to the correct token address *)
        0 (* with amount = 0 *)
        (serialize (FA2Spec.Transfer transfer_payload)))
    acts /\
    (* with a transfer in it *)
    In transfer_data transfer_payload /\
    (* which itself has transfer data *)
    In transfer_to transfer_data.(FA2Spec.txs) /\
    (* whose quantity is the quantity traded, transferred to the contract *)
    transfer_to.(FA2Spec.amount) = msg_payload.(qty_trade) /\
    transfer_to.(FA2Spec.to_) = ctx.(ctx_contract_address).

(* transfers with delta_y given by calculate_trade function *)
Definition trade_emits_transfer_ty (contract : Contract Setup Msg State Error) : Prop :=
    forall bstate caddr cstate chain ctx msg msg_payload cstate' acts,
    (* reachable bstate *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the call to TRADE was successful *)
    msg = trade (msg_payload) ->
    receive contract chain ctx cstate (Some msg) =
      Ok(cstate', acts) ->
    (* in the acts list there is a transfer call with q tokens as the payload *)
    exists transfer_to transfer_data transfer_payload,
    (* there is a transfer call *)
    In
    (act_call
        (msg_payload.(token_out_trade).(FA2Spec.token_address)) (* call to the correct token address *)
        0 (* with amount = 0 *)
        (serialize (FA2Spec.Transfer transfer_payload)))
    acts /\
    (* with a transfer in it *)
    In transfer_data transfer_payload /\
    (* which itself has transfer data *)
    In transfer_to transfer_data.(FA2Spec.txs) /\
    (* whose quantity is the quantity traded, transferred to the contract *)
    let t_x := msg_payload.(token_in_trade) in
    let t_y := msg_payload.(token_out_trade) in
    let rate_in := (get_rate t_x (stor_rates cstate)) in
    let rate_out := (get_rate t_y (stor_rates cstate)) in
    let k := (stor_outstanding_tokens cstate) in
    let x := get_bal t_x (stor_tokens_held cstate) in
    let q := msg_payload.(qty_trade) in
    transfer_to.(FA2Spec.amount) = calc_delta_y rate_in rate_out q k x  /\
    transfer_to.(FA2Spec.to_) = ctx.(ctx_from).

(* Initialization specification *)
(* TODO HOW IS THE CONTRACT INITIALIZED *)
Definition initialized_with_nonzero_rates (contract : Contract Setup Msg State Error) : Prop :=
    forall chain bstate ctx setup cstate,
    (* bstate is reachable *)
    reachable bstate ->
    (* we call init successfully *)
    init contract chain ctx setup = Ok cstate ->
    (* then all rates are nonzero *)
    forall t r,
    FMap.find t (stor_rates cstate) = Some r ->
    r > 0.

(* we amalgamate each proposition in the specification into a single proposition *)
Definition is_structured_pool
    (C : Contract Setup Msg State Error) : Prop :=
    pool_entrypoint_check C /\
    pool_entrypoint_check_2 C /\
    pool_emits_transfer C /\
    pool_emits_mint C /\
    pool_atomic C /\
    pool_increases_tokens_held C /\
    unpool_entrypoint_check C /\
    unpool_entrypoint_check_2 C /\
    unpool_emits_burn C /\
    unpool_emits_transfer C /\
    unpool_decreases_tokens_held C /\
    trade_entrypoint_check C /\
    trade_entrypoint_check_2 C /\
    trade_pricing_formula C /\
    trade_update_rates_formula C /\
    trade_emits_transfer_tx C /\
    trade_emits_transfer_ty C /\
    initialized_with_nonzero_rates C.

(* A tactic to destruct is_sp if it's in the context of a proof *)
Tactic Notation "is_sp_destruct" :=
match goal with
    | is_sp : is_structured_pool _ |- _ =>
        unfold is_structured_pool in is_sp;
        destruct is_sp  as [pool_entrypoint_check_pf is_sp'];
        destruct is_sp' as [pool_entrypoint_check_2_pf is_sp'];
        destruct is_sp' as [pool_emits_transfer_pf is_sp'];
        destruct is_sp' as [pool_emits_mint_pf is_sp'];
        destruct is_sp' as [pool_atomic_pf is_sp'];
        destruct is_sp' as [pool_increases_tokens_held_pf is_sp'];
        destruct is_sp' as [unpool_entrypoint_check_pf is_sp'];
        destruct is_sp' as [unpool_entrypoint_check_2_pf is_sp'];
        destruct is_sp' as [unpool_emits_burn_pf is_sp'];
        destruct is_sp' as [unpool_emits_transfer_pf is_sp'];
        destruct is_sp' as [unpool_decreases_tokens_held_pf is_sp'];
        destruct is_sp' as [trade_entrypoint_check_pf is_sp'];
        destruct is_sp' as [trade_entrypoint_check_2_pf is_sp'];
        destruct is_sp' as [trade_pricing_formula_pf is_sp'];
        destruct is_sp' as [trade_update_rates_formula_pf is_sp'];
        destruct is_sp' as [trade_emits_transfer_tx_pf is_sp'];
        destruct is_sp' as [trade_emits_transfer_ty_pf initialized_with_nonzero_rates_pf]
end.

(* =============================================================================
 * The contract Metaspecification:
      We reason about a contract which satisfies the properties of the specification
      given here, showing that a contract which satisfies the specification also satisfies
      the properties here.
 * ============================================================================= *)

 Context {contract : Contract Setup Msg State Error}
 { is_sp : is_structured_pool contract }.

(* Demand Sensitivity :
    A trade for a given token increases its price relative to other constituent tokens,
    so that higher relative demand corresponds to a higher relative price.
    Likewise, trading one token in for another decreases the first's relative price in
    the pool, corresponding to slackened demand. This enforces the classical notion of
    supply and demand

    We prove that r_x' > r_x and forall t_z, r_z' = r_z.
*)
Lemma rate_decrease : forall r_x r_y delta_x k x,
    calc_rate_in r_x r_y delta_x k x < r_x.
Proof. Admitted.

Theorem demand_sensitivity :
    forall bstate caddr cstate t_x r_x,
    (* state is reachable *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* r_x is the rate of token t_x *)
    0 < r_x ->
    (FMap.find t_x (stor_rates cstate)) = Some r_x ->
    (* a trade of t_x for some t_y happens *)
    forall chain ctx msg msg_payload acts cstate',
        receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
        msg = trade msg_payload ->
        msg_payload.(token_in_trade) = t_x ->
        t_x <> msg_payload.(token_out_trade) ->
    (* new cstate induced by *)
    let r_x' := get_rate t_x (stor_rates cstate') in
    (* r_x' goes down while all other rates stay constant *)
    r_x' < r_x /\
    forall t,
    t <> t_x ->
    get_rate t (stor_rates cstate') = get_rate t (stor_rates cstate).
Proof.
    intros.
    is_sp_destruct.
    pose proof (trade_entrypoint_check_2_pf bstate caddr cstate chain ctx msg msg_payload
            cstate' acts H7 H8 H9 H13 H12).
    do 4 destruct H16. destruct H17.
    (* get the new rates *)
    pose proof (trade_update_rates_formula_pf bstate caddr cstate chain ctx msg msg_payload t_x (msg_payload.(token_out_trade)) (msg_payload.(qty_trade)) cstate' acts H7 H8 H9 H13 (eq_sym H14) (reflexivity (token_out_trade msg_payload)) H15 (reflexivity (qty_trade msg_payload)) H12).
    destruct H19.
    (*  *)
    split.
    -   unfold r_x'. unfold get_rate.
        replace (FMap.find t_x (stor_rates cstate'))
        with (Some
            (calc_rate_in
                (get_rate t_x (stor_rates cstate))
                (get_rate (token_out_trade msg_payload) (stor_rates cstate))
                (qty_trade msg_payload)
                (stor_outstanding_tokens cstate)
                (get_bal t_x (stor_tokens_held cstate)))).
        assert (r_x = (get_rate t_x (stor_rates cstate))).
        +   unfold get_rate.
            replace (FMap.find t_x (stor_rates cstate))
            with (Some r_x).
            reflexivity.
        +   rewrite H21.
            exact (rate_decrease
                (get_rate t_x (stor_rates cstate))
                (get_rate (token_out_trade msg_payload) (stor_rates cstate))
                (qty_trade msg_payload)
                (stor_outstanding_tokens cstate)
                (get_bal t_x (stor_tokens_held cstate))).
    -   intros. unfold get_rate.
        replace (FMap.find t (stor_rates cstate')) with (FMap.find t (stor_rates cstate));
        try exact (eq_sym (H20 t H21)).
        auto.
Qed.

(* Nonpathological prices
    As relative prices shift over time, a price that starts out nonzero never goes to
    zero or to a negative value.

    This is to avoid pathological behavior of zero or negative prices.

    Note, however, that prices can still get arbitrarily close to zero, like in the case
    of CPMMs.
*) (*
Theorem nonpathological_prices :
    forall bstate caddr cstate n,
    (* the state is reachable *)
    reachable bstate ->
    (* get the address *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* the statement *)
    forall t,
    (* token in the ledger => rate neq zero *)
    FMap.find t (stor_rates cstate) = Some n /\ n > 0 ->
    (* any state reachable through cstate has the same property *)
    forall bstate' cstate',
    reachable_through bstate bstate' ->
    contract_state bstate' caddr = Some cstate' ->
    (* the token still has an exchange rate greater than zero in the new state cstate' *)
    exists n',
    FMap.find t (stor_rates cstate) = Some n' /\ n' > 0.
Proof.
    intros.
    (* contract induction over the trace *)

*)

(* Functional non-depletion :
    No trade can empty the entire pool of tokens. This mimics properties of CPMMs
    currently, for which no trade can deplete any constituent token of any pool. The
    difference here is that we are willing to let individual, constituent tokens deplete,
    but do not allow the entire pool to deplete.

    This is because tokenized carbon credits can be consumed by being retired as offsets,
    so while we don't want the entire class of carbon credits to deplete from the pool by
    trading, we should enable individual credits to deplete.
*)
Theorem functional_non_depletion :
    forall bstate caddr cstate,
    (* state is reachable *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* there is liquidity *)
    (stor_outstanding_tokens cstate) > 0 ->
    (* a trade occurs *)
    forall chain ctx msg msg_payload acts cstate',
        receive contract chain ctx cstate (Some msg) = Ok(cstate', acts) ->
        msg = trade msg_payload ->
    (* there is liquidity *)
    (stor_outstanding_tokens cstate') > 0.
Proof. (*
    intros.
    pose proof (trade_entrypoint_check_2_pf bstate caddr cstate chain ctx msg msg_payload
            cstate' acts H7 H8 H9 H12 H11).
    do 4 destruct H13. destruct H14.
    rewrite H12 in H11. *)
    (* open up the receive function
    cbn in H7.
    destruct
        (FMap.find (token_in_trade msg_payload) (tokens_held cstate)),
        (FMap.find (token_in_trade msg_payload) (rates cstate)),
        (FMap.find (token_out_trade msg_payload) (rates cstate)) in H7;
    cbn in H7; inversion H7.
    destruct (RPMM.get_bal (token_out_trade msg_payload) (tokens_held cstate) <?
           calc_delta_y e n0 (qty_trade msg_payload) (outstanding_tokens cstate) n)%N in H7;
    cbn in H7; inversion H7.
    clear H7 H13 H15.*)
    (*  *)
    Admitted.

(* Swap rate consistency :
    For tokens tau_x, tau_y and tau_z, the exchange rate from tau_x to tau_y, and then to
    tau_z, must not be greater than the exchange rate from tau_x to token tau_z.

    As we will see, structured pools always price trades consistently, but because of how
    prices update over time it is nontrivial to show that this is true in practice.

    In particular, price consistency means that it is never profitable to trade in a loop,
    e.g. tau_x to tau_y, and back to tau_x, which is important so that there are no
    arbitrage oportunities internal to the pool.
*)
Theorem swap_rate_consistency :
    forall bstate caddr cstate,
    (* state is reachable *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (* a trade from t_x to t_z *)
    forall t_x t_z qty_trade
        chain ctx msg_xz msg_payload_xz acts_xz cstate_xz,
        receive contract chain ctx cstate msg_xz = Ok (cstate_xz, acts_xz) ->
        msg_xz = Some (trade msg_payload_xz) ->
        msg_payload_xz = Build_trade_data t_x t_z qty_trade ->
    (* a trade from t_x to t_y *)
    forall t_y msg_xy msg_payload_xy acts_xy cstate_xy,
        receive contract chain ctx cstate msg_xy = Ok (cstate_xy, acts_xy) ->
        msg_xy = Some (trade msg_payload_xy) ->
        msg_payload_xy = Build_trade_data t_x t_y qty_trade ->
    (* which yields delta_y tokens in t_y *)
    let delta_y :=
        (get_bal t_y (stor_tokens_held cstate)) -
        (get_bal t_y (stor_tokens_held cstate_xy)) in
    (* followed by a trade of delta_y from t_y to t_z *)
    forall msg_yz msg_payload_yz acts_yz cstate_yz chain' ctx',
        receive contract chain' ctx' cstate_xy msg_yz = Ok (cstate_yz, acts_yz) ->
        msg_yz = Some (trade msg_payload_yz) ->
        msg_payload_yz = Build_trade_data t_y t_z delta_y ->
    (* the output delta_z *)
    let delta_z_direct :=
        (get_bal t_z (stor_tokens_held cstate)) -
        (get_bal t_z (stor_tokens_held cstate_xz)) in
    let delta_z_indirect :=
        (get_bal t_z (stor_tokens_held cstate)) -
        (get_bal t_z (stor_tokens_held cstate_yz)) in
    (* the direct trade yielded more t_z than the indirect trade *)
    delta_z_direct > delta_z_indirect.
Proof. Admitted.

(* Arbitrage sensitivity :
    If an opportunity for arbitrage exists due to some external market pricing a
    constituent token differently from the structured pool, the arbitrage loop can be
    closed with one sufficiently large transaction.

    In our case, this happens because prices adapt through trades due to demand
    sensitivity or the pool depletes in that particular token.
*)
Theorem arbitrage_sensitivity :
    forall bstate caddr cstate t_x,
    (* state is reachable *)
    reachable bstate ->
    (* the contract address is caddr with state cstate *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    contract_state bstate caddr = Some cstate ->
    (*  *)
    forall external_price
    chain ctx msg msg_payload cstate' acts,
    receive contract chain ctx cstate msg = Ok(cstate', acts) ->
    msg = Some(trade msg_payload) ->
    exists trade_qty,
    msg_payload.(qty_trade) = trade_qty ->
    (* price stabilizes or liquidity depletes *)
    FMap.find t_x (stor_rates cstate') = Some(external_price) \/
    FMap.find t_x (stor_tokens_held cstate') = None.
Proof. Admitted.

(* Pooled consistency
    The sum of all the constituent, pooled tokens, multiplied by their value in terms of
    pooled tokens, always equals the total number of outstanding pool tokens. That is,
    pool tokens are never under- or over-collateralized.
*)
Definition fold_fn (rates : FMap token exchange_rate) (tokens_held : FMap token N)
    (n : N) (k : token) : N :=
    let rate :=
        match FMap.find k rates with
        | Some r => r
        | None => 0
        end in
    let qty_held :=
        match FMap.find k tokens_held with
        | Some r => r
        | None => 0
        end in
    rate * qty_held / 1_000_000.

Definition sum_over_tokens
    (rates : FMap token exchange_rate) (tokens_held : FMap token N) : N :=
    (* get the list of keys *)
    let token_family := (FMap.keys rates) in
    (* fold over the list *)
    List.fold_left
        (fold_fn rates tokens_held)
        token_family
        0.

Theorem pooled_consistency :
    forall bstate caddr cstate,
    (* state is reachable *)
    reachable bstate ->
    (* the contract address is caddr *)
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    (* the contract state is cstate *)
    contract_state bstate caddr = Some cstate ->
    (* The sum of all the constituent, pooled tokens, multiplied by their value in terms
    of pooled tokens, always equals the total number of outstanding pool tokens. *)
    sum_over_tokens (stor_rates cstate) (stor_tokens_held cstate) =
        (stor_outstanding_tokens cstate).
Proof. Admitted.

End AbstractSpecification.


Require Import Util LengthEq IL RenamedApart LabelsDefined OptionR.
Require Import Keep Drop Take Restrict SetOperations OUnion.
Require Import Annotation Liveness.Liveness Coherence Delocation.
Require Import AddParam AddAdd MoreListSet DelocationAlgo DelocationAlgoIsCalled.
Require Import PartialOrder.

Set Implicit Arguments.

Local Hint Extern 10 (forall _ _, get (snd ⊝ computeParametersF ?DL ?ZL ?AP ?F ?als) _ _ -> ❬?LVb❭ = ❬_❭)
=> eapply computeParametersF_length : len.

Local Hint Extern 1 =>
match goal with
  [ |- context [ ❬snd (computeParameters _ _ _ _ )❭ ] ] =>
  rewrite computeParameters_length; eauto with len
end : len.

Lemma computeParameters_trs b ZL Lv AP s lv
: live_sound Imperative ZL Lv s lv
  -> noUnreachableCode (isCalled b) s
  -> poLe AP (Lv \\ ZL)
  -> length Lv = length ZL
  -> length ZL = length AP
  -> trs (restr (getAnn lv) ⊝ (zip ominus' (Lv \\ ZL)
                                  (snd (computeParameters (Lv \\ ZL) AP s lv))))
        s lv
        (fst (computeParameters (Lv \\ ZL) AP s lv)).
Proof.
  intros LIVE NOUR P LEN1 LEN2.
  revert_except LIVE.
  induction LIVE; simpl in *; intros; repeat let_case_eq;
    repeat let_pair_case_eq; inv NOUR; simpl in *.
  - eapply trsExp, trs_monotone_DL.
    + eapply IHLIVE; eauto 10 using addParam_Subset with len.
    + rewrite restrict_comp_meet.
      assert (SEQ:lv ∩ (getAnn al \ singleton x) [=] getAnn al \ singleton x) by
          (clear - H0; cset_tac).
      rewrite SEQ. eapply restrict_zip_ominus'; eauto with len.
      eapply PIR2_not_in; [ eapply computeParameters_AP_LV; eauto with len
                          | eauto with len].
  - econstructor.
    + eapply trs_monotone_DL; eauto.
      eapply restrict_subset2; eauto.
      eapply zip_ominus_contra; eauto using PIR2_zip_ounion with len.
    + eapply trs_monotone_DL; eauto using PIR2_zip_ounion' with len.
      eapply restrict_subset2; eauto with len.
      eapply zip_ominus_contra; eauto using PIR2_zip_ounion' with len.
  - inv_get.
    econstructor.
    + eapply restrict_get_Some.
      eapply zip_get_eq. eapply zip_get; eauto.
      eapply keep_Some; eauto. simpl. reflexivity.
      rewrite <- H1. eauto with cset.
  - econstructor.
  - len_simpl.
    assert (LenHelp1:❬(getAnn ⊝ als ++ Lv) \\ (fst ⊝ F ++ ZL)❭ =
                     ❬snd
                        (computeParameters ((getAnn ⊝ als ++ Lv) \\ (fst ⊝ F ++ ZL))
                                           (tab {} ‖F‖ ++ AP) t alb)❭). {
      rewrite computeParameters_length; eauto; revert LEN1 LEN2 H; clear_all;
        eauto with len.
    }
    assert (LenHelp2:
              forall (n : nat) (aa : 〔؟ ⦃var⦄〕),
                get (snd ⊝ computeParametersF F als Lv ZL AP) n aa ->
                ❬aa❭ =
                ❬snd
                   (computeParameters ((getAnn ⊝ als ++ Lv) \\ (fst ⊝ F ++ ZL))
                                      (tab {} ‖F‖ ++ AP) t alb)❭). {
      eapply computeParametersF_length; eauto.
      rewrite <- LenHelp1. eauto with len. eauto with len.
    }
    lnorm. econstructor.
    + eauto with len.
    + eauto with len.
    + rewrite map_length. rewrite take_length_le; eauto.
      rewrite zip_length2; [eauto 20 with len|].
      rewrite fold_zip_ounion_length; eauto.
    + intros. inv_get. simpl.
      eapply trs_monotone_DL.
      * eapply H1; eauto using PIR2_Subset_tab_extend with len.
      * { rewrite (take_eta (length F) (zip ominus' _ _)).
          do 2 rewrite List.map_app.
          eapply PIR2_app.
          - rewrite restrict_disj.
            + eapply restrict_subset2; eauto.
              do 2 rewrite take_zip.
              rewrite take_app_eq; [|eauto with len].
              rewrite take_app_eq; [|eauto with len].
              eapply ominus'_Some_oto_list.
              eapply PIR2_take. eapply PIR2_addAdds3.
              eauto with len.
              eapply PIR2_combineParams_get;
                [ eapply computeParametersF_length_pair; eauto with len
                | eauto with len
                | eapply zip_get; eauto
                | reflexivity ].
            + intros.
              inv_get.
              Opaque to_list.

              pose proof (H10 _ H12).
              edestruct computeParameters_isCalledFrom_get_Some; try eapply H6;
                try eassumption;
                [ intros; edestruct H2; eauto
                | eauto with len
                | dcr; subst ].
              pose proof (H10 _ H15).
              edestruct computeParameters_isCalledFrom_get_Some; try eapply H7;
                try eassumption;
                [ intros; edestruct H2; eauto
                | eauto with len
                | dcr; subst ].
              simpl.
              repeat rewrite of_list_app.
              repeat rewrite of_list_3.
              eapply disj_minus.
              rewrite (meet_comm _ (getAnn lvs)) at 1.
              rewrite union_meet_distr_r. rewrite union_meet_distr_r.
              eapply union_incl_split.
              eapply incl_union_incl_minus. eapply incl_union_left.
              eapply incl_meet_split. eapply incl_union_right.
              eapply incl_list_union; [ eapply map_get_1; try eapply H5 | ].
              clear_all; cset_tac.
              clear_all; cset_tac.
              eapply incl_union_incl_minus. eapply incl_union_left.
              assert (x0 ⊆ list_union (oget ⊝ take ❬F❭ (olu F als Lv ZL AP t alb))). {
                eapply incl_list_union.
                eapply map_get_1; eauto.
                eapply get_take; try eapply H6; eauto. reflexivity.
              }
              clear - H17.
              cset_tac.
          - rewrite restrict_comp_meet.
            pose proof (H10 _ H12).
            edestruct computeParameters_isCalledFrom_get_Some; try eapply H6;
              eauto with len; dcr; subst.
            intros; edestruct H2; eauto.
            simpl.

            repeat rewrite of_list_app. repeat rewrite of_list_3.
            set (XX:=(list_union (oget
                                ⊝ take ❬F❭
                                    (olist_union (snd ⊝ computeParametersF F als Lv ZL AP)
                                     (snd
                                        (computeParameters ((getAnn ⊝ als ++ Lv) \\ (fst ⊝ F ++ ZL))
                                                           (tab {} ‖F‖ ++ AP) t alb))))
                                 ∪ list_union (fst ∘ of_list ⊝ F))).

            assert (lvsEQ:
                      lv ∩ (getAnn lvs \ (of_list (fst Zs) ∪
                                                  (XX ∩ (getAnn lvs \ of_list (fst Zs)) ∪ x)))
                         [=]
                         (getAnn lvs \ (of_list (fst Zs) ∪
                                                (XX ∩ (getAnn lvs \ of_list (fst Zs)) ∪ x)))). {
              rewrite meet_comm. symmetry. eapply incl_meet.
              rewrite <- H3. subst XX.
              rewrite <- H14.
              clear_all; cset_tac.
            }
            rewrite lvsEQ.
            rewrite restrict_disj.
            + eapply restrict_subset2; eauto.
              do 2 rewrite drop_zip.
              repeat rewrite drop_length_ass; eauto with len.
              eapply zip_ominus_contra; eauto with len.
              eapply PIR2_drop; eauto.
              eapply PIR2_addAdds3; eauto with len.
              eapply PIR2_combineParams_get;
                [ | eauto with len | eauto using zip_get_eq | reflexivity].
              eapply computeParametersF_length_pair; eauto with len.
            + intros. inv_get.
              unfold ominus', lminus in H15.
              destruct x3; invc H15. simpl in *.
              subst XX.
              revert H5 H6. clear_all.
              intros; hnf; intros. cset_tac'.
              * eapply H8; eauto.
                eapply incl_list_union. eapply map_get_1; eauto. reflexivity.
                eauto.
              * eapply H0; eauto.
                eapply incl_list_union.
                eapply map_get_1.
                eapply get_take; eauto using get_range. reflexivity.
                eauto.
        }
    + eapply trs_monotone_DL.
      eapply IHLIVE; eauto using PIR2_Subset_tab_extend with len.
      * { rewrite (take_eta (length F) (zip ominus' _ _)).
          rewrite List.map_app.
          eapply PIR2_app.
          - eapply PIR2_restrict.
            do 2 rewrite take_zip.
            rewrite take_app_eq; [|eauto with len].
            rewrite take_app_eq; [|eauto with len].
            eapply ominus'_Some_oto_list.
            eapply PIR2_take. eapply PIR2_addAdds3.
            eauto with len.
            eapply PIR2_combineParams; [| reflexivity].
            eapply computeParametersF_length_pair; eauto with len.
          - eapply restrict_subset2; eauto.
            do 2 rewrite drop_zip.
            repeat (rewrite drop_length_ass; [| eauto with len]).
            eapply zip_ominus_contra.
            eapply PIR2_drop; eauto.
            eapply PIR2_addAdds3. eauto with len.
            eapply PIR2_combineParams; [| reflexivity].
            eapply computeParametersF_length_pair; eauto with len.
        }
Qed.

Lemma is_trs b s lv
: live_sound Imperative nil nil s lv
  -> noUnreachableCode (isCalled b) s
  -> trs nil s lv (fst (computeParameters nil nil s lv)).
Proof.
  intros.
  assert (snd (computeParameters nil nil s lv) = nil). {
    exploit computeParameters_AP_LV; eauto.
    inv H1; eauto.
  }
  exploit computeParameters_trs; eauto; try reflexivity.
Qed.