Require Import VST.floyd.base.
Require Import VST.floyd.val_lemmas.
Local Open Scope logic.

Hint Rewrite <- prop_and : gather_prop.

Lemma gather_prop_left {A}{NA: NatDed A}:
  forall P Q R,  !! P && (!! Q && R) = !!(P/\Q) && R.
Proof. intros. rewrite <- andp_assoc. rewrite <- prop_and; auto.
Qed.

Lemma gather_prop_right {A}{NA: NatDed A}:
  forall P Q R,  R && !! P && !! Q = !!(P/\Q) && R.
Proof. intros. rewrite andp_assoc. rewrite andp_comm.  rewrite <- prop_and; auto.
Qed.
Hint Rewrite gather_prop_left gather_prop_right : gather_prop.

Lemma andp_in_order1 {A}{NA: NatDed A}:
  forall P Q, P && Q = P && (P --> Q).
Proof.
  intros.
  apply pred_ext.
  + apply andp_derives; auto.
    apply imp_andp_adjoint.
    apply andp_left1; auto.
  + apply andp_right.
    - apply andp_left1; auto.
    - apply modus_ponens.
Qed.

Lemma andp_in_order2 {A}{NA: NatDed A}:
  forall P Q, P && Q = Q && (Q --> P).
Proof.
  intros.
  rewrite (andp_comm P Q).
  apply andp_in_order1.
Qed.

Lemma andp_right1{A}{NA: NatDed A}:
  forall P Q R, P |-- Q -> P && Q |-- R -> P |-- Q && R.
Proof.
  intros.
  rewrite andp_in_order1.
  apply andp_right; auto.
  apply imp_andp_adjoint; auto.
Qed.

Lemma andp_right2{A}{NA: NatDed A}:
  forall P Q R, P |-- R -> P && R |-- Q -> P |-- Q && R.
Proof.
  intros.
  rewrite andp_comm.
  apply andp_right1; auto.
Qed.

Definition not_a_prop {A} (P: A) := True.

Ltac not_a_prop := match goal with
  | |- not_a_prop  (prop _) => fail 1
  | |- _ => apply Coq.Init.Logic.I
end.

Lemma flip_prop {A}{NA: NatDed A}: forall P Q,
      not_a_prop P -> (P&& !! Q = !! Q && P).
Proof. intros. apply andp_comm. Qed.

Hint Rewrite @flip_prop using not_a_prop : gather_prop.

Lemma gather_prop3 {A}{NA: NatDed A}:
  forall P Q R,  not_a_prop R -> not_a_prop Q -> R && (!! P && Q) = !!P && (R && Q).
Proof. intros. rewrite andp_comm. rewrite andp_assoc.
        rewrite (andp_comm Q); auto.
Qed.

Hint Rewrite @gather_prop3 using not_a_prop : gather_prop.

Lemma gather_prop4 {A}{NA: NatDed A}:
  forall P Q R,  not_a_prop R -> not_a_prop Q -> (!!P && R) && Q = !!P && (R && Q).
Proof. intros. rewrite andp_assoc. auto.
Qed.
Hint Rewrite @gather_prop4 using not_a_prop : gather_prop.

Lemma gather_prop5 {A}{NA: NatDed A}:
  forall P Q R,  not_a_prop R -> not_a_prop Q -> (R && !!P && Q) = !!P && (R && Q).
Proof. intros. rewrite andp_assoc. rewrite andp_comm. rewrite andp_assoc.
  f_equal; apply andp_comm.
Qed.
Hint Rewrite @gather_prop5 using not_a_prop : gather_prop.

Hint Rewrite @sepcon_andp_prop @sepcon_andp_prop' : gather_prop.

(*Hint Rewrite <- sepcon_assoc : gather_prop.*)

Lemma go_lower_lem1:
  forall (P1 P: Prop) (QR PQR: mpred),
      (P1 -> prop P && QR |-- PQR) ->
      (prop (P1 /\ P ) && QR |-- PQR).
Proof.
 intros.
 apply derives_extract_prop; intros [? ?].
 apply derives_trans with (!!P && QR).
 apply andp_right; auto. apply prop_right; auto.
 apply H; auto.
Qed.

Lemma go_lower_lem1':
  forall (P1 P2 P: Prop) (QR PQR: mpred),
      (prop (P1 /\ (P2 /\ P)) && QR |-- PQR) ->
      (prop ((P1 /\ P2) /\ P ) && QR |-- PQR).
Proof.
 intros.
 eapply derives_trans;  [ | apply H].
 apply andp_derives; auto.
 apply prop_derives; intuition.
Qed.

(* These versions can sometimes take minutes,
   when A and B can't be unified
Hint Extern 1 (_ |-- _) => (simple apply (@derives_refl mpred _) ) : cancel.
Hint Extern 1 (_ |-- |> _) => (simple apply (@now_later mpred _ _) ) : cancel.
*)

Hint Extern 2 (?A |-- ?B) => (constr_eq A B; simple apply derives_refl) : cancel.
Hint Extern 2 (?A |-- |> ?B) => (constr_eq A B; simple apply now_later) : cancel.

Lemma cancel1_start:
 forall P Q : mpred,
   P |-- Q * emp ->
   P |-- Q.
Proof. Set Printing All. intros. rewrite sepcon_emp in H; auto.
Qed.

Lemma cancel1_here:
  forall P P' Q1 Q2 Q3 : mpred,
  P' |-- Q2 ->
  P |-- Q1 * Q3 ->
  P * P' |-- Q1 * Q2 * Q3.
Proof.
intros. rewrite (sepcon_comm Q1).
rewrite sepcon_assoc.  rewrite sepcon_comm. apply sepcon_derives; auto.
Qed.

Lemma cancel1_next:
  forall P Q1 Q2 Q3 : mpred,
   P |-- Q1 * (Q2 * Q3) ->
   P |-- Q1 * Q2 * Q3.
Proof. intros. rewrite sepcon_assoc; auto. Qed.

Lemma cancel1_last:
  forall P P' Q2 Q3 : mpred,
  P' |-- Q2 ->
  P |-- Q3 ->
  P * P' |-- Q2 * Q3.
Proof.
 intros. rewrite sepcon_comm; apply sepcon_derives; auto.
Qed.

Lemma cancel1_finish1:
  forall P Q1 Q2 Q3 : mpred,
   P |-- Q1 * Q2 * Q3 ->
   P |-- Q1 * (Q2 * Q3).
Proof.
 intros. rewrite <- sepcon_assoc. auto.
Qed.

Lemma cancel1_finish2:
  forall P Q : mpred,
    P |-- Q ->
   P |-- Q * emp.
Proof. intros. rewrite sepcon_emp; auto.
Qed.

Ltac cancel1 :=
 first [
   simple apply cancel1_here; [
    try match goal with H := _ : list mpred |- _ => clear H end; (*
      this line is to work around Coq 8.4 bug,
      Anomaly: undefined_evars_of_term *)
    solve [eauto with nocore cancel]
   | ]
 | simple apply cancel1_next; cancel1
 | simple apply cancel1_last; [
    try match goal with H := _ : list mpred |- _ => clear H end; (*
      this line is to work around Coq 8.4 bug,
      Anomaly: undefined_evars_of_term *)
    solve [eauto with nocore cancel] | ]
 ].

Ltac cancel2 :=
  simple apply cancel1_start;
  cancel1;
  repeat simple apply cancel1_finish1;
  try simple apply cancel1_finish2.

Ltac lift1 a e1 rho  :=
 match e1 with
 | lift0 rho => constr:(a)
 | lift0 ?a1 => constr: (lift0 (a a1))
 | _ => constr:(lift1 a e1)
 end.

Ltac lift2 a e1 e2 rho :=
 match e1 with
 |  lift0 ?a1 => lift1 (a a1) e2 rho
 | _ => constr:(lift2 a e1 e2)
 end.

Ltac lift3 a e1 e2 e3 rho :=
 match e1 with
 |  lift0 ?a1 => lift2 (a a1) e2 e3 rho
 | _ => constr:(lift3 a e1 e2 e3)
 end.

Ltac lift4 a e1 e2 e3 e4 rho :=
 match e1 with
 |  lift0 ?a1 => lift3 (a a1) e2 e3 e4 rho
 | _ => constr:(lift4 a e1 e2 e3 e4)
 end.

Ltac abstract_env rho P :=
  match P with
   | @emp mpred _ _ => constr:(@emp (environ->mpred) _ _)
   | @sepcon mpred _ _ ?e1 ?e2 =>
      let e1' := abstract_env rho e1 in let e2' := abstract_env rho e2
       in constr:(@sepcon (environ->mpred) _ _ e1' e2')
   | ?a0 ?a1 ?a2 ?e1 ?e2 ?e3 ?e4 =>
      let e1' := abstract_env rho e1  in let e2' := abstract_env rho e2 in let e3' := abstract_env rho e3 in let e4' := abstract_env rho e4
      in lift3 (a0 a1 a2) e1' e2' e3' e4' rho
   | ?a0 ?a1 ?e1 ?e2 ?e3 ?e4 =>
      let e1' := abstract_env rho e1 in let e2' := abstract_env rho e2 in let e3' := abstract_env rho e3 in let e4' := abstract_env rho e4
      in lift3 (a0 a1) e1' e2' e3' e4' rho
   | ?a0 ?e1 ?e2 ?e3 ?e4 =>
      let e1' := abstract_env rho e1 in let e2' := abstract_env rho e2 in let e3' := abstract_env rho e3 in let e4' := abstract_env rho e4
      in lift4 a0 e1' e2' e3' e4' rho
   | ?a0 ?e1 ?e2 ?e3 =>
      let e1' := abstract_env rho e1 in let e2' := abstract_env rho e2 in let e3' := abstract_env rho e3
      in lift3 a0 e1' e2' e3' rho
   | ?a0 ?e1 ?e2 =>
      let e1' := abstract_env rho e1 in let e2' := abstract_env rho e2
      in lift2 a0 e1' e2' rho
   | ?a0 ?e1 => let e1' := abstract_env rho e1 in lift1 a0 e1' rho
   | rho => constr: (lift1)
   | ?a => constr:(lift0 a)
   end.

Lemma cancel_frame0{A}{ND: NatDed A}{SL: SepLog A}:
  forall rho: environ, emp rho |-- fold_right sepcon emp nil rho.
Proof. intro; apply derives_refl. Qed.

Lemma cancel_frame0_low:
  emp |-- fold_right_sepcon nil.
Proof.  apply derives_refl. Qed.

Lemma cancel_frame2: forall (P Q: environ->mpred) F (rho: environ),
     Q rho |-- 	fold_right sepcon emp F rho ->
    (P * Q) rho |-- fold_right sepcon emp (P::F) rho.
Proof. intros. simpl. apply sepcon_derives; auto.
Qed.

Lemma cancel_frame2_low: forall (P Q: mpred) F,
     Q  |-- fold_right_sepcon F  ->
    (P * Q) |-- fold_right_sepcon (P::F).
Proof. intros. apply sepcon_derives; auto.
Qed.

Lemma cancel_frame1: forall (P: environ->mpred) (rho: environ),
         P rho |-- fold_right sepcon emp (P::nil) rho.
Proof. intros. unfold fold_right. rewrite sepcon_emp; apply derives_refl.
Qed.

Lemma cancel_frame1_low: forall (P: mpred),
         P |-- fold_right_sepcon (P::nil).
Proof. intros. unfold fold_right_sepcon. rewrite sepcon_emp; apply derives_refl.
Qed.

Ltac fixup_lifts :=
 repeat
 match goal with
 | |- context[@lift0 mpred] => change (@lift0 mpred) with (@liftx (LiftEnviron mpred))
 | |- context[@lift1 ?A] => change (@lift1 A mpred) with (@liftx (Tarrow A (LiftEnviron mpred)))
 | |- context[@lift2 ?A ?B] =>  change (@lift2 A B mpred) with (@liftx (Tarrow A (Tarrow B (LiftEnviron mpred))))
 | |- context[@lift3 ?A ?B ?C] => change (@lift3 A B C mpred) with (@liftx (Tarrow A (Tarrow B (Tarrow C (LiftEnviron mpred)))))
 | |- context[@lift4 ?A ?B ?C ?D] => change (@lift4 A B C D mpred) with (@liftx (Tarrow A (Tarrow B (Tarrow C (Tarrow D (LiftEnviron mpred))))))
 end.

Fixpoint fold_right_sepconx (l: list mpred) : mpred :=
match l with
| nil => emp
| a::nil => a
| a::b => a * fold_right_sepconx b
end.

Definition fold_left_sepconx (l: list mpred) : mpred :=
match l with
| nil => emp
| a::l => (fix fold_left_sepconx (a: mpred) (l: list mpred) {struct l}: mpred :=
          match l with
          | nil => a
          | b :: l => fold_left_sepconx (sepcon a b) l
          end) a l
end.

Lemma fold_right_sepconx_eq:
  forall l, fold_right_sepconx l = fold_right_sepcon l.
Proof.
induction l; simpl; auto.
rewrite IHl.
destruct l; simpl; auto. rewrite sepcon_emp; auto.
Qed.

Lemma fold_left_sepconx_eq:
  forall l, fold_left_sepconx l = fold_right_sepcon l.
Proof.
  intros.
  rewrite <- fold_right_sepconx_eq.
  destruct l; auto.
  revert m; induction l; intros.
  + auto.
  + simpl in *.
    rewrite <- IHl.
    clear IHl.
    revert m a; induction l; intros.
    - auto.
    - simpl.
      rewrite sepcon_assoc.
      rewrite IHl.
      auto.
Qed.

Lemma fold_right_sepconx_eqx:
  forall A B, A |-- fold_right_sepconx B -> A |-- fold_right_sepcon B.
Proof.
intros.
rewrite <- fold_right_sepconx_eq; auto.
Qed.

Ltac unfold_right_sepcon A :=
 lazymatch A with
 | (?B * ?C)%logic => let x := unfold_right_sepcon C
                               in let y := constr:(B :: x)
                               in y
 | ?D => let y := constr:(D::nil) in y
end.

Ltac cancel_frame :=
match goal with
| |- _ |-- fold_right_sepcon _  => (* setup *)
   rewrite !sepcon_assoc; cancel_frame
| F := ?v |- ?A |-- fold_right_sepcon ?F  => (* fast way *)
   is_evar v;
   apply fold_right_sepconx_eqx;
   let w := unfold_right_sepcon A
    in instantiate (1:=w) in (Value of F);
    unfold F;
    unfold fold_right_sepconx;
    simple apply derives_refl
(*
| |- _ |-- fold_right_sepcon ?F  =>  (* slow way *)
   repeat apply cancel_frame2_low;
    try (unfold F; apply cancel_frame0_low);
    try (unfold F; apply cancel_frame1_low)
*)
| |- ?P |-- fold_right _ _ ?F ?rho  =>
     let P' := abstract_env rho P in
       change ( P' rho |-- fold_right sepcon emp F rho);
   fixup_lifts; cbv beta;
    repeat rewrite sepcon_assoc;
   repeat match goal with |- (_ * _) _ |-- _ =>
                   apply cancel_frame2
                    end;
    try (unfold F; apply cancel_frame1);
    try (instantiate (1:=nil) in (Value of F); unfold F; apply cancel_frame0)
 end.

Ltac pull_left A :=
 (* For some reason in Coq 8.4pl3 and perhaps other versions,
  this works better than the version in log_normalize
  which is simply,
   repeat rewrite <- (pull_right A) || rewrite <- (pull_right0 A)
  and which sometimes fails when the terms get complicated.
 *)
  repeat match goal with
  | |- context [?Q * ?R * A] => rewrite <- (pull_right A Q R)
  | |- context [?Q * A] => rewrite <- (pull_right0 A Q)
  end.

Lemma cancel_left: forall P Q R: mpred,
   Q |-- R -> P * Q |-- P * R.
Proof.
intros; apply sepcon_derives; auto.
Qed.

Lemma pull_left_special: forall A B C : mpred,
    (B * (A * C)) = (A * (B * C)).
Proof.
intros. rewrite sepcon_comm. rewrite sepcon_assoc. f_equal.
 apply sepcon_comm.
Qed.

Lemma pull_left_special0: forall A B : mpred,
    (B * A) = (A * B).
Proof.
intros; apply sepcon_comm.
Qed.

Ltac qcancel P :=
 lazymatch P with
 | sepcon ?A ?B =>
     match goal with |- _ |-- ?Q =>
       try match Q with context [A] =>
        let a := fresh "A" in set (a:=A);
         rewrite ?(pull_left_special0 a), ?(pull_left_special a);
         apply cancel_left;
         clear a
       end;
       qcancel B
     end
 | ?A =>
     try match goal with |- _ |-- ?Q =>
       lazymatch Q with context [A] =>
        let a := fresh "A" in set (a:=A);
         rewrite ?(pull_left_special0 a), ?(pull_left_special a);
         rewrite ?(pull_left_special0 A), ?(pull_left_special A);
         apply cancel_left;
         clear a
      end
     end
 end.

Ltac is_Type_or_type T :=
  match type of T with
  | Type => idtac
  | type => idtac
  end.

Lemma fun_equal: forall {A B} (f g : A -> B) (x y : A),
  f = g -> x = y -> f x = g y.
Proof. congruence. Qed.

Lemma fun_equal': forall {A B} (f g : forall (x:A), B x) (y : A),
  f = g -> f y = g y.
Proof. congruence. Qed.

Ltac ecareful_unify :=
  match goal with
  | |- ?X = ?X' => first [is_Type_or_type X | is_evar X | is_evar X' | constr_eq X X']; reflexivity
  | |- ?F _ = ?F' _ => first [apply fun_equal | apply fun_equal' with (f := F)]; revgoals; solve[ecareful_unify]
  end; idtac.

Ltac careful_unify :=
  match goal with
  | |- ?X = ?X' => first [is_Type_or_type X | constr_eq X X']; reflexivity
  | |- ?F _ = ?F' _ => first [apply fun_equal | apply fun_equal' with (f := F)]; revgoals; solve[careful_unify]
  end; idtac.

Ltac cancel :=
  rewrite ?sepcon_assoc;
  repeat match goal with |- ?A * _ |-- ?B * _ =>
     constr_eq A B;  simple apply (cancel_left A)
  end;
  match goal with |- ?P |-- _ => qcancel P end;
  repeat first [rewrite emp_sepcon | rewrite sepcon_emp];
  try match goal with |- ?A |-- ?B =>
       constr_eq A B; simple apply (derives_refl A)
  end;
  match goal with |- ?P |-- _ =>
   (* The "emp" is a marker to notice when one complete pass has been made *)
   rewrite <- (emp_sepcon P)
  end;
  repeat rewrite <- sepcon_assoc;
  repeat match goal with
    | |- sepcon _ emp |-- _ => fail 1
    | |- sepcon _ TT |-- _ => pull_left (@TT mpred _)
    | |- sepcon _ ?P' |-- _ => first [ cancel2 | pull_left P' ]
   end;
  repeat first [rewrite emp_sepcon | rewrite sepcon_emp];
  pull_left (@TT mpred _);
  first [ simpl; apply derives_refl'; solve [careful_unify]
            (* this is NOT a _complete_ tactic;
                 for example, "simple apply derives_refl" would be more complete.  But that
                 tactic can sometimes take minutes to discover that something doesn't unify;
                 what I have here is a compromise between reliable speed, and (in)completeness.
               *)
          | apply TT_right
          | apply @sepcon_TT; solve [auto with nocore typeclass_instances]
          | apply @TT_sepcon; solve [auto with nocore typeclass_instances]
          | cancel_frame
          | idtac
          ].

Inductive syntactic_cancel: list mpred -> list mpred -> list mpred -> list mpred -> Prop :=
| syntactic_cancel_nil: forall R, syntactic_cancel R nil R nil
| syntactic_cancel_cons_succeed: forall n R0 R L0 L F Res,
    find_nth_preds (fun R0 => R0 |-- L0) R (Some (n, R0)) ->
    syntactic_cancel (delete_nth n R) L F Res ->
    syntactic_cancel R (L0 :: L) F Res
| syntactic_cancel_cons_fail: forall R L0 L F Res,
    find_nth_preds (fun R0 => R0 |-- L0) R None ->
    syntactic_cancel R L F Res ->
    syntactic_cancel R (L0 :: L) F (L0 :: Res).

Lemma syntactic_cancel_cons: forall nR0 R L0 L F Res,
  find_nth_preds (fun R0 => R0 |-- L0) R nR0 ->
  syntactic_cancel match nR0 with
                   | Some (n, _) => delete_nth n R
                   | None => R
                   end L F Res ->
  syntactic_cancel R (L0 :: L) F (let Res' := Res in
                                 match nR0 with
                                 | Some _ => Res'
                                 | None => L0 :: Res'
                                 end).
Proof.
  intros.
  destruct nR0 as [[? ?]|].
  + eapply syntactic_cancel_cons_succeed; eauto.
  + eapply syntactic_cancel_cons_fail; eauto.
Qed.

Lemma delete_nth_SEP: forall R n R0,
  nth_error R n = Some R0 ->
  fold_right_sepcon R |-- R0 * fold_right_sepcon (delete_nth n R).
Proof.
  intros.
  revert R H; induction n; intros; destruct R; try solve [inv H].
  + inv H.
    simpl.
    auto.
  + simpl in H.
    apply IHn in H.
    simpl.
    rewrite <- sepcon_assoc, (sepcon_comm _ m), sepcon_assoc.
    apply sepcon_derives; auto.
Qed.

Lemma syntactic_cancel_solve1: forall F,
  fold_right_sepcon F |-- fold_right_sepcon nil * fold_right_sepcon F.
Proof.
  intros.
  simpl; rewrite emp_sepcon; auto.
Qed.

Lemma syntactic_cancel_solve2: forall G,
  fold_right_sepcon G |-- fold_right_sepcon nil * TT.
Proof.
  intros.
  simpl; rewrite emp_sepcon.
  apply TT_right.
Qed.

Lemma syntactic_cancel_spec1: forall G1 L1 G2 L2 F,
  syntactic_cancel G1 L1 G2 L2 ->
  fold_right_sepcon G2 |-- fold_right_sepcon L2 * F ->
  fold_right_sepcon G1 |-- fold_right_sepcon L1 * F.
Proof.
  intros.
  revert F H0; induction H; intros.
  + auto.
  + apply IHsyntactic_cancel in H1.
    simpl.
    rewrite sepcon_assoc.
    eapply derives_trans; [| apply sepcon_derives; [apply derives_refl | apply H1]].
    clear IHsyntactic_cancel H1.
    apply find_nth_preds_Some in H.
    destruct H.
    eapply derives_trans; [apply delete_nth_SEP; eauto |].
    apply sepcon_derives; auto.
  + simpl in H1.
    rewrite (sepcon_comm L0), sepcon_assoc in H1.
    apply (IHsyntactic_cancel (L0*F0)) in H1.
    eapply derives_trans; [exact H1 |].
    simpl.
    rewrite <- sepcon_assoc.
    apply sepcon_derives; auto.
    rewrite sepcon_comm; auto.
Qed.

Lemma syntactic_cancel_spec2: forall G1 L1 G2 L2 G3 L3 F,
  syntactic_cancel G1 L1 G2 L2 ->
  syntactic_cancel G2 L2 G3 L3 ->
  fold_right_sepcon G3 |-- fold_right_sepcon L3 * F ->
  fold_right_sepcon G1 |-- fold_right_sepcon L1 * F.
Proof.
  intros.
  eapply syntactic_cancel_spec1; eauto.
  eapply syntactic_cancel_spec1; eauto.
Qed.

Lemma syntactic_cancel_solve3:
  fold_right_sepcon nil |-- fold_right_sepcon nil.
Proof.
  auto.
Qed.

Lemma syntactic_cancel_spec3: forall G1 L1 G2 L2,
  syntactic_cancel G1 L1 G2 L2 ->
  fold_right_sepcon G2 |-- fold_right_sepcon L2 ->
  fold_right_sepcon G1 |-- fold_right_sepcon L1.
Proof.
  intros.
  rewrite <- (sepcon_emp (fold_right_sepcon L1)).
  eapply syntactic_cancel_spec1; eauto.
  rewrite sepcon_emp; auto.
Qed.

Ltac local_cancel_in_syntactic_cancel unify_tac :=
  cbv beta;
  match goal with |- ?A |-- ?B =>
    solve [ constr_eq A B; simple apply (derives_refl A)
          | tryif first [has_evar A | has_evar B] then fail else auto with nocore cancel
          | apply derives_refl'; unify_tac ]
  end.

Ltac syntactic_cancel local_tac :=
  repeat first
         [ simple apply syntactic_cancel_nil
         | simple apply syntactic_cancel_cons;
           [ find_nth local_tac
           | cbv iota; unfold delete_nth; cbv zeta iota
           ]
         ].

(* To solve: Frame := ?Frame |- fold_right_sepcon G |-- fold_right_sepcon L * fold_right_sepcon Frame *)
Ltac cancel_for_evar_frame' local_tac :=
  eapply syntactic_cancel_spec1;
  [ syntactic_cancel local_tac
  | cbv iota; cbv zeta beta;
    first [ match goal with
            | |- _ |-- _ * fold_right_sepcon ?F => try unfold F
            end;
            simple apply syntactic_cancel_solve1
          | match goal with
            | |- fold_right_sepcon ?A |-- fold_right_sepcon ?B * _ => rewrite <- (fold_left_sepconx_eq A), <- (fold_left_sepconx_eq B)
            end;
            unfold fold_left_sepconx; cbv iota beta ]
  ].

(* To solve: |- fold_right_sepcon G |-- fold_right_sepcon L * TT *)
Ltac cancel_for_TT local_tac :=
  eapply syntactic_cancel_spec1;
  [ syntactic_cancel local_tac
  | cbv iota; cbv zeta beta;
    first [ simple apply syntactic_cancel_solve2
          | match goal with
            | |- fold_right_sepcon ?A |-- fold_right_sepcon ?B * _ => rewrite <- (fold_left_sepconx_eq A), <- (fold_left_sepconx_eq B)
            end;
            unfold fold_left_sepconx; cbv iota beta ]
  ].

Ltac cancel_for_normal local_tac :=
  eapply syntactic_cancel_spec3;
  [ syntactic_cancel local_tac
  | cbv iota; cbv zeta beta;
    first [ simple apply syntactic_cancel_solve3
          | match goal with
            | |- fold_right_sepcon ?A |-- fold_right_sepcon ?B => rewrite <- (fold_left_sepconx_eq A), <- (fold_left_sepconx_eq B)
            end;
            unfold fold_left_sepconx; cbv iota beta ]
  ].

(* return Some true exists TT, return Some false if exists fold_right_sepcon. *)
(* unused?
Ltac Check_normal_mpred_list_rec L :=
  match L with
  | nil => constr:(@None bool)
  | cons TT _ => constr:(Some true)
  | cons (fold_right_sepcon _) _ => constr:(Some false)
  | cons _ ?L0 => Check_normal_mpred_list_rec L0
  end.

Ltac Check_pre_no_TT L :=
  let res := Check_normal_mpred_list_rec L in
  match res with
  | Some true => fail 1000 "No TT should appear in the SEP clause of a funcspec's precondition"
  | _ => idtac
  end.
*)

Inductive merge_abnormal_mpred: mpred -> option mpred -> option mpred -> Prop :=
| merge_abnormal_mpred_None: forall P, merge_abnormal_mpred P None (Some P)
| merge_abnormal_mpred_TT_Some: forall P, merge_abnormal_mpred TT (Some P) (Some P)
| merge_abnormal_mpred_Some_TT: forall P, merge_abnormal_mpred P (Some TT) (Some P).

Inductive fold_abnormal_mpred: list mpred -> list mpred -> option mpred -> Prop :=
| fold_abnormal_mpred_nil:
    fold_abnormal_mpred nil nil None
| fold_abnormal_mpred_TT: forall R res R' res',
    fold_abnormal_mpred R R' res ->
    merge_abnormal_mpred TT res res' ->
    fold_abnormal_mpred (TT :: R) R' res'
| fold_abnormal_mpred_fold: forall F R res R' res',
    fold_abnormal_mpred R R' res ->
    merge_abnormal_mpred (fold_right_sepcon F) res res' ->
    fold_abnormal_mpred ((fold_right_sepcon F) :: R) R' res'
| fold_abnormal_mpred_normal: forall P R R' res,
    fold_abnormal_mpred R R' res ->
    fold_abnormal_mpred (P :: R) (P :: R') res.

Definition Some_or_emp (res: option mpred) := match res with | Some P => P | _ => emp end.

Lemma merge_abnormal_mpred_spec: forall P res res',
  merge_abnormal_mpred P res res' ->
  Some_or_emp res' |-- P * Some_or_emp res.
Proof.
  intros.
  inv H; simpl.
  + rewrite sepcon_emp; auto.
  + apply TT_sepcon.
  + apply sepcon_TT.
Qed.

Lemma fold_abnormal_mpred_spec: forall R R' res,
  fold_abnormal_mpred R R' res ->
  fold_right_sepcon R' * Some_or_emp res |-- fold_right_sepcon R.
Proof.
  intros.
  induction H; simpl.
  + rewrite emp_sepcon; auto.
  + apply merge_abnormal_mpred_spec in H0.
    eapply derives_trans; [apply sepcon_derives; [apply derives_refl | apply H0] |].
    rewrite <- sepcon_assoc.
    rewrite (sepcon_comm _ TT).
    rewrite sepcon_assoc.
    apply sepcon_derives; auto.
  + apply merge_abnormal_mpred_spec in H0.
    eapply derives_trans; [apply sepcon_derives; [apply derives_refl | apply H0] |].
    rewrite <- sepcon_assoc.
    rewrite (sepcon_comm _ (fold_right_sepcon F)).
    rewrite sepcon_assoc.
    apply sepcon_derives; auto.
  + rewrite sepcon_assoc.
    apply sepcon_derives; auto.
Qed.

Inductive construct_fold_right_sepcon_rec: mpred -> list mpred -> list mpred -> Prop :=
| construct_fold_right_sepcon_rec_sepcon: forall P Q R R' R'',
    construct_fold_right_sepcon_rec Q R R' ->
    construct_fold_right_sepcon_rec P R' R'' ->
    construct_fold_right_sepcon_rec (P * Q) R R''
| construct_fold_right_sepcon_rec_emp: forall R,
    construct_fold_right_sepcon_rec emp R R
| construct_fold_right_sepcon_rec_single: forall P R,
    construct_fold_right_sepcon_rec P R (P :: R).

Local Unset Elimination Schemes. (* ensure that we avoid name collision with the above *)
Inductive construct_fold_right_sepcon: mpred -> list mpred-> Prop :=
| construct_fold_right_sepcon_constr: forall P R,
    construct_fold_right_sepcon_rec P nil R ->
    construct_fold_right_sepcon P R.
Scheme Minimality for construct_fold_right_sepcon Sort Prop.
Local Set Elimination Schemes.

Lemma construct_fold_right_sepcon_spec: forall P R,
  construct_fold_right_sepcon P R ->
  fold_right_sepcon R = P.
Proof.
  intros.
  destruct H.
  rename R into R'.
  transitivity (fold_right_sepcon nil * P).
  2:{
    simpl.
    rewrite !emp_sepcon.
    auto.
  }
  forget (@nil mpred) as R.
  induction H.
  + etransitivity; [eassumption |].
    transitivity (fold_right_sepcon R * Q * P); [f_equal; eassumption |].
    clear.
    rewrite (sepcon_comm P).
    rewrite !sepcon_assoc; auto.
  + rewrite sepcon_emp; auto.
  + simpl.
    rewrite (sepcon_comm _ P).
    auto.
Qed.

Definition before_symbol_cancel (P Q: list mpred) (res: option mpred): Prop :=
  match res with
  | Some R => fold_right_sepcon P |-- fold_right_sepcon Q * R
  | None => fold_right_sepcon P |-- fold_right_sepcon Q
  end.

Lemma symbolic_cancel_setup: forall P P' Q Q' Q'' Qr,
  construct_fold_right_sepcon P P' ->
  construct_fold_right_sepcon Q Q' ->
  fold_abnormal_mpred Q' Q'' Qr ->
  before_symbol_cancel P' Q'' Qr ->
  P |-- Q.
Proof.
  intros.
  apply construct_fold_right_sepcon_spec in H.
  apply construct_fold_right_sepcon_spec in H0.
  apply fold_abnormal_mpred_spec in H1.
  rewrite <- H, <- H0.
  eapply derives_trans; [| exact H1].
  destruct Qr; auto.
  simpl in H2 |- *.
  rewrite sepcon_emp; auto.
Qed.

Ltac construct_fold_right_sepcon_rec :=
  match goal with
  | |- construct_fold_right_sepcon_rec (sepcon _ _) _ _ =>
         eapply construct_fold_right_sepcon_rec_sepcon;
         [construct_fold_right_sepcon_rec | construct_fold_right_sepcon_rec]
  | |- construct_fold_right_sepcon_rec emp _ _ =>
         apply construct_fold_right_sepcon_rec_emp
  | _ =>
         apply construct_fold_right_sepcon_rec_single
  end.

Ltac merge_abnormal_mpred :=
  first
  [ simple apply merge_abnormal_mpred_None
  | simple apply merge_abnormal_mpred_TT_Some
  | simple apply merge_abnormal_mpred_Some_TT
  | fail 1000 "There should not be two fold_right_sepcon in the right side."
  ].

Ltac construct_fold_right_sepcon :=
  apply construct_fold_right_sepcon_constr;
  construct_fold_right_sepcon_rec.

Ltac is_evar_def F := try first [is_var F; unfold F; fail 1 | fail 2 F "is not evar definition"].

Ltac fold_abnormal_mpred :=
  match goal with
  | |- fold_abnormal_mpred nil _ _ =>
         simple apply fold_abnormal_mpred_nil
  | |- fold_abnormal_mpred (?P :: _) _ _ =>
         match P with
         | TT => simple eapply fold_abnormal_mpred_TT; [fold_abnormal_mpred | merge_abnormal_mpred]
         | prop True => simple eapply fold_abnormal_mpred_TT; [fold_abnormal_mpred | merge_abnormal_mpred]
         | fold_right_sepcon ?F =>
              is_evar_def F;
              simple eapply fold_abnormal_mpred_fold; [fold_abnormal_mpred | merge_abnormal_mpred]
         | _ => simple apply fold_abnormal_mpred_normal; fold_abnormal_mpred
         end
  end.

Ltac new_cancel local_tac :=
  match goal with
  | |- @derives mpred Nveric _ _ => idtac
  | _ => fail 1000 "Tactic cancel can only handle proof goals with form _ |-- _ (unlifted version)."
  end;
  eapply symbolic_cancel_setup;
  [ construct_fold_right_sepcon
  | construct_fold_right_sepcon
  | fold_abnormal_mpred
  | match goal with
    | |- before_symbol_cancel _ _ None =>
           cbv iota beta delta [before_symbol_cancel];
           cancel_for_normal local_tac
    | |- before_symbol_cancel _ _ (Some (fold_right_sepcon _)) =>
           cbv iota beta delta [before_symbol_cancel];
           cancel_for_evar_frame' local_tac
    | |- before_symbol_cancel _ _ (Some TT) =>
           cbv iota beta delta [before_symbol_cancel];
           cancel_for_TT local_tac
    | |- before_symbol_cancel _ _ (Some (prop True)) =>
           cbv iota beta delta [before_symbol_cancel];
           cancel_for_TT local_tac
    end
  ].

Ltac cancel_unify_tac :=
  autorewrite with cancel;
  careful_unify.

Ltac cancel_local_tac :=
  cbv beta;
  match goal with |- ?A |-- ?B =>
    solve [ constr_eq A B; simple apply (derives_refl A)
          | auto with nocore cancel
          | apply derives_refl'; cancel_unify_tac]
  end.

Ltac cancel ::= new_cancel cancel_local_tac.

Ltac no_evar_cancel_local_tac := local_cancel_in_syntactic_cancel cancel_unify_tac.
Ltac no_evar_cancel := new_cancel no_evar_cancel_local_tac.

Ltac ecancel_unify_tac :=
  autorewrite with cancel;
  ecareful_unify.

Ltac ecancel_local_tac := local_cancel_in_syntactic_cancel ecancel_unify_tac.
Ltac pure_ecancel := new_cancel ecancel_local_tac.
Ltac ecancel := no_evar_cancel; pure_ecancel.

Ltac old_local_tac := local_cancel_in_syntactic_cancel careful_unify.
Ltac cancel_for_evar_frame := cancel_for_evar_frame' ecancel_local_tac.

Ltac info_cancel_local_tac :=
  (tryif try (cancel_local_tac; gfail 1)
    then match goal with |- ?Goal => idtac Goal "fail" end
    else match goal with |- ?Goal => idtac Goal "success" end);
  cancel_local_tac.

Ltac info_cancel := new_cancel info_cancel_local_tac.

Ltac info_ecancel_local_tac :=
  (tryif try (ecancel_local_tac; gfail 1)
    then match goal with |- ?Goal => idtac Goal "fail" end
    else match goal with |- ?Goal => idtac Goal "success" end);
  ecancel_local_tac.

Ltac info_ecancel := info_cancel; new_cancel info_ecancel_local_tac.

(*

Export ListNotations.

Goal forall A B C D E F G H I J K L: mpred,
  A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) *
  A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) |--
  (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G) *
  (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G).
Proof.
  intros.
  Time
  do 4
  match goal with
  | |- ?P => assert (P /\ P /\ P); [| tauto]; split; [| split]
  end;
  (rewrite ?sepcon_assoc;
  repeat match goal with |- ?A * _ |-- ?B * _ =>
     constr_eq A B;  simple apply (cancel_left A)
  end;
  match goal with |- ?P |-- _ => qcancel P end;
  repeat first [rewrite emp_sepcon | rewrite sepcon_emp];
  try match goal with |- ?A |-- ?B =>
       constr_eq A B; simple apply (derives_refl A)
  end;
  match goal with |- ?P |-- _ =>
   (* The "emp" is a marker to notice when one complete pass has been made *)
   rewrite <- (emp_sepcon P)
  end;
  repeat rewrite <- sepcon_assoc;
  repeat match goal with
    | |- sepcon _ emp |-- _ => fail 1
    | |- sepcon _ TT |-- _ => pull_left (@TT mpred _)
    | |- sepcon _ ?P' |-- _ => first [ cancel2 | pull_left P' ]
   end;
  repeat first [rewrite emp_sepcon | rewrite sepcon_emp];
  pull_left (@TT mpred _);
  first [ simpl; apply derives_refl'; solve [careful_unify]
            (* this is NOT a _complete_ tactic;
                 for example, "simple apply derives_refl" would be more complete.  But that
                 tactic can sometimes take minutes to discover that something doesn't unify;
                 what I have here is a compromise between reliable speed, and (in)completeness.
               *)
          | apply TT_right
          | apply @sepcon_TT; solve [auto with nocore typeclass_instances]
          | apply @TT_sepcon; solve [auto with nocore typeclass_instances]
          | cancel_frame
          | idtac
          ]).

  cancel. (* New cancel: 8.983 9.199 8.599 *)
          (* Old cancel: 133.919 133.224 138.729 *)
Abort

Goal forall A B C D: mpred,
  A * B * (C * A) * B |-- B * (A * A) * TT.
Proof.
  intros.
  Time
  do 4
  match goal with
  | |- ?P => assert (P /\ P /\ P); [| tauto]; split; [| split]
  end;
(* cancel. (* 4.323 4.275 3.887 3.763 3.684 3.66 3.6 3.534 3.616 3.6 3.591 3.606 *) *)
(*  new_cancel. (* 0.615 0.656 0.655 0.653 0.687 *) *)

Goal forall A B C D: mpred,
  A * B * (C * fold_right_sepcon [A; B] * A) * B |-- B * (A * A) * fold_right_sepcon [A; B].
Proof.
  intros.
  cancel.

Goal forall A B C D: mpred,
  A * B * (C * A) * B |-- B * TT * (A * A).
Proof.
  intros.
  new_cancel.

Goal forall A B C D: mpred, exists F': list mpred,
  let F := F' in
  A * B * (C * A) * B |-- B * (A * A) * fold_right_sepcon F.
Proof.
  intros; eexists; intros.
  new_cancel.

Goal forall A B C D: mpred,
  A * B * (C * A) * B |-- B * (A * D).
Proof.
  intros.
  new_cancel.

Goal forall A B C D: mpred,
  fold_right_sepcon [A; B; C; A; B] |-- fold_right_sepcon [B; A; D].
Proof.
  intros.
  cancel_for_normal.

Goal forall A B C D: mpred,
  fold_right_sepcon [A; B; C; A; B] |-- fold_right_sepcon [B; A] * TT.
Proof.
  intros.
  cancel_for_TT.

Goal forall A B C D: mpred, exists F: list mpred,
  fold_right_sepcon [A; B; C; A; B] |-- fold_right_sepcon [B; A] * fold_right_sepcon F.
Proof.
  intros.
  eexists.
  cancel_for_evar_frame.
*)

Ltac apply_find_core X :=
 match X with
 | ?U -> ?V => match type of U with Prop => apply_find_core V end
 | @derives mpred _ _ _ => constr:(X)
 | @eq mpred ?A ?B => constr:(@derives mpred A B)
 end.

Lemma adjust_sep_apply:  forall (Q: mpred) (P: Prop),
   Q |-- !! P ->
   Q |-- !! P && Q.
Proof. intros. apply andp_right; auto. Qed.

Ltac adjust_sep_apply H :=
 match type of H with
 | _ |-- !! _ => constr:(adjust_sep_apply _ _ H)
 | _ => H
 end.

Ltac adjust2_sep_apply H :=
 let x := adjust_sep_apply H in
 match type of x with
 | @eq mpred _ _ => constr:(derives_refl' _ _ x)
 | _ => x
 end.

Ltac cancel_for_sep_apply := ecancel.

Ltac sep_apply_aux2 H' :=
match type of H' with ?TH =>
     match apply_find_core TH with  ?C |-- ?D =>
      let frame := fresh "frame" in evar (frame: list mpred);
       apply derives_trans with (C * fold_right_sepcon frame);
             [ solve [cancel_for_sep_apply]
             | eapply derives_trans;
                [apply sepcon_derives; [clear frame; apply H' | apply derives_refl]
                |  let x := fresh "x" in set (x := fold_right_sepcon frame);
                  subst frame; unfold fold_right_sepcon in x; subst x;
                  rewrite ?sepcon_emp
                ]
             ]
     end
     end.

Ltac head_of_type_of H :=
 match type of H with ?A => apply_find_core A end.

Ltac sep_apply_aux1 H :=
 let B := head_of_type_of H in
 lazymatch B with
 | ?A |-- _ =>
   lazymatch A with
   | context [!! ?P && _] =>
      let H' := fresh in
      assert (H' := H);
      rewrite ?(andp_assoc (!! P)) in H';
      let H := fresh in
      assert (H:P);
       [ clear H' | rewrite (prop_true_andp P) in H' by apply H; clear H;
           sep_apply_aux1 H'; clear H' ]
   | _ => sep_apply_aux2 H
    end
 end.

Ltac sep_apply_aux0 H :=
 let B := head_of_type_of H in
 lazymatch B with
 | ?A ?D |-- _ =>
    tryif (match type of D with ?DT => constr_eq DT globals end)
   then
    (tryif (unfold A in H) then sep_apply_aux1 H
    else let H' := fresh in
         tryif (assert (H' := H); unfold A in H')
         then sep_apply_aux1 H'
         else sep_apply_aux1 H)
   else sep_apply_aux1 H
 | _ => sep_apply_aux1 H
 end.

Ltac sep_apply_in_entailment H :=
    match goal with |- _ |-- _ =>
     let H' := adjust2_sep_apply H in
         sep_apply_aux0 H'
    end.

Ltac my_unshelve_evar name T cb evar_tac :=
  let x := fresh name
  in
  unshelve evar (x:T); revgoals;
  [
    let x' := eval unfold x in x
    in
    clear x; cb x'
  |
    evar_tac x
  ].

Ltac new_sep_apply_in_entailment originalH evar_tac prop_tac :=
  let rec sep_apply_in_entailment_rec H :=
    lazymatch type of H with
    | forall x:?T, _ =>
      lazymatch type of T with
      | Prop => let H' := fresh "H" in assert (H':T);
           [ | sep_apply_in_entailment_rec (H H'); clear H'];
           [ prop_tac | .. ]
      | _ => my_unshelve_evar x T
        ltac:(fun x => sep_apply_in_entailment_rec (H x))
        evar_tac
      end
    | ?T -> _ =>
      lazymatch type of T with
      | Prop => let H' := fresh "H" in assert (H':T);
           [ | sep_apply_in_entailment_rec (H H'); clear H'];
           [ prop_tac | .. ]
      | _ => let x := fresh "arg" in
        my_unshelve_evar x T
          ltac:(fun x => sep_apply_in_entailment_rec (H x))
          evar_tac
      end
    | ?A |-- ?B => sep_apply_in_entailment H
    | ?A = ?B => sep_apply_in_entailment H
    | _ => fail 0 originalH "is not an entailment"
    end
  in
  sep_apply_in_entailment_rec originalH.

Lemma wand_refl_cancel_right:
  forall {A}{ND: NatDed A} {SL: SepLog A}{CA: ClassicalSep A}
    (P: A),  emp |-- P -* P.
Proof.
intros. apply wand_sepcon_adjoint.
rewrite emp_sepcon. apply derives_refl.
Qed.

Lemma cancel_emp_wand:
  forall P Q R: mpred,
    P |-- Q ->
    P |-- Q * (R -* R).
Proof.
intros. rewrite <- (sepcon_emp P).
apply sepcon_derives; auto.
apply wand_refl_cancel_right.
Qed.

Ltac cancel_wand :=
  repeat
  match goal with |- _ |-- ?B =>
    match B with context [?A -* ?A] =>
    rewrite ?sepcon_assoc;
    pull_right (A -* A);
    first [apply cancel_emp_wand | apply wand_refl_cancel_right]
    end
  end.

Ltac norm_rewrite := autorewrite with norm.
 (* New version: rewrite_strat (topdown hints norm).
     But this will have to wait for a future version of Coq
    in which rewrite_strat discharges side conditions.
    According to Matthieu Sozeau, in the Coq trunk as of June 5, 2013,
    rewrite_strat is documented AND discharges side conditions.
    It might be about twice as fast, or 1.7 times as fast, as the old autorewrite.
    And then, maybe use "bottomup" instead of "topdown", see if that's better.

   To test whether your version of Coq works, use this:
*)
Lemma TEST_L : forall n:nat, n=n -> (n + 1 = S n)%nat.
Proof. intros. rewrite <- plus_n_Sm ,<- plus_n_O. reflexivity.
Qed.
Hint Rewrite TEST_L using reflexivity : test888.
Goal forall n, S n = (n + 1)%nat.
intros.
rewrite_strat (topdown hints test888).
match goal with |- S n = S n => reflexivity end.
Qed.  (* Yes, this works in Coq 8.7.2 *)

Ltac normalize1 :=
         match goal with
            | |- context [@andp ?A (@LiftNatDed ?T ?B ?C) ?D ?E ?F] =>
                      change (@andp A (@LiftNatDed T B C) D E F) with (D F && E F)
            | |- context [@later ?A  (@LiftNatDed ?T ?B ?C) (@LiftIndir ?X1 ?X2 ?X3 ?X4 ?X5) ?D ?F] =>
                   change (@later A  (@LiftNatDed T B C) (@LiftIndir X1 X2 X3 X4 X5) D F)
                     with (@later B C X5 (D F))
            | |- context [@sepcon ?A (@LiftNatDed ?B ?C ?D)
                                                         (@LiftSepLog ?E ?F ?G ?H) ?J ?K ?L] =>
                   change (@sepcon A (@LiftNatDed B C D) (@LiftSepLog E F G H) J K L)
                      with (@sepcon C D H (J L) (K L))
            | |- context [(?P && ?Q) * ?R] => rewrite (corable_andp_sepcon1 P Q R) by (auto with norm)
            | |- context [?Q * (?P && ?R)] => rewrite (corable_sepcon_andp1 P Q R) by (auto with norm)
            | |- context [(?Q && ?P) * ?R] => rewrite (corable_andp_sepcon2 P Q R) by (auto with norm)
            | |- context [?Q * (?R && ?P)] => rewrite (corable_sepcon_andp2 P Q R) by (auto with norm)
            | |-  derives ?A   ?B => match A with
                   | FF => apply FF_left
                   | !! _ => apply derives_extract_prop0
                   | exp (fun y => _) => apply imp_extract_exp_left; (intro y || intro)
                   | !! _ && _ => apply derives_extract_prop
                   | _ && !! _ => apply derives_extract_prop'
                   | context [ ((!! ?P) && ?Q) && ?R ] => rewrite (andp_assoc (!!P) Q R)
                   | context [ ?Q && (!! ?P && ?R)] =>
                                  match Q with !! _ => fail 2 | _ => rewrite (andp_assoc' (!!P) Q R) end
                 (* In the next four rules, doing it this way (instead of leaving it to autorewrite)
                    preserves the name of the "y" variable *)
                   | context [andp (exp (fun y => _)) _] =>
                               let BB := fresh "BB" in set (BB:=B); norm_rewrite; unfold BB; clear BB;
                               apply imp_extract_exp_left; intro y
                   | context [andp _ (exp (fun y => _))] =>
                               let BB := fresh "BB" in set (BB:=B); norm_rewrite; unfold BB; clear BB;
                               apply imp_extract_exp_left; intro y
                   | context [sepcon (exp (fun y => _)) _] =>
                               let BB := fresh "BB" in set (BB:=B); norm_rewrite; unfold BB; clear BB;
                               apply imp_extract_exp_left; intro y
                   | context [sepcon _ (exp (fun y => _))] =>
                               let BB := fresh "BB" in set (BB:=B); norm_rewrite; unfold BB; clear BB;
                                apply imp_extract_exp_left; intro y
                   | _ => simple apply TT_prop_right
                   | _ => simple apply TT_right
                   | _ => constr_eq A B; apply derives_refl
                   end
              | |- _ => solve [auto]
              | |- _ |-- !! (?x = ?y) && _ =>
                            (rewrite (prop_true_andp' (x=y))
                                            by (unfold y; reflexivity); unfold y in *; clear y) ||
                            (rewrite (prop_true_andp' (x=y))
                                            by (unfold x; reflexivity); unfold x in *; clear x)
              |  |- ?ZZ -> ?YY => match type of ZZ with
                                               | Prop => fancy_intros true || fail 1
                                               | _ => intros _
                                              end
              | |- ~ _ => fancy_intro true
              | |- _ => progress (norm_rewrite) (*; auto with typeclass_instances *)
              | |- forall _, _ => let x := fresh "x" in (intro x; repeat normalize1; try generalize dependent x)
              end.

Ltac normalize :=
   autorewrite with gather_prop;
   repeat (((repeat simple apply go_lower_lem1'; simple apply go_lower_lem1)
              || simple apply derives_extract_prop
              || simple apply derives_extract_prop');
              fancy_intros true);
   repeat normalize1; try contradiction.

Lemma allp_instantiate:
   forall {A : Type} {NA : NatDed A} {B : Type} (P : B -> A) (x : B),
       ALL y : B, P y |-- P x.
Proof.
intros. apply allp_left with x. auto.
Qed.

Ltac allp_left x :=
 match goal with |- ?A |-- _ => match A with context [@allp ?T ?ND ?B ?P] =>
   sep_apply_in_entailment (@allp_instantiate T ND B P x)
 end end.

(* these two lemmas work better with new sep_apply and sep_eapply *)
Lemma allp_instantiate': forall (B : Type) (P : B -> mpred) (x : B),
  allp P |-- P x.
Proof. intros. apply allp_instantiate. Qed.

Lemma wand_frame_elim'': forall P Q,
  (P -* Q) * P |-- Q.
Proof. intros. rewrite sepcon_comm. apply wand_frame_elim. Qed.

Lemma prop_sepcon: forall {A}{ND: NatDed A}{SL: SepLog A}
    P Q, !! P * Q = !! P && (TT * Q).
Proof.
 intros.
 rewrite <- (andp_TT (!! _)), sepcon_andp_prop'. normalize.
Qed.

Lemma prop_sepcon2: forall {A}{ND: NatDed A}{SL: SepLog A}
    P Q, Q * !! P = !! P && (TT * Q).
Proof.
 intros.
 rewrite sepcon_comm. apply prop_sepcon.
Qed.


(** * System MALL for propositional multiplicative and additive linear logic

This file encodes the inference rules of the system MALL (two sided)
of propositional multiplicative additive linear logic.
 *)

Require Export FLL.OL.CutCoherence.OLCutl.
Require Import FLL.Misc.Permutations.

Export ListNotations.
Export LLNotations.
Set Implicit Arguments.

(** ** Syntax *)
(* No units *)
Inductive Constants := .
(* conjunction, disjunction and implication *)
Inductive Connectives := TENSOR | PAR | WITH | OPLUS .
(* no quantifiers *)
Inductive Quantifiers := .
(* no unary connectives *)
Inductive UConnectives := .

Instance SimpleOLSig : OLSyntax:=
  {|
    OLType := nat;
    constants := Constants ;
    uconnectives := UConnectives;
    connectives := Connectives ;
    quantifiers := Quantifiers
  |}.

(** ** Inference rules *)

(** *** Constants *)
Definition rulesCTE (c:constants) :=
  match c return ruleCte with
  end.

(** *** Unary connectives *)
Definition rulesUC  (c:uconnectives) :=
  match c return ruleUnary with
  end.

(** *** Binary connectives *)
Definition rulesBC (c :connectives) :=
  match c with
  | TENSOR => {| rb_rightBody := fun F G => (atom (up F)) ** (atom (up G) );
                 rb_leftBody  := fun F G => (atom (down F) ) $ (atom (down G)) |}
  | PAR => {| rb_rightBody := fun F G => (atom (up F)) $ (atom (up G) );
              rb_leftBody  := fun F G => (atom (down F) ) ** (atom (down G)) |}
  | WITH => {| rb_rightBody := fun F G => (atom (up F)) & (atom (up G) );
                 rb_leftBody  := fun F G => (atom (down F) ) op (atom (down G)) |}
  | OPLUS => {| rb_rightBody := fun F G => (atom (up F)) op (atom (up G) );
             rb_leftBody  := fun F G => (atom (down F) ) & (atom (down G)) |}
  end.

(** *** Quantifiers *)
Definition rulesQC (c :quantifiers) :=
  match c return ruleQ with
  end.

Instance SimpleOORUles : OORules :=
  {|
    rulesCte := rulesCTE ;
    rulesUnary := rulesUC ;
    rulesBin := rulesBC;
    rulesQ := rulesQC
  |}.

(** ** Well-formedness conditions *)

(** *** Constants *)
Lemma wellFormedConstant_p : wellFormedCte.
Proof with WFSolver.
  unfold wellFormedCte;intros.
  destruct lab.
Qed.

(** *** Unary connectives *)

Lemma wellFormedUnary_p : wellFormedUnary.
Proof with WFSolver.
  unfold wellFormedUnary;intros.
  destruct lab.
Qed.

(** *** Binary connectives *)
Lemma wellFormedBinary_p : wellFormedBinary.
Proof with WFSolver.
  unfold wellFormedBinary;intros.
  destruct lab;destruct s.
  + (* Conjunction left *)
  exists BOneP...
  apply ANDL_Par.
  + (* Conjunction right *)
  exists BTwoPM...
  apply ANDR_Tensor.
  + (* Disjunction left *)
    exists BTwoPM...
    intros n HSeq HIs...
    FLLInversionAll...
    ++ (* linear case *)
    exists M0.
       exists N0.
       exists [atom (down Fo1)].
       exists [atom (down Go1)].
       exists (@nil oo). exists (@nil oo).
       eexists. exists 4...
       left...
       rewrite H1...
       tensor M0 N0...
       decide3 (makeLRuleBin PAR Fo1 Go1)...
       tensor [ (atom (down (t_bin PAR Fo1 Go1)))] (Delta1 ++ Delta2).
       tensor .
    ++ (* classical case *)
      exists M0.
       exists N0.
       exists [atom (down Fo1)].
       exists [atom (down Go1)].
       exists (@nil oo). exists (@nil oo).
       eexists. exists 4...
       right...
       rewrite H1...
       tensor M0 N0...
       decide3 (makeLRuleBin PAR Fo1 Go1)...
       tensor (@nil oo) (Delta1 ++ Delta2)...
       tensor Delta1 Delta2.

  + (* Disjunction right *)
    exists BOneP...
    intros n HSeq HIs...
    FLLInversionAll.

    exists   ([atom (up Fo1)] ++ [atom (up Go1)]). exists (@nil oo).
    eexists. exists 5...
    rewrite H1.
    left.
    exists N...
    decide3  (perp (up (t_bin PAR Fo1 Go1)) ** (atom (up Fo1) $ atom (up Go1))).
    tensor [ (atom (up (t_bin PAR Fo1 Go1)))] Delta1.
    solveLL...

    exists   ([atom (up Fo1)] ++ [atom (up Go1)]). exists (@nil oo).
    eexists. exists 5...
    rewrite H1.
    right...
    decide3  (perp (up (t_bin PAR Fo1 Go1)) ** (atom (up Fo1) $ atom (up Go1))).
    tensor (@nil oo) Delta1.
    solveLL...

  + (* With Left *)
    exists BOneP...
    intros n HSeq HIs...
    FLLInversionAll.

    exists  [atom (down Fo1)]. exists (@nil oo).
    eexists. exists 4...
    rewrite H1.
    left.
    exists N...
    apply tri_plus1'...
    decide3  (perp (down (t_bin WITH Fo1 Go1)) ** (atom (down Fo1) op atom (down Go1))).
    tensor [ (atom (down (t_bin WITH Fo1 Go1)))] Delta1.

    exists  [atom (down Fo1)]. exists (@nil oo).
    eexists. exists 4...
    rewrite H1.
    right...
    apply tri_plus1'...
    decide3  (perp (down (t_bin WITH Fo1 Go1)) ** (atom (down Fo1) op atom (down Go1))).
    tensor (@nil oo) Delta1.

    exists  [atom (down Go1)]. exists (@nil oo).
    eexists. exists 4...
    rewrite H1.
    left.
    exists N...
    apply tri_plus2'...
    decide3  (perp (down (t_bin WITH Fo1 Go1)) ** (atom (down Fo1) op atom (down Go1))).
    tensor [ (atom (down (t_bin WITH Fo1 Go1)))] Delta1.

    exists  [atom (down Go1)]. exists (@nil oo).
    eexists. exists 4...
    rewrite H1.
    right...
    apply tri_plus2'...
    decide3  (perp (down (t_bin WITH Fo1 Go1)) ** (atom (down Fo1) op atom (down Go1))).
    tensor (@nil oo) Delta1.
  + (* with right *)
    exists BTwoPA...
    intros n HSeq HIs...
    FLLInversionAll...
    ++ exists N.
       exists [atom (up Fo1)].
       exists [atom (up Go1)].
       exists (@nil oo). exists (@nil oo).
       eexists. exists 4...
       rewrite H1.
       left...
       decide3 (makeRRuleBin WITH Fo1 Go1)...
       tensor [(atom (up (t_bin WITH Fo1 Go1)))] Delta12.

    ++ exists N.
       exists [atom (up Fo1)].
       exists [atom (up Go1)].
       exists (@nil oo). exists (@nil oo).
       eexists. exists 4...
       rewrite H1.
       right...
       decide3 (makeRRuleBin WITH Fo1 Go1)...
       tensor (@nil oo) Delta12...
  + (* Oplus Left *)
    exists BTwoPA...
    apply ORL_With.

  + (* Oplus Right *)
    exists BOneP...
    apply ORR_Plus.
Qed.

(** *** Quantifiers *)
Lemma wellFormedQuantifier_p : wellFormedQuantifier.
Proof with solveF.
  unfold wellFormedQuantifier. intros.
  destruct lab.
Qed.

Lemma wellFormedTheory_p : wellFormedTheory.
  split.
  apply wellFormedConstant_p.
  split.
  apply wellFormedUnary_p.
  split; [apply wellFormedBinary_p | apply wellFormedQuantifier_p].
Qed.

(** ** Cut-coherency properties *)

(** *** Binary Connectives *)
Lemma CutCoherenceTENSOR: CutCoherenceBin (rulesBC TENSOR).
Proof with solveF.
  unfold CutCoherenceBin;intros.
  simpl.
  solveLL.
  decide3 ((atom (up F) ) ** (atom (down F) )). econstructor;eauto using le_max_l.
  tensor [perp (up F) ] [perp (up G); perp (down F) ** perp (down G)];solveLL.
  decide3 ((atom (up G) ) ** (atom (down G) )). econstructor;eauto using le_max_r.
  tensor [perp (up G) ] [ perp (down F) ** perp (down G); atom (down F)];solveLL.

  decide1 ((perp (down F) ) ** perp (down G) ).
  tensor [atom (down F) ] [atom (down G) ].
Qed.

Lemma CutCoherencePAR: CutCoherenceBin (rulesBC PAR).
Proof with solveF.
  unfold CutCoherenceBin;intros.
  simpl.
  solveLL.
  decide3 ((atom (up F) ) ** (atom (down F) )). econstructor;eauto using le_max_l.
  tensor  [perp (up F) ** perp (up G); perp (down G)] [perp (down F) ]  ;solveLL.
  decide3 ((atom (up G) ) ** (atom (down G) )). econstructor;eauto using le_max_r.
  tensor  [perp (up F) ** perp (up G); atom (up F)][perp (down G)]   ;solveLL.
  decide1 (perp (up F) ** perp (up G)) .
  tensor [atom (up F) ][ atom (up G)].
Qed.

Lemma CutCoherenceWITH: CutCoherenceBin (rulesBC WITH).
Proof with solveF.
  unfold CutCoherenceBin;intros.
  simpl.
  solveLL.

  decide3 ((atom (up F) ) ** (atom (down F) )). econstructor;eauto using le_max_l.
  tensor[perp (up F) op perp (up G)] [perp (down F)]  ;solveLL.
  decide1 (perp (up F) op perp (up G)).

  decide3 ((atom (up G) ) ** (atom (down G) )). econstructor;eauto using le_max_r.
  tensor[perp (up F) op perp (up G)] [perp (down G)]  ;solveLL.
  decide1 (perp (up F) op perp (up G)).
Qed.

Lemma CutCoherenceOPLUS: CutCoherenceBin (rulesBC OPLUS).
Proof with solveF.
  unfold CutCoherenceBin;intros.
  simpl.
  solveLL.

  decide3 ((atom (up F) ) ** (atom (down F) )). econstructor;eauto using le_max_l.
  tensor [perp (up F)]  [perp (down F) op perp (down G)]  ;solveLL.
  decide1 (perp (down F) op perp (down G)).

  decide3 ((atom (up G) ) ** (atom (down G) )). econstructor;eauto using le_max_r.
  tensor [perp (up G)]  [perp (down F) op perp (down G)]  ;solveLL.
  decide1 (perp (down F) op perp (down G)).
Qed.

Lemma CutCoherence_p : CutCoherence .
  split;intros; try destruct lab.
  split;intros; try destruct lab.
  split;intros; try destruct lab;
    auto using CutCoherenceOPLUS, CutCoherenceWITH, CutCoherenceTENSOR, CutCoherencePAR.
Qed.

(** The theory is well formed: cut-coherence holds and all the rules
are bipoles *)
Lemma wellTheory_p : wellTheory.
  split;auto using CutCoherence_p,  wellFormedTheory_p.
Qed.

Hint Unfold  OLTheoryIsFormula ConstantsFormulas UConnectivesFormulas ConnectivesFormulas QuantifiersFormulas : core .
Hint Unfold  OLTheoryIsFormulaD ConstantsFormulasD UConnectivesFormulasD ConnectivesFormulasD QuantifiersFormulasD :core.

Theorem  OLTheoryIsFormula_p :  OLTheoryIsFormula.
Proof with SolveIsFormulas.
  split;autounfold...
  intro;destruct lab...
Qed.

Theorem  OLTheoryIsFormulaD_p :  OLTheoryIsFormulaD.
Proof with SolveIsFormulas.
  split;autounfold...
  intro;destruct lab...
Qed.

(** ** Adequacy

Now we prove that the encoding is sound and complete. For that, we
define the provability relation of MALL as an inductive definition *)

Notation "F *** G" := (t_bin TENSOR F G) (at level 10) .
Notation "F $$$ G" := (t_bin PAR F G) (at level 10) .
Notation "F 'ooo' G" := (t_bin OPLUS F G) (at level 10) .
Notation "F &* G" := (t_bin WITH F G) (at level 10) .

Inductive MALLSeq : list uexp -> list uexp -> Prop :=
| MALLInit : forall F , MALLSeq [F] [F]
| MALLTensorR : forall L1 L2 L1' L2' F G, MALLSeq L1 (F :: L2) -> MALLSeq L1' (G :: L2') -> MALLSeq  (L1 ++ L1') (F *** G :: (L2 ++ L2'))
| MALLTensorL : forall L1 L2 F G, MALLSeq (F :: G :: L1) L2 -> MALLSeq (F *** G :: L1) L2
| MALLParR : forall L1 L2 F G, MALLSeq L1 (F :: G :: L2) -> MALLSeq L1 (F $$$ G :: L2)
| MALLParL :forall L1 L2 L1' L2' F G, MALLSeq (F :: L1) L2 -> MALLSeq (G :: L1') L2' -> MALLSeq (F $$$ G :: L1 ++ L1') (L2 ++ L2')
| MALLOpRE1 : forall L1 L2 F G, MALLSeq L1 (F :: L2) -> MALLSeq L1 (F ooo G :: L2)
| MALLOpRE2 : forall L1 L2 F G, MALLSeq L1 (G :: L2) -> MALLSeq L1 (F ooo G :: L2)
| MALLOpL : forall L1 L2 F G, MALLSeq (F :: L1) L2 -> MALLSeq (G :: L1) L2 -> MALLSeq (F ooo G :: L1) L2
| MALLWithR : forall L1 L2 F G, MALLSeq L1 (F :: L2) -> MALLSeq L1 (G :: L2) -> MALLSeq L1 (F &* G :: L2)
| MALLWithL1 : forall L1 L2 F G, MALLSeq (F :: L1) L2 ->  MALLSeq (F &* G :: L1) L2
| MALLWithL2 : forall L1 L2 F G, MALLSeq (G :: L1) L2 ->  MALLSeq (F &* G :: L1) L2
| MALLExR : forall  L1 L2 L2', Permutation L2 L2' -> MALLSeq L1 L2' -> MALLSeq L1 L2
| MALLExL : forall  L1 L2 L1', Permutation L1 L1' -> MALLSeq L1' L2 -> MALLSeq L1 L2
.

Global Instance MALLL_morph :
  Proper ((@Permutation uexp) ==> (@Permutation uexp) ==> iff) (MALLSeq).
Proof.
  unfold Proper; unfold respectful.
  intros.
  split;intros;subst.
  eapply MALLExR with (L2':=x0);auto. apply Permutation_sym;auto.
  eapply MALLExL with (L1':=x);auto. apply Permutation_sym;auto.
  eapply MALLExR with (L2':=y0);auto.
  eapply MALLExL with (L1':=y);auto.
Qed.

Ltac solveOLTheory :=
  try
    match goal with
    | [|- OLTheory _] =>
      first [ apply ooth_init ; auto ; SolveIS
            | do 2 constructor;auto ; SolveIS ]
    end.

Hint Unfold LEncode REncode : core .
Theorem Soundeness: forall L1 L2, MALLSeq L1 L2 ->
                                isOLFormulaL L1 ->
                                isOLFormulaL L2 ->
                                seq OLTheory []  ( (LEncode L1) ++  (REncode L2)) (> []).
Proof with solveF;solveLL;solveOLTheory;SolveIS;solveOLTheory.
  intros.
  induction H.
  + (* init *)
    decide3 (RINIT F)...
    tensor (REncode [F]) (LEncode [F]).
  + (* TensorR *)
    decide3 (makeRRuleBin TENSOR  F G)...
    tensor [u| F *** G |] ( LEncode (L1 ++ L1') ++  REncode (L2 ++ L2')).

    assert (Permutation (LEncode (L1 ++ L1') ++ REncode (L2 ++ L2')) ((LEncode L1 ++ REncode L2 ) ++ (LEncode L1' ++ REncode L2' ))).
    autounfold; repeat rewrite map_app...
    rewrite H3.
    tensor (LEncode L1 ++ REncode L2)(LEncode L1' ++ REncode L2').
    sLLPerm ((LEncode L1 ++ (REncode (F ::L2)))).
    apply IHMALLSeq1...
    apply ForallAppInv1 in H0...
    apply ForallAppInv1 in H7...
    sLLPerm ((LEncode L1' ++ (REncode (G ::L2')))).
    apply IHMALLSeq2...
    apply ForallAppInv2 in H0...
    apply ForallAppInv2 in H7...
  + (* TensorL *)
    decide3 (makeLRuleBin TENSOR  F G)...
    tensor  [d| F *** G |]  (LEncode L1 ++ REncode L2).
    sLLPerm ( LEncode( F :: G :: L1) ++ REncode L2).
    apply IHMALLSeq...
  + (* Par Right *)
    decide3 (makeRRuleBin PAR  F G)...
    tensor  [u| F $$$ G |] (LEncode L1 ++ REncode L2).
    sLLPerm ( (LEncode L1) ++ REncode (F :: G :: L2)).
    apply IHMALLSeq...
  + (* Par Left *)
    decide3 (makeLRuleBin PAR  F G)...
    tensor [d| F $$$ G|]  (LEncode (L1 ++ L1') ++ REncode (L2 ++ L2')).
    assert (Permutation (LEncode (L1 ++ L1') ++ REncode (L2 ++ L2')) ((LEncode L1 ++ REncode L2 ) ++ (LEncode L1' ++ REncode L2' ))).
    autounfold; repeat rewrite map_app...
    rewrite H3.
    tensor (LEncode L1 ++ REncode L2)(LEncode L1' ++ REncode L2').
    sLLPerm (LEncode (F::L1) ++ REncode L2).
    apply  IHMALLSeq1...
    apply ForallAppInv1 in H7...
    apply ForallAppInv1 in H1...
    sLLPerm (LEncode (G::L1') ++ REncode L2').
    apply  IHMALLSeq2...
    apply ForallAppInv2 in H7...
    apply ForallAppInv2 in H1...
  + (* Oplus1 *)
    decide3 (makeRRuleBin OPLUS  F G)...
    tensor [u| F ooo G |] (LEncode L1 ++ REncode L2).
    oplus1.
    sLLPerm ( (LEncode L1) ++ (REncode (F :: L2))).
    apply IHMALLSeq...
  + (* Oplus2 *)
    decide3 (makeRRuleBin OPLUS  F G)...
    tensor [u| F ooo G |] (LEncode L1 ++ REncode L2).
    oplus2.
    sLLPerm ( (LEncode L1) ++ (REncode (G :: L2))).
    apply IHMALLSeq...
  + (* Oplus Left *)
    decide3 (makeLRuleBin OPLUS  F G)...
    tensor [d| F ooo G |] (LEncode L1 ++ REncode L2).
    sLLPerm ( LEncode ( F:: L1) ++ REncode L2).
    apply IHMALLSeq1...
    sLLPerm ( LEncode ( G:: L1) ++ REncode L2).
    apply IHMALLSeq2...
  + (* With R *)
    decide3 (makeRRuleBin WITH  F G)...
    tensor [u| F &* G |] (LEncode L1 ++ REncode L2).
    sLLPerm ( LEncode L1  ++ REncode (F::L2)).
    apply IHMALLSeq1...
    sLLPerm ( LEncode L1  ++ REncode (G::L2)).
    apply IHMALLSeq2...
  + (*WithL 1 *)
    decide3 (makeLRuleBin WITH  F G)...
    tensor [d| F &* G |] (LEncode L1 ++ REncode L2).
    oplus1.
    sLLPerm ( LEncode (F ::L1)  ++  REncode L2).
    apply IHMALLSeq...
  + (*WithL 2 *)
    decide3 (makeLRuleBin WITH  F G)...
    tensor [d| F &* G |] (LEncode L1 ++ REncode L2).
    oplus2.
    sLLPerm ( LEncode (G ::L1)  ++  REncode L2).
    apply IHMALLSeq...
  + (* Exchange *)
    eapply Permutation_map in  H as H'.
    unfold REncode; rewrite H'...
    apply IHMALLSeq...
    rewrite <- H...
  + (* Exchange *)
    eapply Permutation_map in  H as H'.
    unfold LEncode; rewrite H'...
    apply IHMALLSeq...
    rewrite <- H...
Qed.

Ltac toMALL H :=
  match (type of H) with
  | In (u| _ |)(LEncode _ ++ REncode _) =>
    apply upRight in H; apply OLInPermutation in H;CleanContext;
    eapply MALLExR; [apply Permutation_sym; eauto|]
  | In (d| _ |)(LEncode _ ++ REncode _) =>
    apply downLeft in H; apply OLInPermutationL in H;CleanContext;
    eapply MALLExL; [apply Permutation_sym;eauto | ]
  | seqN _ _ (u| ?F | :: LEncode ?L ++ REncode ?R) [] (> []) =>
    apply exchangeCCN with (CC' := LEncode L ++ REncode (F :: R)) in H ;[| simpl; perm]
  | seqN _ _ (u| ?F | :: ?T :: LEncode ?L ++ REncode ?R) [] (> []) =>
    apply exchangeCCN with (CC' := T :: LEncode L ++ REncode (F :: R)) in H ;[| simpl; perm]
  | seqN _ _ (d| ?F | :: LEncode ?L ++ REncode ?R) [] (> []) =>
    apply exchangeCCN with (CC' := LEncode (F :: L) ++ REncode R) in H ;[| simpl; perm]
  | seqN _ _ (d| ?F | :: ?T :: LEncode ?L ++ REncode ?R) [] (> []) =>
    apply exchangeCCN with (CC' := T :: LEncode (F::L) ++ REncode R) in H ;[| simpl; perm]
  end.

(** The cut-elimination theorem instantiated for LK *)
Check OLCutElimination wellTheory_p OLTheoryIsFormula_p OLTheoryIsFormulaD_p.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

(* Definitions related to pseudoradom functions.  This file copies some items from ConstructedFunc.v, so we probably need to refactor this in the future. *)

Set Implicit Arguments.
Require Import FCF.FCF.
Require Import FCF.CompFold.
Require Export FCF.Array.
Require Export FCF.Hybrid.

Local Open Scope list_scope.
Local Open Scope array_scope.

Theorem fst_split_map_eq : forall (A B : Type)(ls : list (A * B)),
  fst (split ls) = map fst ls.

  induction ls; intuition idtac; simpl in *.
  remember (split ls) as z. destruct z.
  simpl in *.
  congruence.

Qed.

Theorem any_dec_arrayLookup_swap :
  forall (A B : Set)(eqda : EqDec A)(ls1 ls2 : list (A * B)),
  any_dec (fun x => if (arrayLookup _ ls1 x) then true else false) (fst (split ls2)) =
  any_dec (fun x => if (arrayLookup _ ls2 x) then true else false) (fst (split ls1)).

  unfold any_dec in *.
  induction ls1; intuition idtac; simpl in *.
  eapply fold_left_orb_all_false.
  remember (split ls1) as z.
  destruct z.
  simpl in *.
  case_eq (arrayLookup eqda ls2 a0); intros.
  rewrite fold_left_orb_true.
  eapply (fold_left_orb_ex).
  rewrite eqb_refl.
  trivial.
  eapply arrayLookup_In_split.
  eauto.
  rewrite <- IHls1.
  eapply fold_left_f_eq.
  intuition.
  case_eq (eqb b0 a0); intros.
  rewrite eqb_leibniz in H1.
  subst.
  exfalso.
  eapply arrayLookup_None_not_In; eauto.
  reflexivity.

Qed.

Definition oracleMap(D R S: Set)(eqds : EqDec S)(eqdr : EqDec R)(oracle : S  -> D -> Comp (R * S))(s : S)(ds : list D) :=
  compFold _
  (fun acc d => [rs, s] <-2 acc; [r, s] <-$2 oracle s d; ret (rs ++ r :: nil, s))
  (nil, s) ds.

Theorem oracleMap_wf :
  forall (D R S : Set)(eqds : EqDec S)(eqdr : EqDec R) (oracle : S -> D -> Comp (R * S))ds s,
  (forall s x, well_formed_comp (oracle s x)) ->
  well_formed_comp (@oracleMap D R S _ _ oracle s ds).

  intuition.
  unfold oracleMap.
  eapply compFold_wf; intuition.
  wftac.

Qed.

Section RandomFunc.

  Variable D R : Set.
  Variable RndR : Comp R.

  Hypothesis EqDec_D : EqDec D.
  #[export] Instance EqDec_R : EqDec R.
    eapply comp_EqDec.
    eauto.
  Qed.

  Hypothesis RndR_wf : well_formed_comp RndR.

    (* A random function *)
  Definition randomFunc (f : (list (D * R))) (d : D) : Comp (R * list (D * R)) :=
      match (arrayLookup _ f d) with
        | None => (r <-$ RndR; ret (r, (d, r) :: f))
        | Some r => ret (r, f)
      end.

  Lemma randomFunc_wf : forall f d,
    well_formed_comp (randomFunc f d).

    intuition.
    unfold randomFunc.
    case_eq (f#d); intuition; wftac.

  Qed.

  Hint Resolve randomFunc_wf : wftac.

  (* Eager random functions with finite domain *)
  Definition RndFunc(lsd : list D) : Comp (list (D * R)) :=
    compFold _ (fun f d => r <-$ RndR; ret (d, r)::f) nil lsd.

  Definition lookupEq (ls1 ls2 : list (D * R)) :=
    forall d, arrayLookup _ ls1 d = arrayLookup _ ls2 d.

End RandomFunc.

Theorem randomFunc_lookupEq_spec : forall (D R : Set)(eqdd : EqDec D)(eqdr : EqDec R)(RndR : Comp R)(ls1 ls2 : list (D * R)),
  lookupEq _ ls1 ls2 ->
  forall d, comp_spec (fun p1 p2 => fst p1 = fst p2 /\ lookupEq _ (snd p1) (snd p2)) (randomFunc RndR _ ls1 d) (randomFunc RndR _ ls2 d).

  intros.
  unfold randomFunc.
  rewrite H.
  case_eq (arrayLookup _ ls2 d); intros.
  fcf_simp.
  eapply comp_spec_ret; intuition idtac.

  fcf_skip.
  eapply comp_base_exists; eauto.
  eapply comp_base_exists; eauto.
  eapply comp_spec_ret; intuition idtac.
  unfold lookupEq; intuition idtac; simpl.
  rewrite H.
  reflexivity.

Qed.

Section RandomFunc_hist.

  Variable D R : Set.

  Hypothesis EqDec_D : EqDec D.
  Hypothesis EqDec_R : EqDec R.

  Variable RndR : Comp R.

  Hypothesis RndR_wf : well_formed_comp RndR.

  (* a random function that keeps track of all call history *)
  Definition randomFunc_hist (ls : list (D * R))(d : D) :=
    r <-$ match (arrayLookup _ ls d) with
    | None => RndR
    | Some r => ret r
    end;
    ret (r, ((d,r):: ls)).

  Theorem randomFunc_hist_wf : forall ls d,
    well_formed_comp (randomFunc_hist ls d).

    unfold randomFunc_hist.
    intuition idtac.
    destruct (arrayLookup _ ls d);
    wftac.

  Qed.
  Hint Resolve randomFunc_hist_wf : wf.

  Theorem randomFunc_hist_spec : forall (ls1 ls2 : list (D * R)),
    lookupEq _ ls1 ls2 ->
    forall d, comp_spec (fun p1 p2 => fst p1 = fst p2 /\ lookupEq _ (snd p1) (snd p2)) (randomFunc RndR _ ls1 d) (randomFunc_hist ls2 d).

    intros.
    unfold randomFunc, randomFunc_hist.
    rewrite H.
    case_eq (arrayLookup _ ls2 d); intros.
    fcf_simp.
    eapply comp_spec_ret; intuition idtac.
    unfold lookupEq.
    intuition idtac.
    simpl.
    case_eq (eqb d0 d); intros.
    rewrite eqb_leibniz in H1.
    subst.
    rewrite H.
    trivial.
    eauto.

    fcf_skip.
    eapply comp_base_exists; eauto.
    eapply comp_base_exists; eauto.
    eapply comp_spec_ret; intuition idtac.
    unfold lookupEq; intuition idtac; simpl.
    rewrite H.
    reflexivity.

  Qed.

  (* nested random functions--- always track call history and have two separate lists, allowing the proof to
    identify whether a query was made after some point in time. *)
  Definition nestedRandomFunc (st : list (D * R)) s q :=
    match (arrayLookup _ st q) with
    | None => randomFunc RndR _ s q
    | Some r => ret (r, (q, r)::s)
    end.

  Theorem nestedRandomFunc_wf : forall (ls s : list (D * R)) d,
    well_formed_comp (nestedRandomFunc ls s d).

    intros.
    unfold nestedRandomFunc.
    destruct (arrayLookup _ ls d); wftac.
    eapply randomFunc_wf.
    trivial.

  Qed.

  Definition nestedRandomFunc_pred (st s1 s2 : list (D * R)) : Prop :=
    (forall d, arrayLookup _ s1 d = arrayLookup _ (st ++ s2) d).

  Theorem nestedRandomFunc_spec : forall st s1 s2 (d : D),
    (nestedRandomFunc_pred st s1 s2) ->
    comp_spec (fun p1 p2 => fst p1 = fst p2 /\
      (nestedRandomFunc_pred st (snd p1) (snd p2)))
    (randomFunc RndR _ s1 d)
    (nestedRandomFunc st s2 d).

    unfold nestedRandomFunc_pred in *;
    intros.
    unfold nestedRandomFunc.
    case_eq (arrayLookup _ st d); intros.
    unfold randomFunc.
    rewrite H.
    erewrite arrayLookup_app_Some; eauto.
    eapply comp_spec_ret; intuition idtac.
    simpl in *.
    rewrite H.
    case_eq (eqb d0 d); intros.
    rewrite eqb_leibniz in H1.
    subst.
    repeat erewrite (arrayLookup_app_Some); eauto.
    case_eq (arrayLookup _ st d0); intros.
    repeat erewrite (arrayLookup_app_Some); eauto.
    repeat rewrite (arrayLookup_app_None); eauto.
    simpl.
    rewrite H1.
    trivial.

    unfold randomFunc.
    rewrite H.
    rewrite arrayLookup_app_None.
    case_eq (arrayLookup _ s2 d); intros.
    eapply comp_spec_ret; intuition idtac.
    fcf_skip.
    eapply comp_base_exists; eauto.
    eapply comp_base_exists; eauto.
    eapply comp_spec_ret; intuition idtac.
    simpl.
    rewrite H.
    case_eq (eqb d0 d); intros.
    rewrite eqb_leibniz in H4.
    subst.
    rewrite arrayLookup_app_None; eauto.
    simpl.
    rewrite eqb_refl.
    trivial.
    case_eq (arrayLookup _ st d0); intros.
    repeat erewrite (arrayLookup_app_Some); eauto.
    repeat rewrite arrayLookup_app_None; eauto.
    simpl.
    rewrite H4.
    trivial.
    trivial.

  Qed.

  Theorem nestedRandomFunc_app_spec : forall ls ls1 x1 x2 a,
    (forall y, arrayLookup _ x1 y = arrayLookup _ x2 y) ->
    comp_spec
    (fun y1 y2  =>
     any_dec
       (fun y =>
        if
         arrayLookup _ ls (fst y)
        then true
        else false) (snd y1) =
     any_dec
       (fun y =>
        if
         arrayLookup _ ls (fst y)
        then true
        else false) (snd y2) /\
     (any_dec
        (fun y =>
         if
          arrayLookup _ ls (fst y)
         then true
         else false) (snd y1) = false ->
      (forall z,
       arrayLookup _ (snd y1) z =
       arrayLookup _ (snd y2) z) /\
      fst y1 = fst y2))
    (nestedRandomFunc
       (ls ++ ls1) x1 a)
    (nestedRandomFunc ls1 x2 a).

    intros.
    unfold nestedRandomFunc.

    match goal with
    | [|- context[match ?a with | Some _ => _ | None => _ end] ] =>
        case_eq a; intros
    end.
    match goal with
    | [H: arrayLookup ?eqd (?ls1 ++ ?ls2) ?a = Some _ |- _] =>
      case_eq (arrayLookup eqd ls1 a); intros
    end.
    erewrite arrayLookup_app_Some in H0; eauto.
    inversion H0; clear H0; subst.

    match goal with
    | [|- context[match ?a with | Some _ => _ | None => _ end] ] =>
        case_eq a; intros
    end.
    eapply comp_spec_ret; intuition idtac.
    simpl in *.
    repeat rewrite any_dec_cons.
    simpl.
    match goal with
    | [|- context[if ?a then _ else _] ] =>
      replace a with (Some r)
    end;
    simpl; trivial.

    simpl in *.
    rewrite any_dec_cons in *.
    apply orb_false_elim in H2.
    intuition.
    simpl in *.
    match goal with
    | [H: (if ?a then _ else _) = false |- _] =>
      replace a with (Some r) in H
    end; trivial.
    discriminate.
    simpl in *.

    rewrite any_dec_cons in *.
    apply orb_false_elim in H2.
    intuition idtac.
    simpl in *.
    match goal with
    | [H: (if ?a then _ else _) = false |- _] =>
      replace a with (Some r) in H
    end; trivial.
    discriminate.

    unfold randomFunc.
    match goal with
    | [|- context[match ?a with | Some _ => _ | None => _ end] ] =>
        case_eq a; intros
    end.
    eapply comp_spec_ret; intuition idtac.
    simpl in *.
    rewrite any_dec_cons.
    simpl.
    match goal with
    | [|- context[if ?a then _ else _] ] =>
      replace a with (Some r)
    end; trivial.
    simpl.
    symmetry.
    eapply ex_any_dec.
    eapply arrayLookup_Some_impl_In.
    eauto.
    simpl.
    match goal with
    | [|- context[if ?a then _ else _] ] =>
      replace a with (Some r)
    end;
    simpl; trivial.

    simpl in *.
    rewrite any_dec_cons in *.
    apply orb_false_elim in H3.
    intuition idtac.
    simpl in *.
    match goal with
    | [H: (if ?a then _ else _) = false |- _] =>
      replace a with (Some r) in H
    end; trivial.
    discriminate.

    simpl in *.
    rewrite any_dec_cons in *.
    apply orb_false_elim in H3.
    intuition idtac.
    simpl in *.
    match goal with
    | [H: (if ?a then _ else _) = false |- _] =>
      replace a with (Some r) in H
    end; trivial.
    discriminate.

    fcf_irr_r.
    eapply comp_spec_ret; intuition idtac.
    simpl in *.
    repeat rewrite any_dec_cons.
    simpl in *.
    repeat rewrite (any_dec_map fst (fun y =>if (arrayLookup _ ls y) then true else false)).
    repeat rewrite <- fst_split_map_eq.
    rewrite any_dec_arrayLookup_swap.
    symmetry.
    rewrite any_dec_arrayLookup_swap.
    symmetry.
    f_equal.
    eapply any_dec_f_eq.
    intuition idtac.
    rewrite H.
    reflexivity.
    simpl in *.
    rewrite any_dec_cons in *.
    apply orb_false_elim in H4.
    intuition idtac.
    simpl in *.
    match goal with
    | [H: (if ?a then _ else _) = false |- _] =>
      replace a with (Some r) in H
    end; trivial.
    discriminate.
    simpl in *.
    rewrite any_dec_cons in *.
    apply orb_false_elim in H4.
    intuition idtac.
    simpl in *.
    match goal with
    | [H: (if ?a then _ else _) = false |- _] =>
      replace a with (Some r) in H
    end; trivial.
    discriminate.

    rewrite arrayLookup_app_None in H0.
    rewrite H0.
    eapply comp_spec_ret; intuition idtac.
    simpl in *.
    repeat rewrite any_dec_cons.
    simpl in *.
    repeat rewrite (any_dec_map fst (fun y =>if (arrayLookup _ ls y) then true else false)).
    repeat rewrite <- fst_split_map_eq.
    rewrite any_dec_arrayLookup_swap.
    symmetry.
    rewrite any_dec_arrayLookup_swap.
    symmetry.
    f_equal.
    eapply any_dec_f_eq.
    intuition idtac.
    rewrite H.
    reflexivity.
    simpl in *.
    rewrite H.
    reflexivity.
    trivial.

    match goal with
    | [H: arrayLookup ?eqd (?ls1 ++ ?ls2) ?a = None |- _] =>
      case_eq (arrayLookup eqd ls1 a); intros
    end.
    erewrite arrayLookup_app_Some in H0; eauto.
    discriminate.
    rewrite arrayLookup_app_None in H0.
    rewrite H0.

    unfold randomFunc.
    rewrite H.

    match goal with
    | [|- context[match ?a with | Some _ => _ | None => _ end] ] =>
        case_eq a; intros
    end.
    eapply comp_spec_ret; intuition idtac.
    simpl in *.
    repeat rewrite (any_dec_map fst (fun y =>if (arrayLookup _ ls y) then true else false)).
    repeat rewrite <- fst_split_map_eq.
    rewrite any_dec_arrayLookup_swap.
    symmetry.
    rewrite any_dec_arrayLookup_swap.
    symmetry.
    eapply any_dec_f_eq.
    intuition idtac.
    rewrite H.
    reflexivity.

    fcf_skip.
    eapply comp_base_exists; eauto.
    eapply comp_base_exists; eauto.
    eapply comp_spec_ret; intuition idtac.
    simpl in *.
    repeat rewrite any_dec_cons.
    repeat rewrite (any_dec_map fst (fun y =>if (arrayLookup _ ls y) then true else false)).
    repeat rewrite <- fst_split_map_eq.
    rewrite any_dec_arrayLookup_swap.
    symmetry.
    rewrite any_dec_arrayLookup_swap.
    symmetry.
    f_equal.
    eapply any_dec_f_eq.
    intuition idtac.
    rewrite H.
    reflexivity.

    simpl.
    rewrite H.
    reflexivity.
    trivial.

   Qed.

  (* a list of random values with history *)
  Definition rndHist (ls : list (D * R))(d : D) :=
    r <-$ RndR;
    ret (r, (d,r)::ls).
  Theorem rndHist_wf : forall ls d,
    well_formed_comp (rndHist ls d).

    unfold rndHist.
    intuition idtac; wftac.

  Qed.

  Hint Resolve rndHist_wf : wf.

End RandomFunc_hist.

Local Open Scope type_scope.
Local Open Scope comp_scope.

Section PRF_concrete.

  Variable D R Key : Set.
  Variable RndKey : Comp Key.
  Variable RndR : Comp R.
  Variable f : Key -> D -> R.

  Hypothesis D_EqDec : EqDec D.
  Hypothesis R_EqDec : EqDec R.

  Definition RndR_func : (list (D * R) -> D -> Comp (R * list (D * R))) :=
    (randomFunc RndR _).

  Section PRF_NA_concrete.
  (* A PRF that is secure against a non-adaptive adversary. *)

    Variable State : Set.
    Variable A1 : Comp (list D * State).
    Variable A2 : State -> list R -> Comp bool.

    Definition PRF_NA_G_A : Comp bool :=
      [lsD, s_A] <-$2 A1;
      lsR <-$ (k <-$ RndKey; ret (map (f k) lsD));
      A2 s_A lsR.

    Definition PRF_NA_G_B : Comp bool :=
      [lsD, s_A] <-$2 A1;
      [lsR, _] <-$2 oracleMap _ _ RndR_func nil lsD;
      A2 s_A lsR.

    Definition PRF_NA_Advantage :=
    | Pr[PRF_NA_G_A] - Pr[PRF_NA_G_B] |.

  End PRF_NA_concrete.

  Section PRF_NAI_concrete.

    Variable A_state : Set.
    Variable A1 : Comp ((list (list D)) * A_state).
    Variable A2 : A_state -> list (list R) -> Comp bool.

    Definition PRF_NAI_G0 :=
      [lsDs, s_A] <-$2 A1;
      lsRs <-$ compMap _ (fun lsD => k <-$ RndKey; ret (map (f k) lsD)) lsDs;
      A2 s_A lsRs.

    Definition PRF_NAI_G1 :=
      [lsDs, s_A] <-$2 A1;
      lsRs <-$ compMap _ (fun lsD => [lsR, _] <-$2 oracleMap _ _ RndR_func nil lsD; ret lsR) lsDs;
      A2 s_A lsRs.

    Definition PRF_NAI_Advantage :=
    | Pr[PRF_NAI_G0] - Pr[PRF_NAI_G1] |.

  Section PRF_NA_impl_NAI.

    Variable maxLists : nat.
    Hypothesis maxLists_correct :
      forall ls s_A,
        In (ls, s_A) (getSupport A1) ->
        (length ls <= maxLists)%nat.

    Hypothesis A_state_EqDec : EqDec A_state.
    Hypothesis RndR_wf : well_formed_comp RndR.
    Hypothesis RndKey_wf : well_formed_comp RndKey.

    Variable maxDistance : Rat.
    Hypothesis maxDistance_correct :
      forall i,
      PRF_NA_Advantage (B1 nil _ _ A1 i) (B2 (fun lsD => k <-$ RndKey; ret (map (f k) lsD))
              (fun lsD => [lsR, _] <-$2 oracleMap _ _ RndR_func nil lsD; ret lsR)
              _ A2) <= maxDistance.

    Theorem PRF_NAI_Advantage_eq_Hybrid:
      PRF_NAI_Advantage == ListHybrid_Advantage
                             (fun lsD => k <-$ RndKey; ret (map (f k) lsD))
                             (fun lsD => [lsR, _] <-$2 oracleMap _ _ RndR_func nil lsD; ret lsR)
                             _ A1 A2.

      reflexivity.

    Qed.

    Theorem PRF_NA_impl_NAI :
      PRF_NAI_Advantage <= (maxLists / 1 * maxDistance)%rat.

      rewrite PRF_NAI_Advantage_eq_Hybrid.
      rewrite Single_impl_ListHybrid.
      reflexivity.

      intuition.
      wftac.

      intuition.
      wftac.
      eapply oracleMap_wf.
      intuition.
      eapply randomFunc_wf; intuition.
      intuition.

      intuition.

      assert (DistSingle_Adv (fun lsD : list D => k <-$ RndKey; ret map (f k) lsD)
     (fun lsD : list D =>
      z <-$
      oracleMap (list_EqDec (pair_EqDec D_EqDec R_EqDec)) R_EqDec RndR_func
        nil lsD; [lsR, _]<-2 z; ret lsR)
     (B1 nil (list_EqDec D_EqDec) A_state_EqDec A1 i)
     (B2 (fun lsD : list D => k <-$ RndKey; ret map (f k) lsD)
        (fun lsD : list D =>
         z <-$
         oracleMap (list_EqDec (pair_EqDec D_EqDec R_EqDec)) R_EqDec
           RndR_func nil lsD; [lsR, _]<-2 z; ret lsR)
        (list_EqDec R_EqDec) A2)
     ==
     PRF_NA_Advantage
                          (B1 nil (list_EqDec D_EqDec) A_state_EqDec A1 i)
                          (B2
                             (fun lsD : list D =>
                              k <-$ RndKey; ret map (f k) lsD)
                             (fun lsD : list D =>
                              z <-$
                              oracleMap
                                (list_EqDec (pair_EqDec D_EqDec R_EqDec))
                                R_EqDec RndR_func nil lsD;
                              [lsR, _]<-2 z; ret lsR)
                             (list_EqDec R_EqDec) A2)
                          ).
      unfold DistSingle_Adv, PRF_NA_Advantage, DistSingle_G, PRF_NA_G_A, PRF_NA_G_B.
      eapply ratDistance_eqRat_compat;
        repeat (try comp_skip; try reflexivity; comp_simp; inline_first).
      rewrite H.
      clear H.
      intuition.
    Qed.

  End PRF_NA_impl_NAI.

  End PRF_NAI_concrete.

  Section PRF_Full_concrete.

    Variable A : OracleComp D R bool.

    Definition f_oracle(k : Key)(x : unit)(d : D) :=
      ret (f k d, tt).

    Definition PRF_G_A : Comp bool :=
      k <-$ RndKey;
      [b, _] <-$2 A _ _ (f_oracle k) tt;
      ret b.

    Definition PRF_G_B : Comp bool :=
      [b, _] <-$2 A _ _ (RndR_func) nil;
      ret b.

    Definition PRF_Advantage :=
    | Pr[PRF_G_A] - Pr[PRF_G_B] |.

  End PRF_Full_concrete.

  Section PRF_Finite_concrete.

    Variable dom : list D.
    Variable def : R.
    Variable A : (D -> R) -> Comp bool.

    Definition PRF_Fin_G_A : Comp bool :=
      k <-$ RndKey;
      A (f k).

    Definition PRF_Fin_G_B : Comp bool :=
      f <-$ @RndFunc D R RndR _ dom;
      A (fun d => arrayLookupDef _ f d def).

    Definition PRF_Fin_Advantage :=
    | Pr[PRF_Fin_G_A] - Pr[PRF_Fin_G_B] |.

  End PRF_Finite_concrete.

End PRF_concrete.

Require Import FCF.Asymptotic.
Require Import FCF.Admissibility.

Section PRF.

  Variable D R Key : DataTypeFamily.
  Variable RndKey : forall n, Comp (Key n).
  Variable RndR : forall n, Comp (R n).
  Variable f : forall n, Key n -> D n -> R n.

  Hypothesis D_EqDec : forall n, EqDec (D n).
  Hypothesis R_EqDec : forall n, EqDec (R n).

  Section PRF_NA.
    Variable admissible_A1 : pred_comp_fam.
    Variable admissible_A2 : pred_comp_func_2_fam.

    Definition PRF_NA :=
      forall (State : DataTypeFamily) A1 A2,
        admissible_A1 _ A1 ->
        admissible_A2 State _ _ A2 ->
        negligible (fun n => PRF_NA_Advantage (RndKey n) (RndR n) (@f n) _ _ (A1 n) (@A2 n)).
  End PRF_NA.

  Section PRF_Full.
    Variable admissible_A : pred_oc_fam.

    Definition PRF :=
      forall (A : forall n, OracleComp (D n) (R n) bool),
        admissible_A _ _ _ A ->
        negligible (fun n => PRF_Advantage (RndKey n) (RndR n) (@f n) _ _ (A n)).
  End PRF_Full.

End PRF.


Require Import Stlc.LemmasEvaluation.
Require Import Stlc.LemmasTyping.
Require Import Stlc.SpecEvaluation.
Require Import Stlc.SpecEquivalent.
Require Import Stlc.SpecSyntax.
Require Import Stlc.SpecTyping.
Require Import Utlc.Fix.
Require Import Utlc.LemmasEvaluation.
Require Import Utlc.LemmasScoping.
Require Import Utlc.SpecEvaluation.
Require Import Utlc.SpecEquivalent.
Require Import Utlc.SpecScoping.
Require Import Utlc.SpecSyntax.
Require Import UVal.UVal.

Module S.
  Include Stlc.LemmasEvaluation.
  Include Stlc.LemmasTyping.
  Include Stlc.SpecEvaluation.
  Include Stlc.SpecEquivalent.
  Include Stlc.SpecSyntax.
  Include Stlc.SpecTyping.
End S.

Module U.
  Include Utlc.Fix.
  Include Utlc.LemmasEvaluation.
  Include Utlc.LemmasScoping.
  Include Utlc.SpecEvaluation.
  Include Utlc.SpecEquivalent.
  Include Utlc.SpecScoping.
  Include Utlc.SpecSyntax.
End U.

Inductive Prec : Set :=
| precise
| imprecise.

Inductive PTy : Set :=
| ptarr (τ₁ τ₂ : PTy)
| ptunit
| ptbool
| ptprod (τ₁ τ₂ : PTy)
| ptsum (τ₁ τ₂ : PTy)
| pEmulDV (n : nat) (p : Prec).

Fixpoint repEmul (τ : PTy) : Ty :=
  match τ with
    | ptarr τ₁ τ₂ => tarr (repEmul τ₁) (repEmul τ₂)
    | ptunit => tunit
    | ptbool => tbool
    | ptprod τ₁ τ₂ => tprod (repEmul τ₁) (repEmul τ₂)
    | ptsum τ₁ τ₂ => tsum (repEmul τ₁) (repEmul τ₂)
    | pEmulDV n p => UVal n
  end.

Definition OfTypeStlc (τ : PTy) (t : S.Tm) : Prop :=
  S.Value t ∧ ⟪ empty ⊢ t : repEmul τ ⟫.

Fixpoint OfTypeUtlc' (τ : PTy) (t : U.UTm) : Prop :=
  match τ with
    | ptarr τ₁ τ₂ =>
      match t with
        | U.abs _ => True
        | _       => False
      end
    | ptunit => t = U.unit
    | ptbool => t = U.true ∨ t = U.false
    | ptprod τ₁ τ₂ =>
      match t with
        | U.pair t₁ t₂ => OfTypeUtlc' τ₁ t₁ ∧ OfTypeUtlc' τ₂ t₂
        | _            => False
      end
    | ptsum τ₁ τ₂ =>
      match t with
        | U.inl t₁ => OfTypeUtlc' τ₁ t₁
        | U.inr t₂ => OfTypeUtlc' τ₂ t₂
        | _        => False
      end
    | pEmulDV n p => U.Value t
  end.
Arguments OfTypeUtlc' !τ !t /.

Definition OfTypeUtlc (τ : PTy) (t : U.UTm) : Prop :=
  wsUTm 0 t ∧ OfTypeUtlc' τ t.
Arguments OfTypeUtlc !τ !t /.

Definition OfType (τ : PTy) (t₁ : S.Tm) (t₂ : U.UTm) : Prop :=
  OfTypeStlc τ t₁ ∧ OfTypeUtlc τ t₂.

Inductive PEnv : Set :=
| pempty
| pevar (Γ : PEnv) (τ : PTy).

Notation "Γ p▻ T" := (pevar Γ T) (at level 55, left associativity).

Fixpoint pdom (Γ : PEnv) : Dom :=
  match Γ with
    | pempty => 0
    | pevar Γ _ => S (pdom Γ)
  end.

Reserved Notation "⟪  i : T p∈ Γ  ⟫"
  (at level 0, i at level 98, Γ at level 98).
Inductive GetEvarP : PEnv → Ix → PTy → Prop :=
  | GetEvarHere {Γ T} :
      ⟪   O : T p∈ Γ p▻ T  ⟫
  | GetEvarThere {Γ T T' i} :
      ⟪   i : T p∈ Γ      ⟫ →
      ⟪ S i : T p∈ Γ p▻ T' ⟫
where "⟪  i : T p∈ Γ  ⟫" := (GetEvarP Γ i T).

Lemma pdom_works {i T Γ} :
  ⟪ i : T p∈ Γ ⟫ → pdom Γ ∋ i.
Proof.
  induction 1; constructor; eauto.
Qed.

Lemma pdom_works_inv {i Γ} :
  pdom Γ ∋ i → ∃ τ, ⟪ i : τ p∈ Γ ⟫.
Proof.
  revert i. induction Γ; intros i.
  - inversion 1.
  - inversion 1.
    + subst. exists τ. constructor.
    + subst. destruct (IHΓ i0 H1) as (τ0 & iinΓ).
      exists τ0. constructor. assumption.
Qed.

Fixpoint repEmulCtx (Γ : PEnv) : Env :=
  match Γ with
    | pempty => empty
    | pevar Γ τ => evar (repEmulCtx Γ) (repEmul τ)
  end.

Lemma repEmulCtx_works {Γ i τ} :
  ⟪ i : τ p∈ Γ ⟫ →
  ⟪ i : repEmul τ ∈ repEmulCtx Γ ⟫.
Proof.
  induction 1; eauto using GetEvar.
Qed.

Fixpoint embed (τ : Ty) : PTy :=
  match τ with
    | tarr τ₁ τ₂ => ptarr (embed τ₁) (embed τ₂)
    | tunit => ptunit
    | tbool => ptbool
    | tprod τ₁ τ₂ => ptprod (embed τ₁) (embed τ₂)
    | tsum τ₁ τ₂ => ptsum (embed τ₁) (embed τ₂)
  end.

Fixpoint embedCtx (Γ : Env) : PEnv :=
  match Γ with
      empty => pempty
    | evar Γ τ => pevar (embedCtx Γ) (embed τ)
  end.

Lemma embedCtx_works {Γ i τ} :
  ⟪ i : τ ∈ Γ ⟫ →
  ⟪ i : embed τ p∈ embedCtx Γ ⟫.
Proof.
  induction 1; eauto using GetEvarP.
Qed.

Lemma embedCtx_works_inv {Γ i τ} :
  ⟪ i : τ p∈ embedCtx Γ ⟫ →
  exists τ', τ = embed τ' ∧ ⟪ i : τ' ∈ Γ ⟫.
Proof.
  revert i τ. induction Γ; intros i τ' iτ; simpl in *; inversion iτ; subst.
  - exists τ; intuition.
  - destruct (IHΓ _ _ H3) as [τ'' [eq ty]].
    exists τ''; intuition; eauto using GetEvarP.
Qed.


Require Export Util.
Require Export Net.
Require Export List.
Export ListNotations.

Require Import VerdiTactics.
Require Import UpdateLemmas.
Local Arguments update {_} {_} {_} _ _ _ _ : simpl never.

Fixpoint distinct_pairs_and {A} (R : A -> A -> Prop) (l : list A) : Prop :=
  match l with
    | [] => True
    | x :: xs => (forall y, In y xs -> R x y) /\ distinct_pairs_and R xs
  end.

Class Decomposition (B : BaseParams) (M : MultiParams B) :=
  {
    state_invariant : (name -> data) -> Prop;
    network_invariant : (name -> data) -> packet -> Prop;
    network_network_invariant : packet -> packet -> Prop;

    network_network_invariant_sym :
      forall p1 p2,
        network_network_invariant p1 p2 ->
        network_network_invariant p2 p1 ;

    state_invariant_init : state_invariant init_handlers;

    state_invariant_maintained_input :
      forall h inp sigma st' out ps,
        input_handlers h inp (sigma h) = (out, st', ps) ->
        state_invariant sigma ->
        state_invariant (update sigma h st');
    state_invariant_maintained_deliver :
      forall p sigma st' out ps,
        net_handlers (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (out, st', ps) ->
        state_invariant sigma ->
        network_invariant sigma p ->
        state_invariant (update sigma (pDst p) st');

    network_invariant_maintained_input_old :
      forall h inp sigma st' out ps p,
        input_handlers h inp (sigma h) = (out, st', ps) ->
        state_invariant sigma ->
        network_invariant sigma p ->
        network_invariant (update sigma h st') p;
    network_invariant_maintained_input_new :
      forall h inp sigma st' out ps p,
        input_handlers h inp (sigma h) = (out, st', ps) ->
        state_invariant sigma ->
        In (pDst p, pBody p) ps ->
        pSrc p = h ->
        network_invariant (update sigma h st') p;

    network_invariant_maintained_deliver_old :
      forall sigma st' out ps p q,
        net_handlers (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (out, st', ps) ->
        state_invariant sigma ->
        network_invariant sigma p ->
        network_invariant sigma q ->
        network_network_invariant p q ->
        network_invariant (update sigma (pDst p) st') q;
    network_invariant_maintained_deliver_new :
      forall sigma st' out ps p p',
        net_handlers (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (out, st', ps) ->
        state_invariant sigma ->
        network_invariant sigma p ->
        In (pDst p', pBody p') ps ->
        pSrc p' = pDst p ->
        network_invariant (update sigma (pDst p) st') p';

    network_network_invariant_maintained_input_old :
      forall h inp sigma st' out ps p p',
        input_handlers h inp (sigma h) = (out, st', ps) ->
        state_invariant sigma ->
        network_invariant sigma p ->
        In (pDst p', pBody p') ps ->
        pSrc p' = h ->
        network_network_invariant p p';

    network_network_invariant_maintained_input_new :
      forall h inp sigma st' out ps,
        input_handlers h inp (sigma h) = (out, st', ps) ->
        state_invariant sigma ->
        distinct_pairs_and network_network_invariant (map (fun m => mkPacket h (fst m) (snd m)) ps);

    network_network_invariant_maintained_deliver_old :
      forall sigma st' out ps p p' q,
        net_handlers (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (out, st', ps) ->
        state_invariant sigma ->
        network_invariant sigma p ->
        network_invariant sigma q ->
        network_network_invariant p q ->
        In (pDst p', pBody p') ps ->
        pSrc p' = pDst p ->
        network_network_invariant p' q;

    network_network_invariant_maintained_deliver_new :
      forall sigma st' out ps p,
        net_handlers (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (out, st', ps) ->
        state_invariant sigma ->
        network_invariant sigma p ->
        distinct_pairs_and network_network_invariant (map (fun m => mkPacket (pDst p) (fst m) (snd m)) ps)
  }.

Section Decomposition.
  Context `{d : Decomposition}.

  (* Fixpoint remove_one {A : Type} (A_eq_dec : forall x y : A, {x = y} + {x <> y}) a l :=
    match l with
      | x :: xs => if A_eq_dec a x then xs else x :: remove_one A_eq_dec a xs
      | [] => []
    end. *)

  Definition packet_eq_dec :
    forall p1 p2 : packet,
      {p1 = p2} + {p1 <> p2}.
  Proof.
    intros. decide equality; eauto using name_eq_dec,msg_eq_dec.
  Defined.

  Definition composed_invariant net :=
    (state_invariant (nwState net)) /\
    (forall p, In p (nwPackets net) -> network_invariant (nwState net) p) /\
    (distinct_pairs_and network_network_invariant (nwPackets net)).

  Lemma post_net_analyze_sent_packet :
    forall h p ms xs ys,
      In p (map (fun m => mkPacket h (fst m) (snd m)) ms ++ xs ++ ys) ->
      (In (pDst p, pBody p) ms /\ h = pSrc p) \/ In p (xs ++ ys).
  Proof.
    intros.
    in_crush. destruct x; simpl in *; eauto.
  Qed.

  Lemma post_input_analyze_sent_packet :
    forall h p ms l,
      In p (map (fun m => mkPacket h (fst m) (snd m)) ms ++ l) ->
      (In (pDst p, pBody p) ms /\ h = pSrc p) \/ In p l.
  Proof.
    intros.
    in_crush; destruct x; simpl in *; eauto.
  Qed.

  (* NB: generalizing this over R makes it useless to [eauto using]
     because the conclusion is too general. *)
  Lemma nw_nw_distinct_pairs_and_elim :
    forall xs a b ys l,
      l = xs ++ a :: ys ->
      In b (xs ++ ys) ->
      distinct_pairs_and network_network_invariant l ->
      network_network_invariant a b.
  Proof.
    induction xs; intros; subst; simpl in *; intuition eauto; subst; eauto.
    apply network_network_invariant_sym. eauto.
  Qed.

  Lemma distinct_pairs_and_app_cons :
    forall A R xs p ys l,
      l = (xs ++ p :: ys) ->
      distinct_pairs_and (A:=A) R l ->
      distinct_pairs_and R (xs ++ ys).
  Proof.
    induction xs; intros; subst; simpl in *; intuition eauto.
  Qed.

  Lemma distinct_pairs_and_app :
    forall A R l1 l2,
      distinct_pairs_and (A := A) R l1 ->
      distinct_pairs_and R l2 ->
      (forall x y,
         In x l1 ->
         In y l2 ->
         R x y) ->
      distinct_pairs_and R (l1 ++ l2).
  Proof.
    induction l1; intros; simpl in *; intuition.
    find_apply_lem_hyp in_app_or.
    intuition eauto.
  Qed.

  Theorem decomposition_invariant :
    inductive_invariant step_m step_m_init composed_invariant.
  Proof.
    unfold inductive_invariant. intuition.
    - unfold composed_invariant. simpl.
      intuition auto using state_invariant_init.
    - unfold inductive, composed_invariant. intros.
      match goal with H : step_m _ _ _ |- _ => invcs H end; intuition; simpl in *.
      + eauto using state_invariant_maintained_deliver.
      + find_apply_lem_hyp post_net_analyze_sent_packet.
        intuition
          eauto 10 using
              network_invariant_maintained_deliver_new,
              network_invariant_maintained_deliver_old,
              nw_nw_distinct_pairs_and_elim,
              network_network_invariant_sym.
      + apply distinct_pairs_and_app;
        eauto using network_network_invariant_maintained_deliver_new, distinct_pairs_and_app_cons.

        intros. do_in_map. subst.
        eapply network_network_invariant_maintained_deliver_old;
          eauto using nw_nw_distinct_pairs_and_elim.
        simpl; now rewrite <- surjective_pairing.
      + eauto using state_invariant_maintained_input.
      + find_apply_lem_hyp post_input_analyze_sent_packet.
        intuition
          eauto using network_invariant_maintained_input_new,
                      network_invariant_maintained_input_old.
      + apply distinct_pairs_and_app;
            eauto using network_network_invariant_maintained_input_new.
        intros.
        do_in_map. subst.
        apply network_network_invariant_sym.
        eapply network_network_invariant_maintained_input_old; eauto.
        simpl. now rewrite <- surjective_pairing.
  Qed.
End Decomposition.


From Coq Require Import ZArith .
From Common Require Import Var .
From mQhasm Require Import zDSL zRadix .
From mathcomp Require Import seq .

Open Scope N_scope.
Open Scope zdsl_scope.

Definition fe25519_mul_stage3_2 : program :=

let         wsize :=   64%nat in

let crypto_sign_ed25519_amd64_51_REDMASK51 :=
                       2251799813685247%Z in (* 0x7FFFFFFFFFFFF from consts *)
let crypto_sign_ed25519_amd64_51_REDMASK51_width :=
                       51 in        (* 51 bits *)

let            x0 :=   0 in (* *[uint64 *](xp +  0) *)
let            x1 :=   1 in (* *[uint64 *](xp +  8) *)
let            x2 :=   2 in (* *[uint64 *](xp + 16) *)
let            x3 :=   3 in (* *[uint64 *](xp + 24) *)
let            x4 :=   4 in (* *[uint64 *](xp + 32) *)
let            y0 :=   5 in (* *[uint64 *](yp +  0) *)
let            y1 :=   6 in (* *[uint64 *](yp +  8) *)
let            y2 :=   7 in (* *[uint64 *](yp + 16) *)
let            y3 :=   8 in (* *[uint64 *](yp + 24) *)
let            y4 :=   9 in (* *[uint64 *](yp + 32) *)
let            z0 :=  10 in (* *[uint64 *](rp +  0) *)
let            z1 :=  11 in (* *[uint64 *](rp +  8) *)
let            z2 :=  12 in (* *[uint64 *](rp + 16) *)
let            z3 :=  13 in (* *[uint64 *](rp + 24) *)
let            z4 :=  14 in (* *[uint64 *](rp + 32) *)
let         carry := 999 in
let           tmp := 998 in
let          tmp2 := 997 in

let            r0 :=  20 in
let            r1 :=  21 in
let            r2 :=  22 in
let            r3 :=  23 in
let            r4 :=  24 in

let            c0 :=  30 in
let            c1 :=  31 in
let            c2 :=  32 in
let            c3 :=  33 in
let            c4 :=  34 in

let        mulr01 :=  40 in
let        mulr11 :=  41 in
let        mulr21 :=  42 in
let        mulr31 :=  43 in
let        mulr41 :=  44 in

let        mulrax :=  50 in
let        mulrdx :=  51 in
let          mult :=  52 in
let    mulredmask :=  53 in
let       mulx219 :=  54 in
let       mulx319 :=  55 in
let       mulx419 :=  56 in
[::
zAssign z0 (zVar r0);
zAssign z1 (zVar r1);
zAssign z2 (zVar r2);
zAssign z3 (zVar r3);
zAssign z4 (zVar r4);
      (*  *)
      (*   mult = r0 *)
      (*   (uint64) mult >>= 51 *)
      (*   mult += r1 *)
zAssign mult (zVar r0);
zSplit mult tmp (zVar mult) 51;
zAssign mult (zBinop zAdd (zVar mult) (zVar r1));
      (*   r1 = mult *)
      (*   (uint64) mult >>= 51 *)
      (*   r0 &= mulredmask *)
      (*   mult += r2 *)
zAssign r1 (zVar mult);
zSplit mult tmp2 (zVar mult) 51;
zAssign r0 (zVar tmp);
zAssign mult (zBinop zAdd (zVar mult) (zVar r2));
      (*   r2 = mult *)
      (*   (uint64) mult >>= 51 *)
      (*   r1 &= mulredmask *)
      (*   mult += r3 *)
zAssign r2 (zVar mult);
zSplit mult tmp (zVar mult) 51;
zAssign r1 (zVar tmp2);
zAssign mult (zBinop zAdd (zVar mult) (zVar r3));
      (*   r3 = mult *)
      (*   (uint64) mult >>= 51 *)
      (*   r2 &= mulredmask *)
      (*   mult += r4 *)
zAssign r3 (zVar mult);
zSplit mult tmp2 (zVar mult) 51;
zAssign r2 (zVar tmp);
zAssign mult (zBinop zAdd (zVar mult) (zVar r4));
      (*   r4 = mult *)
      (*   (uint64) mult >>= 51 *)
      (*   r3 &= mulredmask *)
zAssign r4 (zVar mult);
zSplit mult tmp (zVar mult) 51;
zAssign r3 (zVar tmp2);
      (*   mult *= 19 *)
      (*   r0 += mult *)
      (*   r4 &= mulredmask *)
zAssign mult (zBinop zMul (zVar mult) (zConst 19%Z));
zAssign r0 (zBinop zAdd (zVar r0) (zVar mult));
zAssign r4 (zVar tmp)
      (*   #END MACRO mul *)

      (*  *)
      (*   #// var lhs = r0_512 + r1_512 * 2**51 + r2_512 * 2**102 + r3_512 * 2**153 + r4_512 * 2**204 *)
      (*   #//     rhs = r0@u512 + r1@u512 * 2**51 + r2@u512 * 2**102 + r3@u512 * 2**153 + r4@u512 * 2**204 *)
      (*  *)
      (*   #// assert 0 <=u r0 <=u 2**52 && *)
      (*   #//        0 <=u r1 <=u 2**52 && *)
      (*   #//        0 <=u r2 <=u 2**52 && *)
      (*   #//        0 <=u r3 <=u 2**52 && *)
      (*   #//        0 <=u r4 <=u 2**52 && *)
      (*   #//        (lhs - rhs) %u (2**255 - 19) = 0 *)
      (*  *)
] .

Definition fe25519_mul_stage3_2_inputs : VS.t :=
let            x0 :=   0 in (* *[uint64 *](xp +  0) *)
let            x1 :=   1 in (* *[uint64 *](xp +  8) *)
let            x2 :=   2 in (* *[uint64 *](xp + 16) *)
let            x3 :=   3 in (* *[uint64 *](xp + 24) *)
let            x4 :=   4 in (* *[uint64 *](xp + 32) *)
let            y0 :=   5 in (* *[uint64 *](yp +  0) *)
let            y1 :=   6 in (* *[uint64 *](yp +  8) *)
let            y2 :=   7 in (* *[uint64 *](yp + 16) *)
let            y3 :=   8 in (* *[uint64 *](yp + 24) *)
let            y4 :=   9 in (* *[uint64 *](yp + 32) *)
let            z0 :=  10 in (* *[uint64 *](rp +  0) *)
let            z1 :=  11 in (* *[uint64 *](rp +  8) *)
let            z2 :=  12 in (* *[uint64 *](rp + 16) *)
let            z3 :=  13 in (* *[uint64 *](rp + 24) *)
let            z4 :=  14 in (* *[uint64 *](rp + 32) *)
let         carry := 999 in
let           tmp := 998 in
let          tmp2 := 997 in
let            r0 :=  20 in
let            r1 :=  21 in
let            r2 :=  22 in
let            r3 :=  23 in
let            r4 :=  24 in
let            c0 :=  30 in
let            c1 :=  31 in
let            c2 :=  32 in
let            c3 :=  33 in
let            c4 :=  34 in
let        mulr01 :=  40 in
let        mulr11 :=  41 in
let        mulr21 :=  42 in
let        mulr31 :=  43 in
let        mulr41 :=  44 in
let        mulrax :=  50 in
let        mulrdx :=  51 in
let          mult :=  52 in
let    mulredmask :=  53 in
let       mulx219 :=  54 in
let       mulx319 :=  55 in
let       mulx419 :=  56 in
VSLemmas.OP.P.of_list [:: r0; r1; r2; r3; r4].

Definition fe25519_mul_stage3_2_pre : bexp := zTrue.

Definition fe25519_mul_stage3_2_post : bexp :=
let            x0 :=   0 in (* *[uint64 *](xp +  0) *)
let            x1 :=   1 in (* *[uint64 *](xp +  8) *)
let            x2 :=   2 in (* *[uint64 *](xp + 16) *)
let            x3 :=   3 in (* *[uint64 *](xp + 24) *)
let            x4 :=   4 in (* *[uint64 *](xp + 32) *)
let            y0 :=   5 in (* *[uint64 *](yp +  0) *)
let            y1 :=   6 in (* *[uint64 *](yp +  8) *)
let            y2 :=   7 in (* *[uint64 *](yp + 16) *)
let            y3 :=   8 in (* *[uint64 *](yp + 24) *)
let            y4 :=   9 in (* *[uint64 *](yp + 32) *)
let            z0 :=  10 in (* *[uint64 *](rp +  0) *)
let            z1 :=  11 in (* *[uint64 *](rp +  8) *)
let            z2 :=  12 in (* *[uint64 *](rp + 16) *)
let            z3 :=  13 in (* *[uint64 *](rp + 24) *)
let            z4 :=  14 in (* *[uint64 *](rp + 32) *)
let         carry := 999 in
let           tmp := 998 in
let          tmp2 := 997 in
let            r0 :=  20 in
let            r1 :=  21 in
let            r2 :=  22 in
let            r3 :=  23 in
let            r4 :=  24 in
let            c0 :=  30 in
let            c1 :=  31 in
let            c2 :=  32 in
let            c3 :=  33 in
let            c4 :=  34 in
let        mulr01 :=  40 in
let        mulr11 :=  41 in
let        mulr21 :=  42 in
let        mulr31 :=  43 in
let        mulr41 :=  44 in
let        mulrax :=  50 in
let        mulrdx :=  51 in
let          mult :=  52 in
let    mulredmask :=  53 in
let       mulx219 :=  54 in
let       mulx319 :=  55 in
let       mulx419 :=  56 in
let        n25519 := 57896044618658097711785492504343953926634992332820282019728792003956564819949%Z in
zEqMod
  (radix51 [::zVar z0; zVar z1; zVar z2; zVar z3; zVar z4])
  (radix51 [::zVar r0; zVar r1; zVar r2; zVar r3; zVar r4])
  (zConst n25519).

Definition fe25519_mul_stage3_2_spec :=
  {| spre := fe25519_mul_stage3_2_pre;
     sprog := fe25519_mul_stage3_2;
     spost := fe25519_mul_stage3_2_post |}.

From mathcomp Require Import eqtype ssrbool.
From mQhasm Require Import zVerify.

Lemma valid_fe25519_mul_stage3_2 : valid_zspec (fe25519_mul_stage3_2_inputs, fe25519_mul_stage3_2_spec).
Proof.
  time "valid_fe25519_mul_stage3_2" verify_zspec.
Qed.

Close Scope zdsl_scope.
Close Scope N_scope.