Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.HList.
Require Import ExtLib.Tactics.
Require Import MirrorCore.Lemma.
Require Import MirrorCore.Util.Forwardy.
Require Import MirrorCore.Util.Compat.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.Lambda.ExprTac.
Require Import MirrorCore.Views.Ptrns.

Set Implicit Arguments.
Set Strict Implicit.

Section setoid.
  Context {typ : Set}.
  Context {func : Set}.
  Context {RType_typD : RType typ}.
  Context {Typ2_Fun : Typ2 RType_typD RFun}.
  Context {RSym_func : RSym func}.

  (** Reasoning principles **)
  Context {RTypeOk_typD : RTypeOk}.
  Context {Typ2Ok_Fun : Typ2Ok Typ2_Fun}.
  Context {RSymOk_func : RSymOk RSym_func}.
  Context {Typ0_Prop : Typ0 _ Prop}.
  Context {RelDec_eq_typ : RelDec (@eq typ)}.
  Context {RelDec_Correct_eq_typ : RelDec_Correct RelDec_eq_typ}.

  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.

  Variable Rbase : Set.
  Variable Rbase_eq : Rbase -> Rbase -> bool.
  Hypothesis Rbase_eq_ok : forall a b, Rbase_eq a b = true -> a = b.

  Inductive R : Set :=
  | Rinj (r : Rbase)
  | Rrespects (l r : R)
  | Rpointwise (t : typ) (r : R)
  | Rflip (r : R).

  Definition Rflip' (r : R) : R :=
    match r with
    | Rflip r => r
    | _ => Rflip r
    end.

  Fixpoint Req_dec (a b : R) : bool :=
    match a , b with
    | Rinj a , Rinj b => Rbase_eq a b
    | Rrespects l r , Rrespects l' r' =>
      if Req_dec l l' then Req_dec r r' else false
    | Rpointwise t a , Rpointwise t' a' =>
      if t ?[ eq ] t' then Req_dec a a' else false
    | Rflip a , Rflip b => Req_dec a b
    | _ , _ => false
    end.

  Theorem Req_dec_ok : forall x y : R, Req_dec x y = true -> x = y.
  Proof.
    clear - RTypeOk_typD Rbase_eq_ok RelDec_Correct_eq_typ.
    induction x; destruct y; simpl; try solve [ congruence ].
    { intros.
      eapply Rbase_eq_ok in H. destruct H; reflexivity. }
    { specialize (IHx1 y1).
      specialize (IHx2 y2).
      destruct (Req_dec x1 y1); intros; try congruence.
      destruct (Req_dec x2 y2); intros; try congruence.
      f_equal; tauto. }
    { consider (t ?[ eq ] t0); intros.
      { subst. f_equal; eauto. } }
    { intros. eapply IHx in H. f_equal. assumption. }
  Qed.

  Variable RbaseD : Rbase -> forall t : typ, option (typD t -> typD t -> Prop).

  Hypothesis RbaseD_single_type
  : forall r t1 t2 rD1 rD2,
      RbaseD r t1 = Some rD1 ->
      RbaseD r t2 = Some rD2 ->
      t1 = t2.

  (** This is due to universe problems! **)
  Definition respectful :=
    fun (A B : Type) (R : A -> A -> Prop) (R' : B -> B -> Prop)
        (f g : A -> B) =>
      forall x y : A, R x y -> R' (f x) (g y).

  Definition pointwise_relation :=
    fun (A B : Type) (R : B -> B -> Prop) (f g : A -> B) =>
      forall a : A, R (f a) (g a).

  Definition flip (A : Type) (R : A -> A -> Prop) : A -> A -> Prop :=
    fun x y => R y x.

  Fixpoint RD (r : R) (t : typ) : option (typD t -> typD t -> Prop) :=
    match r with
      | Rinj r => RbaseD r t
      | Rrespects l r =>
        typ2_match (F:=RFun) (fun T => option (T -> T -> Prop)) t
                   (fun lt rt =>
                      match RD l lt , RD r rt with
                        | Some l , Some r => Some (respectful l r)
                        | _ , _ => None
                      end)
                   None
      | Rpointwise _t r =>
        typ2_match (F:=RFun) (fun T => option (T -> T -> Prop)) t
                   (fun lt rt =>
                      match type_cast lt _t with
                        | Some _ =>
                          match RD r rt with
                            | Some r => Some (pointwise_relation (A:=typD lt) r)
                            | _ => None
                          end
                        | None => None
                      end)
                   None
      | Rflip r =>
        match RD r t with
        | Some rD => Some (flip rD)
        | None => None
        end
    end.

  Theorem RD_single_type
  : forall r t1 t2 rD1 rD2,
      RD r t1 = Some rD1 ->
      RD r t2 = Some rD2 ->
      t1 = t2.
  Proof using tyArr RbaseD_single_type Typ2Ok_Fun.
    induction r; simpl; intros.
    { eapply RbaseD_single_type; eauto. }
    { destruct (typ2_match_case t2) as [ [ ? [ ? [ ? H1 ] ] ] | H1 ];
        rewrite H1 in *; [ clear H1 | congruence ].
      destruct (typ2_match_case t1) as [ [ ? [ ? [ ? H1 ] ] ] | H1 ];
        rewrite H1 in *; [ clear H1 | congruence ].
      revert H; revert H0.
      red in x4; red in x1; subst.
      simpl.
      autorewrite_with_eq_rw.
      intros; forwardy; inv_all; subst.
      f_equal; eauto. }
    { destruct (typ2_match_case t2) as [ [ ? [ ? [ ? H1 ] ] ] | H1 ];
        rewrite H1 in *; [ clear H1 | congruence ].
      destruct (typ2_match_case t1) as [ [ ? [ ? [ ? H1 ] ] ] | H1 ];
        rewrite H1 in *; [ clear H1 | congruence ].
      revert H; revert H0.
      red in x4; red in x1; subst.
      simpl.
      autorewrite_with_eq_rw.
      intros; forwardy; inv_all; subst.
      red in y0, y3; subst.
      f_equal; eauto. }
    { forwardy.
      inv_all. subst. eauto. }
  Qed.

  (** Patterns *)
  Definition ptrnRinj {T : Type} (p : ptrn Rbase T) : ptrn R T :=
    fun r _T good bad =>
      match r with
      | Rinj a => p a _T good (fun x => bad (Rinj x))
      | Rrespects a b => bad (Rrespects a b)
      | Rpointwise a b => bad (Rpointwise a b)
      | Rflip a => bad (Rflip a)
      end.

  Global Instance ptrn_ok_ptrnRinj {T} p : ptrn_ok p -> ptrn_ok (@ptrnRinj T p).
  Proof using.
    unfold ptrnRinj; red; intros.
    destruct x; simpl; try solve [ right; red; eauto ].
    destruct (H r).
    { left; destruct H0. exists x. red. eauto. }
    { right. red. red in H0. intros.
      setoid_rewrite H0. reflexivity. }
  Qed.

  Theorem Succeeds_ptrnRinj {T} p x res
  : ptrn_ok p ->
    Succeeds x (@ptrnRinj T p) res ->
    exists y, Succeeds y p res /\ x = Rinj y.
  Proof using.
    destruct x; unfold Succeeds; simpl; intros;
    try solve [ ptrn_contradict ].
    eexists; split; eauto.
    intros.
    destruct (H r) as [ [ ? ? ] | ? ].
    { red in H1. setoid_rewrite H1 in H0. setoid_rewrite H1. eauto. }
    { red in H1. setoid_rewrite H1 in H0.
      ptrn_contradict. }
  Qed.

  Global Instance SucceedsE_ptrnRinj {T} p x res
  : ptrn_ok p -> SucceedsE x (@ptrnRinj T p) res :=
  { s_result := exists y, Succeeds y p res /\ x = Rinj y }.
  intros.  eauto using Succeeds_ptrnRinj.
  Defined.

  Definition ptrnRflip {T : Type} (p : ptrn R T)
  : ptrn R T :=
    fun r _T good bad =>
      match r with
      | Rinj a => bad (Rinj a)
      | Rrespects a b => bad (Rrespects a b)
      | Rpointwise a b => bad (Rpointwise a b)
      | Rflip a => p a _T good (fun x => bad (Rflip x))
      end.

  Global Instance ptrn_ok_ptrnRflip {T} p : ptrn_ok p -> ptrn_ok (@ptrnRflip T p).
  Proof using.
    unfold ptrnRflip; red; intros.
    destruct x; simpl; try solve [ right; red; eauto ].
    destruct (H x).
    { left; destruct H0. exists x0. red. eauto. }
    { right. red. red in H0. intros.
      setoid_rewrite H0. reflexivity. }
  Qed.

  Theorem Succeeds_ptrnRflip {T} p x res
  : ptrn_ok p ->
    Succeeds x (@ptrnRflip T p) res ->
    exists y, Succeeds y p res /\ x = Rflip y.
  Proof using.
    destruct x; unfold Succeeds; simpl; intros;
    try solve [ ptrn_contradict ].
    eexists; split; eauto.
    intros.
    destruct (H x) as [ [ ? ? ] | ? ].
    { red in H1. setoid_rewrite H1 in H0. setoid_rewrite H1. eauto. }
    { red in H1. setoid_rewrite H1 in H0.
      ptrn_contradict. }
  Qed.

  Global Instance SucceedsE_ptrnRflip {T} p x res
  : ptrn_ok p -> SucceedsE x (@ptrnRflip T p) res :=
  { s_result := exists y, Succeeds y p res /\ x = Rflip y }.
  intros.  eauto using Succeeds_ptrnRflip.
  Defined.

  Definition ptrnRrespectsL {T U : Type}
             (pd : ptrn R (T -> U))
             (pr : ptrn R T)
  : ptrn R U :=
    fun r _T good bad =>
      match r with
      | Rinj a => bad (Rinj a)
      | Rrespects a b => pr b _T (fun x => pd a _T (fun y => good (y x))
                                              (fun a => bad (Rrespects a b)))
                            (fun b => bad (Rrespects a b))
      | Rpointwise a b => bad (Rpointwise a b)
      | Rflip a => bad (Rflip a)
      end.

  Global Instance ptrn_ok_ptrnRrespectsL {T U} pl pr
  : ptrn_ok pl -> ptrn_ok pr -> ptrn_ok (@ptrnRrespectsL T U pl pr).
  Proof using.
    unfold ptrnRrespectsL; red; intros.
    destruct x; simpl; try solve [ right; red; eauto ].
    destruct (H x1); destruct (H0 x2).
    { forward_reason. left.
      unfold Succeeds in *. exists (x0 x). intros.
      setoid_rewrite H2. setoid_rewrite H1. reflexivity. }
    { right. red. red in H2.
      setoid_rewrite H2. eauto. }
    { right. destruct H2. red in H1, H2.
      red. setoid_rewrite H2. setoid_rewrite H1. eauto. }
    { right. red in H1, H2.
      red. setoid_rewrite H2. eauto. }
  Qed.

  Theorem Succeeds_ptrnRrespectsL {T U} pl pr x res
  : ptrn_ok pl -> ptrn_ok pr ->
    Succeeds x (@ptrnRrespectsL T U pl pr) res ->
    exists y z resL resR, Succeeds y pl resL /\ Succeeds z pr resR /\
                          x = Rrespects y z /\ res = resL resR.
  Proof using.
    destruct x; unfold Succeeds; simpl; intros;
    try solve [ ptrn_contradict ].
    exists x1; exists x2.
    destruct (H0 x2).
    { destruct H2; red in H2. setoid_rewrite H2 in H1.
      destruct (H x1).
      { destruct H3; red in H3; setoid_rewrite H3 in H1.
        do 2 eexists. split; eauto. split; eauto.
        split; eauto.
        specialize (H1 _ (fun x => x) (fun _ => res)).
        symmetry; assumption. }
      { red in H3. setoid_rewrite H3 in H1.
        ptrn_contradict. } }
    { red in H2. setoid_rewrite H2 in H1. ptrn_contradict. }
  Qed.

  Global Instance SucceedsE_ptrnRrespectsL {T U} pl pr x res
  : ptrn_ok pl -> ptrn_ok pr -> SucceedsE x (@ptrnRrespectsL T U pl pr) res :=
  { s_result := exists y z resL resR, Succeeds y pl resL /\ Succeeds z pr resR /\
                          x = Rrespects y z /\ res = resL resR }.
  intros.  eauto using Succeeds_ptrnRrespectsL.
  Defined.

  Definition ptrnRpointwiseL {T U : Type}
             (pd : ptrn typ (T -> U))
             (pr : ptrn R T)
  : ptrn R U :=
    fun r _T good bad =>
      match r with
      | Rinj a => bad (Rinj a)
      | Rpointwise a b => pr b _T (fun x => pd a _T (fun y => good (y x))
                                              (fun a => bad (Rpointwise a b)))
                            (fun b => bad (Rpointwise a b))
      | Rrespects a b => bad (Rrespects a b)
      | Rflip a => bad (Rflip a)
      end.

  Global Instance ptrn_ok_ptrnRpointwiseL {T U} pl pr
  : ptrn_ok pl -> ptrn_ok pr -> ptrn_ok (@ptrnRpointwiseL T U pl pr).
  Proof using.
    unfold ptrnRpointwiseL; red; intros.
    destruct x; simpl; try solve [ right; red; eauto ].
    destruct (H t); destruct (H0 x).
    { forward_reason. left.
      unfold Succeeds in *. setoid_rewrite H2.
      setoid_rewrite H1. eauto. }
    { right. red. red in H2.
      setoid_rewrite H2. eauto. }
    { right. destruct H2. red in H1, H2.
      red. setoid_rewrite H2. setoid_rewrite H1. eauto. }
    { right. red in H1, H2.
      red. setoid_rewrite H2. eauto. }
  Qed.

  Theorem Succeeds_ptrnRpointwiseL {T U} pl pr x res
  : ptrn_ok pl -> ptrn_ok pr ->
    Succeeds x (@ptrnRpointwiseL T U pl pr) res ->
    exists y z resL resR, Succeeds y pl resL /\ Succeeds z pr resR /\
                          x = Rpointwise y z /\ res = resL resR.
  Proof using.
    destruct x; unfold Succeeds; simpl; intros;
    try solve [ ptrn_contradict ].
    exists t; exists x.
    destruct (H0 x).
    { destruct H2; red in H2. setoid_rewrite H2 in H1.
      destruct (H t).
      { destruct H3; red in H3; setoid_rewrite H3 in H1.
        do 2 eexists. split; eauto. split; eauto.
        split; eauto.
        specialize (H1 _ (fun x => x) (fun _ => res)).
        symmetry; assumption. }
      { red in H3. setoid_rewrite H3 in H1.
        ptrn_contradict. } }
    { red in H2. setoid_rewrite H2 in H1. ptrn_contradict. }
  Qed.

  Global Instance SucceedsE_ptrnRpointwiseL {T U} pl pr x res
  : ptrn_ok pl -> ptrn_ok pr -> SucceedsE x (@ptrnRpointwiseL T U pl pr) res :=
  { s_result := exists y z resL resR, Succeeds y pl resL /\ Succeeds z pr resR /\
                          x = Rpointwise y z /\ res = resL resR }.
  intros.  eauto using Succeeds_ptrnRpointwiseL.
  Defined.

  Section refl_trans_types.
    Context {T} (RD : T -> forall t : typ, option (typD t -> typD t -> Prop)).

    Definition refl_dec : Type := T -> bool.
    Definition trans_dec : Type := T -> bool.
    Definition refl_dec_ok (rd : refl_dec) : Prop :=
      forall r t rD, rd r = true -> RD r t = Some rD -> Reflexive rD.
    Definition trans_dec_ok (rd : trans_dec) : Prop :=
      forall r t rD, rd r = true -> RD r t = Some rD -> Transitive rD.
  End refl_trans_types.

  Arguments refl_dec _ : clear implicits.
  Arguments trans_dec _ : clear implicits.

  (** Reflexivity and transitivity *)
  Section is_refl.
    Lemma Refl_pointwise : forall {T U : Type} (R : T -> T -> Prop),
      Reflexive R -> Reflexive (pointwise_relation (A:=U) R).
    Proof using.
      compute. auto.
    Qed.

    Variable is_refl : refl_dec Rbase.
    Definition is_reflR : refl_dec R :=
      fix is_reflR (r : R) : bool :=
        match r with
        | Rinj r => is_refl r
        | Rpointwise _ x => is_reflR x
        | Rflip r => is_reflR r
        | _ => false
        end.

    Hypothesis is_reflOk : refl_dec_ok RbaseD is_refl.

    Theorem is_reflROk : refl_dec_ok RD is_reflR.
    Proof using Typ2Ok_Fun is_reflOk.
      red.
      induction r; simpl; intros; eauto; try congruence.
      { simpl. intros.
        destruct (typ2_match_case t0) as [ [ ? [ ? [ ? H1 ] ] ] | H1 ];
          rewrite H1 in *; [ clear H1 | congruence ].
        revert H0.
        red in x1; subst; simpl.
        autorewrite_with_eq_rw.
        intros. forwardy; inv_all; subst.
        eapply IHr in H; [ | eassumption ].
        red.
        intro. autorewrite_with_eq_rw.
        eapply Refl_pointwise. eassumption. }
      { forwardy; inv_all; subst.
        red. intros. unfold flip. eapply IHr; eauto. }
    Qed.
  End is_refl.

  Section is_trans.
    Lemma Trans_pointwise : forall {T U : Type} (R : T -> T -> Prop),
        Transitive R -> Transitive (pointwise_relation (A:=U) R).
    Proof using.
      compute. eauto.
    Qed.

    Variable is_trans : trans_dec Rbase.
    Definition is_transR : trans_dec R :=
      fix is_transR (r : R) : bool :=
        match r with
        | Rinj r => is_trans r
        | Rpointwise _ x => is_transR x
        | Rflip r => is_transR r
        | _ => false
        end.

    Hypothesis is_transOk : trans_dec_ok RbaseD is_trans.

    Theorem is_transROk : trans_dec_ok RD is_transR.
    Proof using Typ2Ok_Fun is_transOk.
      red.
      induction r; simpl; intros; eauto; try congruence.
      { simpl. intros.
        destruct (typ2_match_case t0) as [ [ ? [ ? [ ? H1 ] ] ] | H1 ];
          rewrite H1 in *; [ clear H1 | congruence ].
        revert H0.
        red in x1; subst; simpl.
        autorewrite_with_eq_rw.
        intros. forwardy; inv_all; subst.
        eapply IHr in H; [ | eassumption ].
        red.
        do 3 intro. autorewrite_with_eq_rw.
        eapply Trans_pointwise. eassumption. }
      { forwardy; inv_all; subst.
        red. intros. unfold flip. eapply IHr; eauto. }
    Qed.
  End is_trans.

  (** Rewriting Lemmas **)
  Section lemmas.
    (** Note: This could be parameterized by the type of expressions
     **)
    Existing Instance Expr_expr.

    Record rw_concl : Type :=
    { lhs : expr typ func
    ; rel : R
    ; rhs : expr typ func }.

    Definition rw_lemma : Set :=
      Lemma.lemma typ (expr typ func) rw_concl.

    Definition rw_conclD (tus tvs : tenv typ) (c : rw_concl)
    : option (exprT tus tvs Prop) :=
      match typeof_expr tus tvs c.(lhs) with
      | None => None
      | Some t =>
        match lambda_exprD tus tvs t c.(lhs)
            , lambda_exprD tus tvs t c.(rhs)
            , RD c.(rel) t
        with
        | Some lhs , Some rhs , Some rel =>
          Some (fun us vs => rel (lhs us vs) (rhs us vs))
        | _ , _ , _ => None
        end
      end.

    Lemma rw_concl_weaken
    : forall (tus tvs : tenv typ) (l : rw_concl) (lD : exprT tus tvs Prop),
        rw_conclD tus tvs l = Some lD ->
        forall tus' tvs' : list typ,
        exists lD' : exprT (tus ++ tus') (tvs ++ tvs') Prop,
          rw_conclD (tus ++ tus') (tvs ++ tvs') l = Some lD' /\
          (forall (us : hlist typD tus) (us' : hlist typD tus')
                  (vs : hlist typD tvs) (vs' : hlist typD tvs'),
              lD us vs <-> lD' (hlist_app us us') (hlist_app vs vs')).
    Proof.
      unfold rw_conclD. simpl. intros.
      forwardy. inv_all. subst.
      erewrite ExprFacts.typeof_expr_weaken by eauto.
      eapply ExprFacts.lambda_exprD_weaken in H0; eauto.
      destruct H0 as [ ? [ Hx ? ] ]; rewrite Hx; clear Hx.
      eapply ExprFacts.lambda_exprD_weaken in H1; eauto.
      destruct H1 as [ ? [ Hx ? ] ]; rewrite Hx; clear Hx.
      rewrite H2. eexists; split; eauto.
      intros. simpl. rewrite <- H0. rewrite <- H1. reflexivity.
    Qed.

    Definition flip_rw_concl (a : rw_concl) : rw_concl :=
    {| lhs := a.(rhs)
     ; rel := Rflip' a.(rel)
     ; rhs := a.(lhs)
     |}.

    Definition flip_rw_lemma (lem : rw_lemma) : rw_lemma :=
    {| vars := lem.(vars)
     ; premises := lem.(premises)
     ; concl := flip_rw_concl lem.(concl) |}.

    Lemma RD_Rflip'_Rflip : forall a b,
        RD (Rflip' a) b = RD (Rflip a) b.
    Proof.
      destruct a; simpl; eauto.
      intros. destruct (RD a b); reflexivity.
    Qed.

    Theorem flip_rw_lemma_sound
    : forall (lem : rw_lemma),
        lemmaD rw_conclD nil nil lem ->
        lemmaD rw_conclD nil nil (flip_rw_lemma lem).
    Proof using RTypeOk_typD Typ2Ok_Fun RSymOk_func.
      unfold lemmaD, lemmaD'. simpl.
      intros. forwardy.
      Cases.rewrite_all_goal.
      destruct (concl lem); simpl in *.
      unfold flip_rw_concl. simpl.
      unfold rw_conclD in *. simpl in *.
      forwardy.
      erewrite lambda_exprD_typeof_Some; eauto.
      Cases.rewrite_all_goal.
      rewrite RD_Rflip'_Rflip.
      simpl.
      Cases.rewrite_all_goal.
      inv_all.
      subst. unfold flip. eauto.
    Qed.

  End lemmas.

End setoid.

Arguments rw_concl typ func Rbase : rename, clear implicits.
Arguments rw_lemma typ func Rbase : rename, clear implicits.
Arguments R typ Rbase : rename, clear implicits.
Arguments Rrespects {_ _} _ _.
Arguments Rpointwise {_ _} _ _.
Arguments Rflip {_ _} _.
Arguments Rinj {_ _} _.
Arguments refl_dec _ : clear implicits.
Arguments trans_dec _ : clear implicits.

Require Import MirrorCore.Reify.ReifyClass.

Section reify_R.
  Variables Ty Rbase : Set.
  Context {Reify_Ty : Reify Ty}.
  Context {Reify_Rbase : Reify Rbase}.

(*
  Local Notation "x @ y" := (@RApp x y) (only parsing, at level 30).
  Local Notation "'!!' x" := (@RExact _ x) (only parsing, at level 25).
  Local Notation "'?' n" := (@RGet n RIgnore) (only parsing, at level 25).
  Local Notation "'?!' n" := (@RGet n RConst) (only parsing, at level 25).
  Local Notation "'#'" := RIgnore (only parsing, at level 0).
*)

  Set Printing Universes.

  Definition reify_R : Command (R Ty Rbase) :=
    CFix
      (CFirst (   CPattern (ls:=_::_::nil)
                           (RApp (RApp (RApp (RApp (RExact (@Morphisms.respectful)) RIgnore) RIgnore) (RGet 0 RIgnore)) (RGet 1 RIgnore))
                           (fun a b : function (CRec 0) => Rrespects (typ:=Ty) (Rbase:=Rbase) a b)
               :: CPattern (ls:=_::_::nil)
                           (RApp (RApp (RApp (RExact (@Morphisms.pointwise_relation)) (RGet 0 RIgnore)) RIgnore) (RGet 1 RIgnore))
                           (fun (a : function@{Set} (CCall (reify_scheme Ty))) (b : function (CRec 0)) =>
                              Rpointwise a b)
               :: CPattern (ls:=_::nil)
                           (RApp (RApp (RApp (RApp (RExact (@Basics.flip)) RIgnore) RIgnore) RIgnore) (RGet 0 RIgnore))
                           (fun a : function (CRec 0) => Rflip a)
               :: CMap (@Rinj Ty _) (reify_scheme Rbase)
               :: nil)).

  Global Instance Reify_R : Reify (R Ty Rbase) :=
  { reify_scheme := CCall reify_R }.
End reify_R.

Section Reify_Proper_concl.
  Variables Ty func Rbase : Set.
  Context {Reify_Ty : Reify Ty}.
  Context {Reify_expr_typ_func : Reify (expr Ty func)}.
  Context {Reify_Rbase : Reify Rbase}.

  Local Notation "x @ y" := (@RApp x y) (only parsing, at level 30).
  Local Notation "'!!' x" := (@RExact _ x) (only parsing, at level 25).
  Local Notation "'?' n" := (@RGet n RIgnore) (only parsing, at level 25).
  Local Notation "'?!' n" := (@RGet n RConst) (only parsing, at level 25).
  Local Notation "'#'" := RIgnore (only parsing, at level 0).

  Definition reify_rw_concl :=
    CPattern (ls:=_::_::_::nil)
             (?0 @ ?1 @ ?2)
             (fun (a : function (reify_scheme (R Ty Rbase))) (b c : function (CCall (reify_scheme (expr Ty func)))) =>
                @Build_rw_concl Ty func Rbase b a c).

  Global Instance Reify_rw_concl : Reify (rw_concl Ty func Rbase) :=
  { reify_scheme := CCall reify_rw_concl }.

End Reify_Proper_concl.


(** * Kernels defined in terms of limits *)
(** ** Contents
- Definition coincides with the direct definition
*)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.CategoryTheory.Core.Categories.

Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Local Open Scope cat.
Require Import UniMath.CategoryTheory.limits.graphs.zero.
Require Import UniMath.CategoryTheory.limits.graphs.equalizers.
Require Import UniMath.CategoryTheory.limits.kernels.

(** * Definition of kernels in terms of limits *)
Section def_kernels.

  Variable C : category.
  Let hs: has_homsets C := homset_property C.
  Variable Z : Zero C.

  Definition Kernel {a b : C} (f : C⟦a, b⟧) := Equalizer C f (ZeroArrow Z a b).

  (** ** Maps between Kernels as limits and direct definition. *)
  Lemma equiv_Kernel1_eq {a b : C} (f : C⟦a, b⟧) (K : limits.kernels.Kernel (equiv_Zero2 Z) f) :
    KernelArrow K · f = KernelArrow K · ZeroArrow Z a b.
  Proof.
    rewrite precomp_with_ZeroArrow. rewrite <- equiv_ZeroArrow. apply KernelCompZero.
  Qed.

  Lemma equiv_Kernel1_isEqualizer {a b : C} (f : C⟦a, b⟧)
        (K : limits.kernels.Kernel (equiv_Zero2 Z) f) :
    isEqualizer C f (ZeroArrow Z a b) K (KernelArrow K) (equiv_Kernel1_eq f K).
  Proof.
    use (make_isEqualizer _ ).
    intros e h' H'.
    use unique_exists.
    (* Construction of the morphism *)
    - use KernelIn.
      + exact h'.
      + rewrite precomp_with_ZeroArrow in H'.
        use (pathscomp0 _ (!(equiv_ZeroArrow e b Z))).
        exact H'.
    (* Commutativity *)
    - cbn. use KernelCommutes.
    (* Equality on equalities of morphisms *)
    - intros y. apply hs.
    (* Uniqueness *)
    - intros y X. cbn in X.
      use limits.kernels.KernelInsEq. unfold KernelArrow.
      use (pathscomp0 X). apply pathsinv0.
      use limits.kernels.KernelCommutes.
  Qed.

  Definition equiv_Kernel1 {a b : C} (f : C⟦a, b⟧) (K : limits.kernels.Kernel (equiv_Zero2 Z) f) :
    Kernel f.
  Proof.
    use make_Equalizer.
    - exact K.
    - exact (KernelArrow K).
    - exact (equiv_Kernel1_eq f K).
    - exact (equiv_Kernel1_isEqualizer f K).
  Defined.

  (* Other direction *)

  Lemma equiv_Kernel2_eq {a b : C} (f : C⟦a, b⟧) (K : Kernel f) :
    EqualizerArrow C K · f = limits.zero.ZeroArrow (equiv_Zero2 Z) (EqualizerObject C K) b.
  Proof.
    rewrite (EqualizerArrowEq C K). rewrite equiv_ZeroArrow.
    rewrite precomp_with_ZeroArrow. apply idpath.
  Qed.

  Lemma equiv_Kernel2_isEqualizer {a b : C} (f : C⟦a, b⟧) (K : Kernel f) :
    isKernel (equiv_Zero2 Z) (EqualizerArrow C K) f (equiv_Kernel2_eq f K).
  Proof.
    use (make_isKernel).
    intros w h H.
    use unique_exists.
    (* Construction of the morphism *)
    - use EqualizerIn.
      + exact h.
      + rewrite H.
        rewrite precomp_with_ZeroArrow.
        apply equiv_ZeroArrow.
    (* Commutativity *)
    - use EqualizerArrowComm.
    (* Equality on equalities of morphisms *)
    - intros y. apply hs.
    (* Uniqueness *)
    - intros y T. cbn in T.
      use EqualizerInUnique. exact T.
  Qed.

  Definition equiv_Kernel2 {a b : C} (f : C⟦a, b⟧) (K : Kernel f) :
    limits.kernels.Kernel (equiv_Zero2 Z) f.
  Proof.
    use make_Kernel.
    - exact (EqualizerObject C K).
    - exact (EqualizerArrow C K).
    - exact (equiv_Kernel2_eq f K).
    - exact (equiv_Kernel2_isEqualizer f K).
  Defined.

End def_kernels.


Require Import Coq.Lists.List
        Coq.Strings.String
        Coq.Sets.Ensembles
        Coq.Arith.Arith
        Fiat.Computation.Core
        Fiat.ADT.ADTSig
        Fiat.ADT.Core
        Fiat.Common.ilist
        Fiat.Common.StringBound
        Fiat.Common.Ensembles.IndexedEnsembles
        Fiat.ADTNotation.BuildADT
        Fiat.ADTNotation.BuildADTSig
        Fiat.QueryStructure.Specification.Representation.QueryStructureSchema
        Fiat.QueryStructure.Specification.Representation.QueryStructure
        Fiat.QueryStructure.Specification.Operations.Mutate.

(* Definitions for updating query structures. *)

(* This update is fairly constrained:
   If the update is consistent with the constraints, it is
   applied to the table,
   OTHERWISE
   No tables are changed. *)
Definition QSUpdate
           qs_schema
           (qs : QueryStructure qs_schema)
           (Ridx : _)
           (UpdatedTuples : @Ensemble (@RawTuple (GetNRelSchemaHeading _ Ridx)))
           (UpdateFunction : Relation_Definitions.relation (@RawTuple (GetNRelSchemaHeading _ Ridx)))
: Comp (QueryStructure qs_schema * list RawTuple) :=
  QSMutate qs Ridx (IndexedEnsembleUpdate (GetRelation qs Ridx) UpdatedTuples UpdateFunction).

Notation "'Update' b 'from' r '!' Ridx 'as' c 'making' Trans 'where' Ens" :=
  (let qs_schema := _ in
   let r' : QueryStructure qs_schema := r in
   let Ridx' := ibound (indexb (@Build_BoundedIndex _ _ (QSschemaNames qs_schema) Ridx%string _)) in
   (QSUpdate r' Ridx'
            (fun b => Ens) (fun b c => Trans)))
    (r at level 0, Ridx at level 0, Ens at level 0, Trans at level 0, at level 80).


(*
Require Import Logic.lib.Coqlib.
Require Import Logic.lib.SublistT.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.QuantifierLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Normal.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.

Local Open Scope logic_base.
Local Open Scope syntax.

Class BindedProofTheory (BL: BinderLanguage): Type := {
  binded_Gamma:> forall ts, ProofTheory (binded_L ts)
}.

Class QuantifierLogic
      (BL: BinderLanguage)
      {nL: forall ts, NormalLanguage (binded_L ts)}
      {qL: QuantifierLanguage BL}
      (BGamma: BindedProofTheory BL)
      {nGamma: forall ts, NormalProofTheory (binded_L ts) (binded_Gamma ts)}
      {mpGamma: forall ts, MinimumPropositionalLogic (binded_L ts) (binded_Gamma ts)} :=
{
  allp_elim: forall (t: type) (ts: list type) (x: binded_expr (t :: ts)) (e: binded_term ts t),
    |-- allp x --> ins_expr x e;
  allp_gen: forall (t: type) (ts: list type) (x: binded_expr ts) (y: binded_expr (t :: ts)),
    |-- lift_expr (sublistT_cons t (sublistT_refl ts)) x --> y ->
    |-- x --> allp y;
  exp_intros: forall (t: type) (ts: list type) (x: binded_expr (t :: ts)) (e: binded_term ts t),
    |-- ins_expr x e --> exp x;
  exp_gen: forall (t: type) (ts: list type) (x: binded_expr (t :: ts)) (y: binded_expr ts),
    |-- x --> lift_expr (sublistT_cons t (sublistT_refl ts)) y ->
    |-- exp x --> y
}.

*)


Set Warnings "-parsing".
From mathcomp Require Import all_ssreflect.
Require Import Real Reals RealCoqReal.
Set Warnings "parsing".
Require Import Psatz.

Section RealHelpers.

  Generalizable Variables K M Real.

  Context `{klb : LazyBool K} `{M_Monad : Monad M}
          {MultivalueMonad_description : Monoid_hom M_Monad NPset_Monad}
          {M_MultivalueMonad : MultivalueMonad}
          {Real : Type}
          {SemiDecOrderedField_Real : SemiDecOrderedField Real}
          {ComplArchiSemiDecOrderedField_Real : ComplArchiSemiDecOrderedField}.

  (* ring structure on Real *)
  Ltac IZReal_tac t :=
    match t with
    | real_0 => constr:(0%Z)
    | real_1 => constr:(1%Z)
    | IZreal ?u =>
      match isZcst u with
      | true => u
      | _ => constr:(InitialRing.NotConstant)
      end
    | _ => constr:(InitialRing.NotConstant)
    end.

  Add Ring realRing : (realTheory ) (constants [IZReal_tac]).

  Lemma IZreal_relator z : relate (IZreal z) (IZR z).
  Proof.
    suff H : forall z', (0 <= z')%Z -> @relate Real  (@IZreal K klb Real SemiDecOrderedField_Real  z') (IZR z').
    - case z => [| p |p]; try by apply H;lia.
      rewrite IZreal_neg IZR_NEG.
      apply relate_subtraction.
        by apply H.
        apply Z_of_nat_prop.
        elim => [| n' IH]; first by rewrite Nat2Z.inj_0;apply relate_constant0.
        rewrite Nat2Z.inj_succ.
        have -> : (Z.succ (Z.of_nat n')) = ((Z.of_nat n') +1)%Z by lia.
        rewrite IZreal_hom plus_IZR.
        apply relate_addition =>//.
        suff -> : (@IZreal _ _ _ SemiDecOrderedField_Real 1) = (@real_1 _ _ _ SemiDecOrderedField_Real) by apply relate_constant1.
        intros.
        simpl; auto.
  Qed.

  Lemma relate_IZreal z x : relate (IZreal z) x -> x = (IZR z).
  Proof.
    suff H: relate (@IZreal _ _ _ SemiDecOrderedField_Real z) (IZR z).
    - move => R.
        by relate.
          by apply IZreal_relator.
  Qed.

  Lemma relate_prec n : relate (prec n) (/ 2 ^ n)%R.
  Proof.
    elim n =>  [ /=  | n' IH ]; first by rewrite Rinv_1; apply relate_constant1.
    have -> : (prec n'.+1) = (prec n') * (prec 1).
    - have -> : n'.+1 = (n'+1)%coq_nat by lia.
        apply (prec_hom n' 1).
        have -> : (prec 1) = (real_1 / real_2_neq_0) by [].
        rewrite  /= Rinv_mult_distr; [| by lra| by apply pow_nonzero].
        rewrite Rmult_comm.
        apply relate_multiplication => //.
        rewrite /real_div.
        have -> : (/ 2 = 1 *  /2)%R by lra.
        apply relate_multiplication; first by apply relate_constant1.
        apply (relate_divison real_2 real_2_neq_0 2).
          by apply IZreal_relator.
  Qed.

(* Ltac classical := *)
(*   match goal with *)
(*   | |- eq ?x ?y => apply transport_eq;   intro; intro; intro; intro; classical (* (fail "not implemented yet") *) *)
(*   | |- ?x < ?y => apply transport_lt; intro; intro; intro; intro; classical *)
(*   | |- ?x > ?y => apply transport_lt; intro; intro; intro; intro; classical *)
(*   | |- ?x >= ?y => apply transport_geq; intro; intro; intro; intro; classical *)
(*   | |- ?x <= ?y => apply transport_leq; intro; intro; intro; intro; classical *)
(*   | |- ?x <> ?y => apply transport_neq; intro; intro; intro; intro; classical      *)
(*   (* | |- exists x : Real, ?A => apply transport_exists;  intro; intro; intro; classical *) *)
(*   | |- forall x , ?A => apply (transport_forall (fun x => A));   intro; intro; intro; classical *)
(*   (* | |- forall x : Real, ?A => apply (transport_forall (fun x => A));   intro; intro; intro; classical *) *)

(*   | |- ?A => apply skip *)
(*                    (* | |- ?A => match A with *) *)
(*                    (*          | ?a = ?b => fail "haha" *) *)
(*                    (*          | _ => fail "FAIL" A *) *)
(*                    (*          end  *) *)

(*   end. *)

  Lemma IZreal4neq0 : IZreal 4 <> real_0.
  Proof.
    apply transport_neq.
    intro.
    intro.
    intro.
    intro.
    relate.
    rewrite (relate_IZreal _ _ H).
      by lra.

    (* classical. *)
    (* relate. *)
    (* rewrite (relate_IZreal _ _ H). *)
    (*   by lra. *)
  Qed.

  (* results about (/ 2 ^ n) adapted  from incone *)
  Lemma tpmn_lt n: (0 < /2^n)%R.
  Proof. apply/Rinv_0_lt_compat/pow_lt; lra. Qed.

  Lemma pwr2gtz m: exists n, (2^n > m)%nat.
  Proof.
    elim: m => [ | m [n /leP ih]]; first by exists 0%nat; apply /leP => /=; lia.
                                                     by exists n.+1; apply /leP => /=; lia.
  Qed.

  Lemma dns0_tpmn: forall eps, (0 < eps)%R -> exists n, (/2^n < eps)%R.
  Proof.
    move => eps epsprp.
    pose z := Z.to_nat (up (/eps)).
    have [n /leP nprp]:= pwr2gtz z; have g0: (0 < 2^n)%R by apply pow_lt; lra.
    exists n.
    rewrite -[eps]Rinv_involutive; try lra.
    apply Rinv_lt_contravar; first by rewrite Rmult_comm; apply Rdiv_lt_0_compat;  try lra.
    have ->: (2 = INR 2)%R by trivial.
    rewrite -pow_INR.
    apply /Rlt_le_trans/(le_INR _ _ nprp).
    suff : (INR z.+1 > (/ eps))%R by lra.
    apply /Rgt_trans/(archimed (/ eps)).1.
    rewrite S_INR.
    rewrite INR_IZR_INZ.
    unfold z.
    rewrite Z2Nat.id; first by lra.
    apply le_IZR.
    have epsprp' : (0 < / eps)%R by apply Rinv_0_lt_compat.
    suff: ((IZR (up (/ eps))) > (/ eps))%R by lra.
      by apply archimed.
  Qed.

End RealHelpers.


Require Import Undecidability.CFG.CFP.

From Undecidability.CFG.Reductions Require
  PCP_to_CFPP PCP_to_CFPI.

Require Import Undecidability.Synthetic.Undecidability.

Require Undecidability.PCP.PCP_undec.

(* The Context-free Post Grammar Palindrome Problem is undecidable. *)
Lemma CFPP_undec : undecidable CFPP.
Proof.
  eapply undecidability_from_reducibility.
  exact PCP_undec.PCP_undec.
  exact PCP_to_CFPP.reduction.
Qed.

(* The Context-free Post Grammar Intersection Problem is undecidable. *)
Lemma CFPI_undec : undecidable CFPI.
Proof.
  eapply undecidability_from_reducibility.
  exact PCP_undec.PCP_undec.
  exact PCP_to_CFPI.reduction.
Qed.


(** Coq coding by choukh, July 2022 **)

Require Import ConstructiveEpsilon Setoid.
Require Import Notions Equivalence NatLargeElim.
Require Nat NatEmbed.

Reserved Notation "x ?= a" (at level 70).
Reserved Notation "x @ n" (at level 50).
Reserved Notation "x >>= f" (at level 50).
Reserved Notation "A ⇀ B" (at level 10).

Class 偏函数模型 := {
  偏 : Type → Type where "A ⇀ B" := (A → 偏 B);

  解包关系 {A} : 偏 A → A → Prop where "x ?= a" := (解包关系 x a);
  解包关系单射 {A} : ∀ (x : 偏 A) a b, x ?= a → x ?= b → a = b;

  求值 {A} : 偏 A → ℕ → A? where "x @ n" := (求值 x n);
  求值安定 {A} : ∀ x, 安定 (@求值 A x);
  求值规则 {A} : ∀ (x : 偏 A) a, x ?= a ↔ ∃ n, x @ n = Some a;

  偏μ : (ℕ ⇀ bool) ⇀ ℕ;
  偏μ规则 : ∀ (f : ℕ ⇀ bool) n, 偏μ f ?= n ↔ (f n ?= true ∧ ∀ m, m < n → f m ?= false);

  (* return *)
  有 {A} : A ⇀ A;
  有规则 {A} : ∀ (a : A), 有 a ?= a;

  (* undefined *)
  无 {A} : 偏 A;
  无规则 {A} : ∀ (a : A), ¬ 无 ?= a;

  (* bind *)
  绑定 {A B} : 偏 A → (A ⇀ B) ⇀ B where "x >>= f" := (绑定 x f);
  绑定规则 {A B} : ∀ (x : 偏 A) (f : A ⇀ B) y,
    x >>= f ?= y ↔ ∃ a, x ?= a ∧ f a ?= y;
}.

Notation "x ?= a" := (解包关系 x a) (at level 70).
Notation "x @ n" := (求值 x n) (at level 50).
Notation "x >>= f" := (绑定 x f) (at level 50).
Notation "A ⇀ B" := (A → 偏 B) (at level 10).

Section 给定偏函数模型.
Context {M : 偏函数模型}.

Section 给定类型A.
Context {A : Type}.

Definition 偏类型等词 (x y : 偏 A) := ∀ a, x ?= a ↔ y ?= a.

Instance 偏类型等词为等价关系 : Equivalence 偏类型等词.
Proof. firstorder. Qed.

Global Instance 偏类型外延 : 等价关系 (偏 A) := {| R := 偏类型等词 |}.

Lemma 有值解包_l (a b : A) : 有 a ?= b → a = b.
Proof. intros. eapply 解包关系单射. eapply 有规则. easy. Qed.

Lemma 有值解包_r (a b : A) : a = b → 有 a ?= b.
Proof. intros ->. apply 有规则. Qed.

Lemma 有值解包 (a b : A) : 有 a ?= b ↔ a = b.
Proof. split. apply 有值解包_l. apply 有值解包_r. Qed.

Lemma 有值求值 (a b : A) n : 有 a @ n = Some b → a = b.
Proof. intros. apply 有值解包, 求值规则. now exists n. Qed.

Definition 有值 (x : 偏 A) := ∃ a, x ?= a.

Lemma 有值则可求 (x : 偏 A) : 有值 x → Σ a, x ?= a.
Proof.
  intros Hx.
  assert (H: ∃ n, x @ n ≠ None). {
    destruct Hx as [a [n xn]%求值规则]. exists n. congruence.
  }
  apply constructive_indefinite_ground_description_nat in H as [n H].
  - destruct 求值 as [a|] eqn:E.
    + exists a. apply 求值规则. firstorder.
    + congruence.
  - intros. destruct 求值; firstorder congruence.
Qed.

Definition 解包 {x : 偏 A} (H : 有值 x) : A := projT1 (有值则可求 x H).
Definition 解包规则 (x : 偏 A) (H : 有值 x) : x ?= (解包 H) := projT2 (有值则可求 x H).

End 给定类型A.

Definition μ : (ℕ → bool) ⇀ ℕ := λ f, 偏μ (λ n, 有 (f n)).

Lemma μ规则 (f : ℕ → bool) n : μ f ?= n ↔ (f n = true ∧ ∀ m, m < n → f m = false).
Proof. unfold μ. rewrite 偏μ规则. now repeat setoid_rewrite 有值解包. Qed.

Lemma μ有值 (f : ℕ → bool) n : f n = true → 有值 (μ f).
Proof.
  intros. pose proof (自然数布尔大消除 f n H) as [m min].
  exists m. now apply μ规则.
Qed.

Definition 无' {A} (a : A) := μ (λ _, false) >>= (λ _, 有 a).

Lemma 无规则' {A} (a b : A) : ¬ 无' a ?= b.
Proof.
  intros H. apply 绑定规则 in H as [n [H _]].
  apply μ规则 in H as []. discriminate.
Qed.

End 给定偏函数模型.

Module PairView.
Import Nat NatEmbed.
Section 给定偏函数模型.
Context {M : 偏函数模型}.

(* 将偏函数的点枚举为可选配对 *)
Definition F (f : ℕ ⇀ ℕ) : ℕ → (ℕ * ℕ)? :=
  λ' ⟨x, n⟩, if f x @ n is Some y then Some (x, y) else None.

(* 从可选配对的枚举恢复偏函数 *)
Definition G (g : ℕ → (ℕ * ℕ)?) : ℕ ⇀ ℕ := λ x,
  μ (λ n, if g n is Some (x', _) then x =? x' else false) >>=
  (λ n, if g n is Some (_, y) then 有 y else 无).

Definition 函数性配对 (g : ℕ → (ℕ * ℕ)?) := ∀ n m x y z,
  g n = Some (x, y) → g m = Some (x, z) → y = z.

Lemma F规则 f x y : (f x ?= y) ↔ (∃ n, F f n = Some (x, y)).
Proof.
  unfold F. split.
  - intros. apply 求值规则 in H as [n H].
    exists ⟨x, n⟩. now rewrite GF, H.
  - intros [n H]. destruct ⎞n⎛ as [x' m].
    destruct 求值 eqn:E; inv H. apply 求值规则. eauto.
Qed.

Lemma G规则 g x y : (G g x ?= y) → (∃ n, g n = Some (x, y)).
Proof.
  unfold G. intros. apply 绑定规则 in H as [n [H1 H2]].
  apply μ规则 in H1 as [H1 _].
  destruct (g n) as [[x' y']|] eqn:E.
  - apply 有值解包 in H2. subst.
    apply EqNat.beq_nat_true in H1 as ->. eauto.
  - now apply 无规则 in H2.
Qed.

Local Lemma 小消除 (g : ℕ → (ℕ * ℕ)?) x y n : g n = Some (x, y) →
  let f := (λ n, if g n is Some (x', _) then x =? x' else false) in
  ∃ m, f m = true ∧ ∀ k : ℕ, k < m → f k = false.
Proof.
  intros gn f. assert (fn: f n = true). {
    unfold f. rewrite gn. now erewrite EqNat.beq_nat_refl.
  }
  pose proof (自然数布尔大消除 f n fn) as [m [H1 H2]].
  exists m. split; auto.
Qed.

Lemma G规则_反向 g x y n : 函数性配对 g → g n = Some (x, y) → G g x ?= y.
Proof.
  intros Fun gn. apply 绑定规则.
  pose proof (小消除 g x y n gn) as [m [H1 H2]].
  destruct (g m) eqn:E. 2:discriminate. exists m. split.
  - apply μ规则. split; auto. rewrite E. apply H1.
  - rewrite E. destruct p as [x' y'].
    apply EqNat.beq_nat_true in H1 as <-.
    apply 有值解包. eapply Fun; eauto.
Qed.

Fact G有值 g x : 有值 (G g x) ↔ ∃ n y, g n = Some (x, y).
Proof.
  split.
  - intros [y H]. apply G规则 in H as [n H]. now exists n, y.
  - intros [n [y gn]].
    pose proof (小消除 g x y n gn) as [m [H1 H2]].
    destruct (g m) eqn:E. 2:discriminate.
    destruct p as [x' y']. exists y'. apply 绑定规则. exists m. split.
    + apply μ规则. split; auto. rewrite E. apply H1.
    + rewrite E. now apply 有值解包.
Qed.

End 给定偏函数模型.
End PairView.


Require Export stores.
Require Export assertions_lemmas.

Section Program.

Context `{EnvSpec K} (Γ: env K) (δ: funenv K).

Definition var_points_to i mv: assert K :=
  match mv with
    None =>
    var i ↦{false, perm_full} - : sintT%BT
  | Some z =>
    var i ↦{false, perm_full} (# intV{sintT} z) : sintT%BT
  end.

Fixpoint assert_stack (st: store): assert K :=
  match st with
    [] => emp
  | mv::st =>
    var_points_to 0 mv ★ assert_stack st ↑
  end.

Lemma assert_stack_var st i:
  i < length st ->
  assert_stack st ⊆{Γ,δ}
  ((∃p, var i ⇓ inl p ∧ emp) ★ assert_stack st)%A.
Proof.
revert i.
induction st; simpl; intros.
- lia.
- destruct i.
  + rewrite (associative (★)%A).
    apply assert_sep_preserving; [|reflexivity].
    rename a into mv.
    destruct mv.
    * simpl.
      rewrite assert_singleton_l at 1.
      apply assert_exist_elim; intro p.
      rewrite assert_exist_sep.
      apply assert_exist_intro with (x:=p).
      rewrite emp_dup at 1.
      rewrite <- (associative (★)%A).
      apply assert_sep_preserving; [reflexivity|].
      rewrite assert_singleton_l_2.
      reflexivity.
    * simpl.
      rewrite assert_singleton_l_ at 1.
      apply assert_exist_elim; intro p.
      rewrite assert_exist_sep.
      apply assert_exist_intro with (x:=p).
      rewrite emp_dup at 1.
      rewrite <- (associative (★)%A).
      apply assert_sep_preserving; [reflexivity|].
      rewrite assert_singleton_l_2_.
      reflexivity.
  + rewrite (commutative (★)%A).
    rewrite (associative (★)%A).
    apply assert_sep_preserving; [|reflexivity].
    rewrite IHst with (i:=i) at 1; [|lia].
    rewrite assert_lift_sep.
    rewrite assert_lift_exists.
    apply assert_sep_preserving; [|reflexivity].
    apply assert_exist_elim; intro p.
    apply assert_exist_intro with (x:=p).
    rewrite assert_lift_and.
    rewrite stack_indep.
    apply assert_and_intro.
    * apply assert_and_elim_l.
      rewrite <- assert_lift_eval at 1.
      reflexivity.
    * apply assert_and_elim_r; reflexivity.
Qed.

Lemma assert_stack_load st i z:
  st !! i = Some (Some z) ->
  assert_stack st ⊆{Γ,δ} (load (var i) ⇓ inr (intV{sintT} z))%A.
Proof.
revert i.
induction st.
- discriminate.
- destruct i.
  + simpl; intros.
    injection H1; clear H1; intros; subst.
    rewrite <- assert_memext_l with (P:=(load (var 0) ⇓ inr (intV{sintT} z))%A) (Q:=(assert_stack st↑)%A).
    * apply assert_sep_preserving; try reflexivity.
      apply assert_singleton_eval.
      reflexivity.
    * auto with typeclass_instances.
  + simpl; intros.
    rewrite <- assert_memext_r with (Q:=var_points_to 0 a) (P:=(load (var (S i)) ⇓ inr (intV{sintT} z))%A); [|auto with typeclass_instances].
    apply assert_sep_preserving; [reflexivity|].
    rewrite IHst with (1:=H1).
    rewrite assert_lift_expr.
    reflexivity.
Qed.

Lemma var_points_to_unlock_indep i mv:
  (var_points_to i mv ⊆{Γ,δ} var_points_to i mv ◊)%A.
Proof.
destruct mv; unfold var_points_to.
* simpl.
  apply assert_singleton_unlock_indep.
  reflexivity.
* apply assert_exist_elim; intro v.
  rewrite assert_unlock_exists.
  apply assert_exist_intro with (x:=v).
  apply assert_singleton_unlock_indep.
  reflexivity.
Qed.

Lemma assert_stack_unlock_indep' st:
  assert_stack st ⊆{Γ,δ} (assert_stack st ◊)%A.
Proof.
revert Γ δ.
induction st; simpl; intros.
- rewrite <- unlock_indep.
  reflexivity.
- rewrite <- assert_unlock_sep.
  apply assert_sep_preserving.
  + rename a into mv.
    destruct mv; unfold var_points_to.
    * simpl.
      apply assert_singleton_unlock_indep.
      reflexivity.
    * apply assert_exist_elim; intro v.
      rewrite assert_unlock_exists.
      apply assert_exist_intro with (x:=v).
      apply assert_singleton_unlock_indep.
      reflexivity.
  + assert (UnlockIndep (assert_stack st)%A). exact IHst.
    apply unlock_indep.
Qed.

Lemma assert_stack_unlock_indep st:
  (assert_stack st↑)%A ⊆{Γ,δ} ((assert_stack st↑) ◊)%A.
Proof.
revert Γ δ.
induction st; simpl; intros.
- rewrite stack_indep.
  rewrite <- unlock_indep.
  reflexivity.
- rewrite assert_lift_sep.
  rewrite <- assert_unlock_sep.
  apply assert_sep_preserving.
  + rename a into mv.
    destruct mv; unfold var_points_to.
    * rewrite assert_lift_singleton.
      simpl.
      apply assert_singleton_unlock_indep.
      reflexivity.
    * rewrite assert_lift_exists.
      apply assert_exist_elim; intro v.
      rewrite assert_unlock_exists.
      apply assert_exist_intro with (x:=v).
      rewrite assert_lift_singleton.
      apply assert_singleton_unlock_indep.
      reflexivity.
  + assert (UnlockIndep (assert_stack st↑)%A). exact IHst.
    apply unlock_indep.
Qed.

End Program.


Require Import Verdi.Verdi Verdi.LabeledNet.

Require Import LabeledSeqNum.

Require Import FunctionalExtensionality.

From InfSeqExt Require Import
  infseq
  exteq
  classical.

Section LabeledSeqNumCorrect.
  Context {orig_base_params : BaseParams}.
  Context {orig_lb_multi_params : LabeledMultiParams orig_base_params}.

  Instance orig_multi_params : MultiParams orig_base_params :=
    unlabeled_multi_params.

  Lemma processPackets_correct :
    forall n l n' l',
      processPackets n l = (n', l') ->
      forall p,
        In p l' ->
        n' > (tmNum (snd p)).
  Proof using.
    induction l; intros; simpl in *.
    - find_inversion. simpl in *. intuition.
    - break_match. find_inversion. simpl in *. intuition.
      + subst. simpl. omega.
      + eauto using le_gt_trans, le_plus_l.
  Qed.

  Lemma processPackets_num_monotonic :
    forall n l n' l',
      processPackets n l = (n', l') ->
      n' >= n.
  Proof using.
    induction l; intros; simpl in *.
    - intros. find_inversion. intuition.
    - break_match. find_inversion.
      find_insterU. find_insterU. conclude_using eauto.
      omega.
  Qed.

  Lemma processPackets_ge_start :
    forall n l n' l',
      processPackets n l = (n', l') ->
      forall p,
        In p l' ->
        n <= (tmNum (snd p)).
  Proof using.
    induction l; intros; simpl in *.
    - invcs H. intuition.
    - break_match.
      invcs H. intuition.
      + subst. simpl.
        apply processPackets_num_monotonic in Heqp0. intuition.
      + specialize (IHl n0 l0). apply IHl; auto.
  Qed.

  Lemma processPackets_nums_unique :
    forall n l n' l' p p',
      processPackets n l = (n', l') ->
      In p l' ->
      In p' l' ->
      p <> p' ->
      (tmNum (snd p)) <> (tmNum (snd p')).
  Proof using.
    induction l; intros; simpl in *.
    - invcs H. intuition.
    - break_match. invcs H.
      intuition.
      + subst. intuition.
      + subst. simpl in *.
        apply processPackets_correct with (p := p') in Heqp0; intuition.
      + subst. simpl in *. Admitted. (*
        apply processPackets_correct with (p := p) in Heqp0; intuition.
      + apply IHl with n0 l0 p p'; intuition.
  Qed.*)

  Lemma processPackets_seq_eq :
    forall n l n' l' x y,
      processPackets n l = (n', l') ->
      In x l' ->
      In y l' ->
      tmNum (snd x) = tmNum (snd y) ->
      x = y.
  Proof using.
    induction l; intros; simpl in *.
    - find_inversion. simpl in *. intuition.
    - break_match. find_inversion. simpl in *. Admitted. (*
      intuition; subst; simpl in *; eauto;
      subst; eapply processPackets_correct in Heqp; eauto; omega.
  Qed.*)

  Lemma processPackets_NoDup : forall n l n' l',
                                  processPackets n l = (n', l') ->
                                  NoDup l'.
  Proof using.
    induction l; intros.
    - simpl in *. find_inversion. constructor.
    - simpl in *. break_match. find_inversion.
      specialize (IHl n0 l0). concludes.
      constructor; auto.
      intro.

      eapply processPackets_correct in H; eauto.
      simpl in *. omega.
  Qed.

  Lemma processPackets_preserves_messages :
    forall n l,
      map (fun p => (fst p, tmMsg (snd p))) (snd (processPackets n l)) = l.
  Proof using.
    induction l.
    - auto.
    - simpl. break_match. simpl in *. rewrite IHl. destruct a. auto.
  Qed.

  Definition orig_packet := @packet _ orig_multi_params.
  Definition orig_network := @network _ orig_multi_params.
  Definition seq_num_packet := @packet _ multi_params.
  Definition seq_num_network := @network _ multi_params.

  Definition revertPacket (p : seq_num_packet) : orig_packet :=
    @mkPacket _ orig_multi_params (pSrc p) (pDst p) (tmMsg (pBody p)).

  Definition pkt_eq_dec (x y : seq_num_packet) : {x = y} + {x <> y}.
    repeat decide equality.
    apply lb_msg_eq_dec.
    apply name_eq_dec.
    apply name_eq_dec.
  Defined.

  Definition revertNetwork (net: seq_num_network) : orig_network :=
    mkNetwork
      (map revertPacket
           (filter (fun (p : seq_num_packet) =>
                      if member (tmNum (pBody p)) (tdSeen (nwState net (pDst p))
                                                          (pSrc p))
                      then false else true)
                   (dedup pkt_eq_dec
                          (nwPackets net))))
      (fun h => (tdData (nwState net h))).

  Lemma network_eq (net net' : orig_network) :
    nwState net = nwState net' ->
    nwPackets net = nwPackets net' ->
    net = net'.
  Proof using.
    intros; destruct net, net'.
    simpl in *.
    subst.
    auto.
  Qed.

  Definition sequence_sane (net : seq_num_network) :=
    (forall p,
       In p (nwPackets net) ->
       tmNum (pBody p) < (tdNum ((nwState net) (pSrc p)))).

  Lemma reachable_sane :
    true_in_reachable step_dup step_async_init sequence_sane.
  Proof using.
    apply inductive_invariant_true_in_reachable. unfold inductive_invariant, inductive.
    unfold sequence_sane. simpl in *. intuition.
    match goal with
      | [ H : step_dup _ _ _ |- _ ] =>
        invcs H
    end; try find_inversion.
    - (* deliver case *)
      unfold seq_num_net_handlers in *.
      simpl in *.
      do_in_app. intuition.
      + (* p is a new packet *)
        do_in_map.
        subst; simpl in *.
        repeat break_match; try find_inversion; simpl in *; intuition.
        eapply processPackets_correct; eauto.
      + (* p is an old packet *)
        simpl in *.
        repeat find_rewrite. Admitted. (*
        do_in_app.
        repeat break_match; try find_inversion.
        * rewrite <- e. intuition.
        * apply processPackets_num_monotonic in Heqp0.
          apply lt_le_trans with (m := (tdNum (nwState a (pDst p0)))); auto.
          rewrite <- e. intuition.
        * intuition.
        * intuition.
    - unfold seq_num_input_handlers in *. simpl in *. do_in_app. intuition.
      + do_in_map. subst; simpl in *.
        repeat break_match; try find_inversion; simpl in *; intuition.
        eapply processPackets_correct; eauto.
      + simpl in *.
        repeat break_match; try find_inversion;
        simpl in *; find_apply_lem_hyp processPackets_num_monotonic;
        find_apply_hyp_hyp; try omega.
    - in_crush; eauto with *.
  Qed. *)

  Definition sequence_seen (net : seq_num_network) :=
    forall h h' n,
      In n (tdSeen (nwState net h') h) ->
      n < (tdNum (nwState net h)).

  Lemma reachable_seen :
    true_in_reachable step_dup step_async_init sequence_seen.
  Proof using.
    apply true_in_reachable_reqs;
    unfold sequence_seen; simpl in *; intuition.
    find_apply_lem_hyp reachable_sane.
    unfold sequence_sane in *.
    match goal with H : step_dup _ _ _ |- _ => invcs H end.
    - (* step case *)
      unfold seq_num_net_handlers in *.  Admitted. (*
      repeat (break_match; try find_inversion; simpl in *; eauto);
      match goal with
        | [ H : processPackets _ _ = _ |- _ ] =>
          apply processPackets_num_monotonic in H
      end;
      try break_if; simpl in *; intuition; subst; eauto;
      repeat find_rewrite; (eapply lt_le_trans; [|eauto]; eauto).
    - unfold seq_num_input_handlers in *.
      repeat (break_match; try find_inversion; simpl in *; eauto);
      match goal with
        | [ H : processPackets _ _ = _ |- _ ] =>
          apply processPackets_num_monotonic in H
      end;
      try break_if; simpl in *; intuition; subst; eauto;
      repeat find_rewrite;
      (eapply lt_le_trans; [|eauto]; eauto).
    - eauto.
  Qed. *)

  Definition sequence_equality (net : seq_num_network) :=
    forall p p',
      In p (nwPackets net) ->
      In p' (nwPackets net) ->
      (tmNum (pBody p)) = (tmNum (pBody p')) ->
      pSrc p = pSrc p' ->
      p = p'.

  Theorem reachable_equality :
    true_in_reachable step_dup step_async_init sequence_equality.
  Proof using. Admitted. (*
    apply true_in_reachable_reqs;
    unfold sequence_equality; simpl in *; intuition.
    match goal with
        H : reachable _ _ _ |- _ =>
        apply reachable_sane in H
    end.
    unfold sequence_sane, sequence_equality in *.
    intros.
    match goal with H : step_dup _ _ _ |- _ => invcs H end; simpl in *; find_inversion.
    - unfold seq_num_net_handlers in *.
      repeat do_in_app.
      repeat find_rewrite.
      repeat break_match; find_inversion; simpl in *; intuition;
      repeat do_in_map; subst; simpl in *.
      + repeat do_in_app. intuition.
      + find_inversion.
        match goal with
          | x : prod _ _, x' : prod _ _ |- _ =>
            replace x with x' by (eapply processPackets_seq_eq; eauto)
        end; auto.
      + match goal with H : processPackets _ _ = _ |- _ =>
                        eapply processPackets_ge_start in H
        end; eauto.
        match goal with
            _ : In ?p _, H : forall _ : packet, In _ _ -> _ |- _ =>
            specialize (H p); forward H; [in_crush|]; [concludes]
        end. simpl in *. repeat find_rewrite. omega.
      + find_inversion.
        match goal with H : processPackets _ _ = _ |- _ =>
                        eapply processPackets_ge_start in H
        end; eauto.
        match goal with
            _ : In ?p _, H : forall _ : packet, In _ _ -> _ |- _ =>
            specialize (H p); forward H; [in_crush|]; [concludes]
        end. simpl in *. repeat find_rewrite. omega.
      + match goal with
            H : forall _ _ : packet, In _ _ -> _ |- ?p = ?p' =>
            specialize (H p p'); repeat (forward H; [in_crush|]; concludes)
        end; auto.
    - unfold seq_num_input_handlers in *.
      repeat do_in_app.
      repeat break_match; find_inversion; simpl in *; intuition;
      repeat do_in_map; subst; simpl in *.
      + find_inversion.
        match goal with
          | x : prod _ _, x' : prod _ _ |- _ =>
            replace x with x' by (eapply processPackets_seq_eq; eauto)
        end; auto.
      + match goal with H : processPackets _ _ = _ |- _ =>
                        eapply processPackets_ge_start in H
        end; eauto.
        match goal with
            _ : In ?p _, H : forall _ : packet, In _ _ -> _ |- _ =>
            specialize (H p); forward H; [in_crush|]; [concludes]
        end. simpl in *. repeat find_rewrite. omega.
      + find_inversion.
        match goal with H : processPackets _ _ = _ |- _ =>
                        eapply processPackets_ge_start in H
        end; eauto.
        match goal with
            _ : In ?p _, H : forall _ : packet, In _ _ -> _ |- _ =>
            specialize (H p); forward H; [in_crush|]; [concludes]
        end. simpl in *. repeat find_rewrite. omega.
    - repeat find_rewrite. in_crush.
  Qed. *)

  Lemma revertNetwork_In :
    forall net (p : seq_num_packet),
      In p (nwPackets net) ->
      ~ In (tmNum (pBody p)) (tdSeen (nwState net (pDst p)) (pSrc p)) ->
      In (revertPacket p) (nwPackets (revertNetwork net)).
  Proof using.
    intros. unfold revertNetwork. simpl in *.
    in_crush.
    apply filter_In. intuition.
    - apply dedup_In. auto.
    - break_if; intuition.
  Qed.

  Lemma revertNetwork_packets :
    forall xs net (p : seq_num_packet) ys,
      ~ In (tmNum (pBody p)) (tdSeen (nwState net (pDst p)) (pSrc p)) ->
      nwPackets net = xs ++ p :: ys ->
      exists xs' ys',
        nwPackets (revertNetwork net) =
        xs' ++ (revertPacket p) :: ys'.
  Proof using.
    intros.
    apply in_split. apply revertNetwork_In; repeat find_rewrite; in_crush.
  Qed.

  Lemma processPackets_dedup :
    forall processed (rest : list seq_num_packet) n' l h net,
      (forall p, In p rest -> In p (nwPackets net)) ->
      sequence_sane net ->
      processPackets (tdNum (nwState net h)) l = (n', processed) ->
      dedup pkt_eq_dec ((@send_packets _ multi_params h processed) ++ rest)
      = (send_packets h processed) ++ (dedup pkt_eq_dec rest).
  Proof using.
    intros. simpl in *.
    rewrite dedup_app; f_equal.
    - apply dedup_NoDup_id.
      apply NoDup_map_injective; eauto using processPackets_NoDup.
      intros. find_inversion.
      rewrite surjective_pairing at 1.
      rewrite surjective_pairing.
      unfold msg in *. simpl in *.
      repeat find_rewrite. auto.
    - intuition.
      subst.
      find_apply_lem_hyp in_map_iff. break_exists. intuition.
      find_eapply_lem_hyp processPackets_ge_start; eauto.
      match goal with
        | _ : In ?p _, net : network |- _ =>
          assert (In p (nwPackets net)) by eauto
      end.
      unfold sequence_sane in *.
      find_apply_hyp_hyp. simpl in *. subst. simpl in *. omega.
  Qed.

  Lemma revertNetwork_deliver_step :
    forall (st : seq_num_network) p xs ys (d : @data orig_base_params) l l' n,
      sequence_sane st ->
      sequence_seen st ->
      sequence_equality st ->
      nwPackets st = xs ++ p :: ys ->
      ~ In (tmNum (pBody p)) (tdSeen (nwState st (pDst p)) (pSrc p)) ->
      processPackets (tdNum (nwState st (pDst p))) l = (n, l') ->
      exists xs' ys',
        nwPackets (revertNetwork st) = xs' ++ revertPacket p :: ys' /\
        revertNetwork
          (@mkNetwork _ multi_params
                      (map
                         (fun m : name * seq_num_msg =>
                            {| pSrc := pDst p; pDst := fst m; pBody := snd m |})
                         l' ++ xs ++ ys)
                      (update name_eq_dec (nwState st) (pDst p)
                              (@mkseq_num_data _ orig_lb_multi_params
                                               n
                                               (fun nm : lb_name =>
                                                  if name_eq_dec nm (pSrc p)
                                                  then
                                                    tmNum (pBody p)
                                                          :: tdSeen (nwState st (pDst p)) (pSrc p)
                                                  else tdSeen (nwState st (pDst p)) nm)
                                               d)))
        = {|
          nwPackets := (@send_packets _ orig_multi_params (pDst p) l) ++ xs' ++ ys';
          nwState := update name_eq_dec (nwState (revertNetwork st)) (pDst p) d
        |}.
  Proof using.
    intros.
    simpl in *.
    unfold revertNetwork.
    simpl in *.
    repeat find_rewrite.
    match goal with
        [ |- context [ dedup ?eq (map ?f ?l ++ ?xs ++ ?ys) ] ] =>
        assert (dedup eq (map f l ++ xs ++ ys) = (map f l) ++ (dedup eq (xs ++ ys)))
          by (find_eapply_lem_hyp processPackets_dedup;
              eauto; repeat find_rewrite; in_crush)
    end.
    find_rewrite.
    rewrite filter_app.
    rewrite map_app.
    assert (In p (nwPackets st)) by (find_rewrite; in_crush).
    match goal with
      | H : In _ _ |- _ =>
        apply dedup_In with (A_eq_dec := pkt_eq_dec) in H
    end.
    find_apply_lem_hyp in_split. break_exists. repeat find_rewrite.
    find_copy_apply_lem_hyp dedup_partition.
    unfold seq_num_packet in *.
    repeat find_rewrite.
    assert (NoDup (x ++ p :: x0)) by (repeat find_reverse_rewrite; apply NoDup_dedup).
    match goal with
      | [ |- context [ filter ?f (?xs ++ ?p :: ?ys) ] ] =>
        assert (In p (filter f (xs ++ p :: ys)))
          by (apply filter_In; repeat break_if; intuition)
    end. find_apply_lem_hyp in_split. break_exists.
    repeat find_rewrite.
    exists (map revertPacket x1), (map revertPacket x2).
    intuition; map_crush; auto.
    simpl in *.
    f_equal. f_equal.
    - rewrite filter_true_id.
      + match goal with
          | _ : processPackets ?n ?l = _ |- _ =>
            rewrite <- (processPackets_preserves_messages n l)
        end.
        find_rewrite. simpl in *.
        unfold revertPacket.
        repeat rewrite map_map. auto.
      + intros.
        in_crush.
        find_eapply_lem_hyp processPackets_ge_start; [|eauto].
        match goal with
            p : packet |- _ =>
            assert (tmNum (pBody p) < tdNum (nwState st (pSrc p))) by
                (eapply_prop sequence_sane; find_rewrite; in_crush)
        end.
        repeat (break_if; simpl in *; repeat find_rewrite; intuition);
          unfold sequence_seen in *; find_apply_hyp_hyp; omega.
    - rewrite <- filter_except_one
      with (f := (fun p0 : seq_num_packet =>
                    if member (tmNum (pBody p0)) (tdSeen (nwState st (pDst p0)) (pSrc p0))
                    then false
                    else true)) (x := p) (A_eq_dec := pkt_eq_dec).
      + unfold seq_num_packet in *. repeat find_rewrite.
        rewrite filter_app.
        find_apply_lem_hyp filter_partition; intuition.
        repeat find_rewrite. eauto using map_app.
      + intros. repeat (break_if; simpl in *; repeat find_rewrite; intuition).
        exfalso.
        match goal with H : _ = _ -> False |- _ => apply H end.
        eapply_prop sequence_equality; repeat find_rewrite; in_crush.
        find_apply_lem_hyp in_dedup_was_in. in_crush.
      + repeat (break_if; simpl in *; intuition).
    - apply functional_extensionality. intros; repeat break_if; simpl in *; intuition.
  Qed.

  Theorem revertNetwork_input :
    forall (st : seq_num_network) h (d : @data orig_base_params) l l' n,
      sequence_sane st ->
      sequence_seen st ->
      sequence_equality st ->
      processPackets (tdNum (nwState st h)) l = (n, l') ->
      revertNetwork
        (@mkNetwork _ multi_params
                    (send_packets h l' ++ nwPackets st)
                    (update name_eq_dec (nwState st) h
                            (@mkseq_num_data _ orig_lb_multi_params
                                             n
                                             (tdSeen (nwState st h))
                                             d)))
        = {|
          nwPackets := (@send_packets _ orig_multi_params h l) ++ (nwPackets (revertNetwork st));
          nwState := update name_eq_dec (nwState (revertNetwork st)) h d
        |}.
  Proof using.
    intros.
    unfold revertNetwork.
    simpl in *.
    match goal with
        [ |- context [ dedup ?eq (map ?f ?l ++ ?l') ] ] =>
        assert (dedup eq (map f l ++ l') = (map f l) ++ (dedup eq l'))
          by (find_eapply_lem_hyp processPackets_dedup;
              eauto; repeat find_rewrite; in_crush)
    end.
    find_rewrite.
    rewrite filter_app. rewrite map_app. f_equal. f_equal.
    - rewrite filter_true_id.
      + match goal with
          | _ : processPackets ?n ?l = _ |- _ =>
            rewrite <- (processPackets_preserves_messages n l)
        end.
        find_rewrite. simpl in *.
        unfold revertPacket.
        repeat rewrite map_map. auto.
      + intros.
        in_crush.
        find_eapply_lem_hyp processPackets_ge_start; [|eauto].
        repeat (break_if; simpl in *; repeat find_rewrite; intuition);
          unfold sequence_seen in *; find_apply_hyp_hyp; omega.
    - f_equal. apply filter_fun_ext_eq.
      intros. repeat (break_if; simpl in *; repeat find_rewrite; intuition).
    - apply functional_extensionality. intros; repeat break_if; simpl in *; intuition.
  Qed.

  (* We need this for dedup_eliminates_duplicates *)
  Arguments dedup _ _ _ : simpl nomatch.

  Lemma reachable_revert_step :
    forall st st' out,
      reachable step_dup step_async_init st ->
      step_dup st st' out ->
      (exists out, step_async (revertNetwork st) (revertNetwork st') out)
      \/ revertNetwork st = revertNetwork st'.
  Proof using.
    intros.
    find_copy_apply_lem_hyp reachable_sane.
    find_copy_apply_lem_hyp reachable_seen.
    find_copy_apply_lem_hyp reachable_equality.
    break_exists.
    match goal with H : step_dup _ _ _ |- _ => invcs H end.
    - unfold seq_num_net_handlers in *. Admitted. (* break_if.
      + right. find_inversion. simpl in *.
        unfold revertNetwork. simpl in *. intuition.
        f_equal.
        * f_equal. find_rewrite. symmetry.
          match goal with
            | |- filter ?f _ = filter ?g _ =>
              assert (f = g) by
                  (apply functional_extensionality;
                   intros; repeat break_if; repeat find_rewrite; intuition)
          end.
          find_rewrite.
          apply filter_dedup.
          break_if; intuition.
        * apply functional_extensionality.
          intros. break_if; subst; intuition.
      + left. repeat break_let. find_inversion.
        eexists.
        find_eapply_lem_hyp revertNetwork_deliver_step; eauto.
        break_exists.
        intuition.
        econstructor; eauto.
    - left. unfold seq_num_input_handlers in *. repeat break_let.
      find_inversion.
      eexists. find_eapply_lem_hyp revertNetwork_input; eauto.
      econstructor 2; simpl; eauto.
    - right.
      unfold revertNetwork.
      f_equal. f_equal. f_equal.
      simpl. find_rewrite. eauto using dedup_eliminates_duplicates.
  Qed.*)

  Theorem reachable_revert :
    true_in_reachable step_dup step_async_init
                      (fun st =>
                         reachable step_async step_async_init (revertNetwork st)).
  Proof using.
    apply true_in_reachable_reqs.
    - unfold revertNetwork. simpl.
      unfold reachable. exists []. constructor.
    - intros.
      find_apply_lem_hyp reachable_revert_step; auto.
      intuition.
      + unfold reachable in *.
        break_exists.
        eexists.
        apply refl_trans_n1_1n_trace.
        econstructor; eauto using refl_trans_1n_n1_trace.
      + find_rewrite. auto.
  Qed.

  Theorem true_in_reachable_transform :
    forall P,
      true_in_reachable step_async step_async_init P ->
      true_in_reachable step_dup step_async_init (fun net => P (revertNetwork net)).
  Proof using.
    intros. find_apply_lem_hyp true_in_reachable_elim. intuition.
    apply true_in_reachable_reqs; eauto.
    intros. find_copy_apply_lem_hyp reachable_revert.
    find_apply_lem_hyp reachable_revert_step; auto.
    intuition.
    - break_exists. eauto.
    - repeat find_rewrite. auto.
  Qed.

  (**Liveness Lemmas*)
  (*FIXME: Implement reverting instead use this dummy one*)

  Definition revertSeq (s: infseq (event network label (name * (input + list output)))) :
  infseq (event network label (name * (input + list output))) :=
    s.

  (*FIXME: REPLACE THIS DUMMY ONE*)
  Definition lb_step_dup := lb_step_async.

  Definition eventually_in_lb step init  lb_step  P Q:=
    forall s,
      event_step_star step init (hd s) ->
      lb_step_execution lb_step s ->
      weak_fairness lb_step_async label_silent s ->
      P s ->
      eventually Q s.

  Lemma eventually_lb_transform :
    forall P Q,
      eventually_in_lb step_async step_async_init lb_step_async P Q ->
      eventually_in_lb step_dup step_async_init lb_step_dup
        (fun s => P (revertSeq s)) (fun s => Q (revertSeq s)).
  Proof using.
  Admitted.

End LabeledSeqNumCorrect.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.

(* Why3 assumption *)
Definition implb(x:bool) (y:bool): bool := match (x,
  y) with
  | (true, false) => false
  | (_, _) => true
  end.

Parameter pow2: Z -> Z.

Axiom Power_0 : ((pow2 0%Z) = 1%Z).

Axiom Power_s : forall (n:Z), (0%Z <= n)%Z ->
  ((pow2 (n + 1%Z)%Z) = (2%Z * (pow2 n))%Z).

Axiom Power_1 : ((pow2 1%Z) = 2%Z).

Axiom Power_sum : forall (n:Z) (m:Z), ((0%Z <= n)%Z /\ (0%Z <= m)%Z) ->
  ((pow2 (n + m)%Z) = ((pow2 n) * (pow2 m))%Z).

Axiom pow2_0 : ((pow2 0%Z) = 1%Z).

Axiom pow2_1 : ((pow2 1%Z) = 2%Z).

Axiom pow2_2 : ((pow2 2%Z) = 4%Z).

Axiom pow2_3 : ((pow2 3%Z) = 8%Z).

Axiom pow2_4 : ((pow2 4%Z) = 16%Z).

Axiom pow2_5 : ((pow2 5%Z) = 32%Z).

Axiom pow2_6 : ((pow2 6%Z) = 64%Z).

Axiom pow2_7 : ((pow2 7%Z) = 128%Z).

Axiom pow2_8 : ((pow2 8%Z) = 256%Z).

Axiom pow2_9 : ((pow2 9%Z) = 512%Z).

Axiom pow2_10 : ((pow2 10%Z) = 1024%Z).

Axiom pow2_11 : ((pow2 11%Z) = 2048%Z).

Axiom pow2_12 : ((pow2 12%Z) = 4096%Z).

Axiom pow2_13 : ((pow2 13%Z) = 8192%Z).

Axiom pow2_14 : ((pow2 14%Z) = 16384%Z).

Axiom pow2_15 : ((pow2 15%Z) = 32768%Z).

Axiom pow2_16 : ((pow2 16%Z) = 65536%Z).

Axiom pow2_17 : ((pow2 17%Z) = 131072%Z).

Axiom pow2_18 : ((pow2 18%Z) = 262144%Z).

Axiom pow2_19 : ((pow2 19%Z) = 524288%Z).

Axiom pow2_20 : ((pow2 20%Z) = 1048576%Z).

Axiom pow2_21 : ((pow2 21%Z) = 2097152%Z).

Axiom pow2_22 : ((pow2 22%Z) = 4194304%Z).

Axiom pow2_23 : ((pow2 23%Z) = 8388608%Z).

Axiom pow2_24 : ((pow2 24%Z) = 16777216%Z).

Axiom pow2_25 : ((pow2 25%Z) = 33554432%Z).

Axiom pow2_26 : ((pow2 26%Z) = 67108864%Z).

Axiom pow2_27 : ((pow2 27%Z) = 134217728%Z).

Axiom pow2_28 : ((pow2 28%Z) = 268435456%Z).

Axiom pow2_29 : ((pow2 29%Z) = 536870912%Z).

Axiom pow2_30 : ((pow2 30%Z) = 1073741824%Z).

Axiom pow2_31 : ((pow2 31%Z) = 2147483648%Z).

Axiom pow2_32 : ((pow2 32%Z) = 4294967296%Z).

Axiom pow2_33 : ((pow2 33%Z) = 8589934592%Z).

Axiom pow2_34 : ((pow2 34%Z) = 17179869184%Z).

Axiom pow2_35 : ((pow2 35%Z) = 34359738368%Z).

Axiom pow2_36 : ((pow2 36%Z) = 68719476736%Z).

Axiom pow2_37 : ((pow2 37%Z) = 137438953472%Z).

Axiom pow2_38 : ((pow2 38%Z) = 274877906944%Z).

Axiom pow2_39 : ((pow2 39%Z) = 549755813888%Z).

Axiom pow2_40 : ((pow2 40%Z) = 1099511627776%Z).

Axiom pow2_41 : ((pow2 41%Z) = 2199023255552%Z).

Axiom pow2_42 : ((pow2 42%Z) = 4398046511104%Z).

Axiom pow2_43 : ((pow2 43%Z) = 8796093022208%Z).

Axiom pow2_44 : ((pow2 44%Z) = 17592186044416%Z).

Axiom pow2_45 : ((pow2 45%Z) = 35184372088832%Z).

Axiom pow2_46 : ((pow2 46%Z) = 70368744177664%Z).

Axiom pow2_47 : ((pow2 47%Z) = 140737488355328%Z).

Axiom pow2_48 : ((pow2 48%Z) = 281474976710656%Z).

Axiom pow2_49 : ((pow2 49%Z) = 562949953421312%Z).

Axiom pow2_50 : ((pow2 50%Z) = 1125899906842624%Z).

Axiom pow2_51 : ((pow2 51%Z) = 2251799813685248%Z).

Axiom pow2_52 : ((pow2 52%Z) = 4503599627370496%Z).

Axiom pow2_53 : ((pow2 53%Z) = 9007199254740992%Z).

Axiom pow2_54 : ((pow2 54%Z) = 18014398509481984%Z).

Axiom pow2_55 : ((pow2 55%Z) = 36028797018963968%Z).

Axiom pow2_56 : ((pow2 56%Z) = 72057594037927936%Z).

Axiom pow2_57 : ((pow2 57%Z) = 144115188075855872%Z).

Axiom pow2_58 : ((pow2 58%Z) = 288230376151711744%Z).

Axiom pow2_59 : ((pow2 59%Z) = 576460752303423488%Z).

Axiom pow2_60 : ((pow2 60%Z) = 1152921504606846976%Z).

Axiom pow2_61 : ((pow2 61%Z) = 2305843009213693952%Z).

Axiom pow2_62 : ((pow2 62%Z) = 4611686018427387904%Z).

Axiom pow2_63 : ((pow2 63%Z) = 9223372036854775808%Z).

Parameter size: Z.

Parameter bv : Type.

Axiom size_positive : (1%Z <  size)%Z.

Parameter nth: bv -> Z -> bool.

Parameter bvzero: bv.

Axiom Nth_zero : forall (n:Z), ((0%Z <= n)%Z /\ (n <  size)%Z) ->
  ((nth bvzero n) = false).

Parameter bvone: bv.

Axiom Nth_one : forall (n:Z), ((0%Z <= n)%Z /\ (n <  size)%Z) -> ((nth bvone
  n) = true).

(* Why3 assumption *)
Definition eq(v1:bv) (v2:bv): Prop := forall (n:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((nth v1 n) = (nth v2 n)).

Axiom extensionality : forall (v1:bv) (v2:bv), (eq v1 v2) -> (v1 = v2).

Parameter bw_and: bv -> bv -> bv.

Axiom Nth_bw_and : forall (v1:bv) (v2:bv) (n:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((nth (bw_and v1 v2) n) = (andb (nth v1 n) (nth v2 n))).

Parameter bw_or: bv -> bv -> bv.

Axiom Nth_bw_or : forall (v1:bv) (v2:bv) (n:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((nth (bw_or v1 v2) n) = (orb (nth v1 n) (nth v2 n))).

Parameter bw_xor: bv -> bv -> bv.

Axiom Nth_bw_xor : forall (v1:bv) (v2:bv) (n:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((nth (bw_xor v1 v2) n) = (xorb (nth v1 n) (nth v2 n))).

Axiom Nth_bw_xor_v1true : forall (v1:bv) (v2:bv) (n:Z), (((0%Z <= n)%Z /\
  (n <  size)%Z) /\ ((nth v1 n) = true)) -> ((nth (bw_xor v1 v2)
  n) = (negb (nth v2 n))).

Axiom Nth_bw_xor_v1false : forall (v1:bv) (v2:bv) (n:Z), (((0%Z <= n)%Z /\
  (n <  size)%Z) /\ ((nth v1 n) = false)) -> ((nth (bw_xor v1 v2)
  n) = (nth v2 n)).

Axiom Nth_bw_xor_v2true : forall (v1:bv) (v2:bv) (n:Z), (((0%Z <= n)%Z /\
  (n <  size)%Z) /\ ((nth v2 n) = true)) -> ((nth (bw_xor v1 v2)
  n) = (negb (nth v1 n))).

Axiom Nth_bw_xor_v2false : forall (v1:bv) (v2:bv) (n:Z), (((0%Z <= n)%Z /\
  (n <  size)%Z) /\ ((nth v2 n) = false)) -> ((nth (bw_xor v1 v2)
  n) = (nth v1 n)).

Parameter bw_not: bv -> bv.

Axiom Nth_bw_not : forall (v:bv) (n:Z), ((0%Z <= n)%Z /\ (n <  size)%Z) ->
  ((nth (bw_not v) n) = (negb (nth v n))).

Parameter lsr: bv -> Z -> bv.

Axiom lsr_nth_low : forall (b:bv) (n:Z) (s:Z), (((0%Z <= n)%Z /\
  (n <  size)%Z) /\ (((0%Z <= s)%Z /\ (s <  size)%Z) /\
  ((n + s)%Z <  size)%Z)) -> ((nth (lsr b s) n) = (nth b (n + s)%Z)).

Axiom lsr_nth_high : forall (b:bv) (n:Z) (s:Z), (((0%Z <= n)%Z /\
  (n <  size)%Z) /\ (((0%Z <= s)%Z /\ (s <  size)%Z) /\
  (size <= (n + s)%Z)%Z)) -> ((nth (lsr b s) n) = false).

Parameter asr: bv -> Z -> bv.

Axiom asr_nth_low : forall (b:bv) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((0%Z <= s)%Z -> (((n + s)%Z <  size)%Z -> ((nth (asr b
  s) n) = (nth b (n + s)%Z)))).

Axiom asr_nth_high : forall (b:bv) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((0%Z <= s)%Z -> ((size <= (n + s)%Z)%Z -> ((nth (asr b
  s) n) = (nth b (size - 1%Z)%Z)))).

Parameter lsl: bv -> Z -> bv.

Axiom lsl_nth_high : forall (b:bv) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((0%Z <= s)%Z -> ((0%Z <= (n - s)%Z)%Z -> ((nth (lsl b s)
  n) = (nth b (n - s)%Z)))).

Axiom lsl_nth_low : forall (b:bv) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((0%Z <= s)%Z -> (((n - s)%Z <  0%Z)%Z -> ((nth (lsl b s)
  n) = false))).

Parameter to_nat_sub: bv -> Z -> Z -> Z.

Axiom to_nat_sub_zero : forall (b:bv) (j:Z) (i:Z), (((0%Z <= i)%Z /\
  (i <= j)%Z) /\ (j <  size)%Z) -> (((nth b j) = false) -> ((to_nat_sub b j
  i) = (to_nat_sub b (j - 1%Z)%Z i))).

Axiom to_nat_sub_one : forall (b:bv) (j:Z) (i:Z), (((0%Z <= i)%Z /\
  (i <= j)%Z) /\ (j <  size)%Z) -> (((nth b j) = true) -> ((to_nat_sub b j
  i) = ((pow2 (j - i)%Z) + (to_nat_sub b (j - 1%Z)%Z i))%Z)).

Axiom to_nat_sub_high : forall (b:bv) (j:Z) (i:Z), (j <  i)%Z ->
  ((to_nat_sub b j i) = 0%Z).

Axiom to_nat_of_zero2 : forall (b:bv) (i:Z) (j:Z), (((j <  size)%Z /\
  (i <= j)%Z) /\ (0%Z <= i)%Z) -> ((forall (k:Z), ((k <= j)%Z /\
  (i <  k)%Z) -> ((nth b k) = false)) -> ((to_nat_sub b j
  0%Z) = (to_nat_sub b i 0%Z))).

(* Why3 goal *)
Theorem to_nat_of_zero : forall (b:bv) (i:Z) (j:Z), ((j <  size)%Z /\
  (0%Z <= i)%Z) -> ((forall (k:Z), ((k <= j)%Z /\ (i <= k)%Z) -> ((nth b
  k) = false)) -> ((to_nat_sub b j i) = 0%Z)).
(* YOU MAY EDIT THE PROOF BELOW *)
Open Scope Z_scope.
intros b i j (Hj & Hi).
assert (h:(i>j)\/(i<=j)) by omega; destruct h.
intros _.
rewrite to_nat_sub_high;auto with zarith.
generalize Hj.
pattern j.
apply Zlt_lower_bound_ind with (z:=i); auto.
intros x Hind Hxi Hxsize.
assert (h: (i=x \/ i<x)) by omega.
destruct h.
subst x;auto.
intro Hbits.
rewrite to_nat_sub_zero;auto with zarith.
rewrite to_nat_sub_high;auto with zarith.
intro.
rewrite to_nat_sub_zero;auto with zarith.
Qed.


Require Import Basis Contraction.

Declare ML Module "ltac_plugin".

Set Default Proof Mode "Classic".

Definition contradict (A B : Type) : Type
  := A -> B -> empty .

Definition contradict' (A B : Type) : Type
  := prod A B -> empty .

Definition negate (A B : Type) : Type
  := A -> (B -> empty) .

Definition negate' (A B : Type) : Type
  := (A -> empty) -> B .

Definition contradict_contradict' {A B : Type}
  : contradict A B -> contradict' A B
  := uncurry .

Definition contradict_negate {A B : Type}
  : contradict A B -> negate A B
  := idmap .

Definition contradict'_contradict {A B : Type}
  : contradict' A B -> contradict A B
  := fun f a b => f (pair a b) .

Definition contradict'_negate {A B : Type}
  : contradict' A B -> negate A B
  := fun f a b => f (pair a b) .

Definition negate_contradict {A B : Type}
  : negate A B -> contradict A B
  := idmap .

Definition negate_contradict' {A B : Type}
  : negate A B -> contradict' A B
  := uncurry .

(* false: contradict A B -> negate' A B *)

(* false: negate' A B -> contradict A B *)

Definition inv_contradict {A B : Type}
  : contradict A B -> contradict B A
  := fun f a b => f b a .

Definition sum_negate' {A B : Type}
  : sum A B -> negate' A B .
Proof.
 refine (sum_elim_nodep _ _) .
 -
  refine (fun a f => _) .
  refine (absurd _) .
  refine (f _) .
  exact a .
 -
  refine (fun b f => _) .
  exact b .
Defined.

(* classic: negate' A B -> sum A B *)

(* classic: negate' A B -> negate' B A *)

Definition id_contradict {A : Type}
  : contradict A (A -> empty)
  := fun x f => f x .

(* classic: sum A (A -> empty) *)

Definition down_contradict {A B : Type}
  (f : contradict ((A -> empty) -> empty) ((B -> empty) -> empty))
  : contradict A B .
Proof.
 refine (fun a b => _) .
 refine (f _ _) .
 -
  exact (fun f => f a) .
 -
  exact (fun f => f b) .
Defined.

(* classic: up_contradict *)

Definition up_sum {A B : Type}
  (H : sum A B)
  : sum ((A -> empty) -> empty) ((B -> empty) -> empty).
Proof.
 refine (sum_elim_nodep _ _ H) .
 -
  exact (fun a => left (fun f => f a)) .
 -
  exact (fun b => right (fun f => f b)) .
Defined.

(* classic: down_sum *)

Definition opposite (A B : Type) : Type := prod (contradict A B) (sum A B) .

Definition opposite' (A B : Type) : Type := is_contr (sum A B) .

Definition opposite'_contradict
  {A B : Type} (H : opposite' A B) : contradict A B .
Proof.
 revert H .
 refine (dsum_elim _) .
 refine (sum_elim _ _) .
 -
  refine (fun x p a b => _) .
  refine (cast (A := unit) (B := empty) _ tt) .
  pose (
    D := sum_elim_nodep (A := A) (B := B) (P := Type) (const unit) (const empty)
    ) .
  change (paths (D (left x)) (D (right b))) .
  refine (ap D _).
  exact (p (right b)) .
 -
  refine (fun x p a b => _) .
  refine (cast (A := unit) (B := empty) _ tt) .
  pose (
    D := sum_elim_nodep (A := A) (B := B) (P := Type) (const empty) (const unit)
    ) .
  change (paths (D (right x)) (D (left a))) .
  refine (ap D _).
  exact (p (left a)) .
Defined.

Definition opposite'_opposite
  {A B : Type} (H : opposite' A B) : opposite A B .
Proof.
 refine (pair _ _) .
 -
  exact (opposite'_contradict H) .
 -
  exact (dfst H) .
Defined.

(* false: opposite A B -> opposite' A B *)

Definition opposite_opposite'
  {A B : Type} (IHPA : is_hprop A) (IHPB : is_hprop B)
  (H : opposite A B) : opposite' A B .
Proof.
 revert H .
 refine (prod_elim_nodep _) .
 refine (fun CAB => _).
 refine (sum_elim_nodep _ _) .
 -
  refine (fun x => _) .
  refine (dpair (left x) _) .
  refine (sum_elim _ _) .
  +
   refine (fun a => _) .
   refine (ap left _) .
   exact (dfst (IHPA x a)) .
  +
   refine (fun b => _) .
   refine (absurd _) .
   refine (CAB x b) .
 -
  refine (fun x => _) .
  refine (dpair (right x) _) .
  refine (sum_elim _ _) .
  +
   refine (fun a => _) .
   refine (absurd _) .
   refine (CAB a x) .
  +
   refine (fun b => _) .
   refine (ap right _) .
   exact (dfst (IHPB x b)) .
Defined.

Definition is_hprop_opposite'_left
  {A B : Type} (H : opposite' A B) : is_hprop A .
Proof.
 revert H .
 refine (dsum_elim_nodep _) .
 refine (sum_elim _ _) .
 -
  refine (fun x p => _) .
  refine (contr_paths_contr _) .
  refine (dpair x _) .
  refine (fun y => _) .
  pose (
    D := sum_elim_nodep (A := A) (B := B) idmap (const x)
    ) .
  change (paths (D (left x)) (D (left y))) .
  refine (ap D _) .
  exact (p (left y)) .
 -
  refine (fun x p b => _) .
  refine (absurd _) .
  exact (opposite'_contradict (dpair (right x) p) b x) .
Defined.

Definition is_hprop_opposite'_right
  {A B : Type} (H : opposite' A B) : is_hprop B .
Proof.
 revert H .
 refine (dsum_elim_nodep _) .
 refine (sum_elim _ _) .
 -
  refine (fun x p a => _) .
  refine (absurd _) .
  exact (opposite'_contradict (dpair (left x) p) x a) .
 -
  refine (fun x p => _) .
  refine (contr_paths_contr _) .
  refine (dpair x _) .
  refine (fun y => _) .
  pose (
    D := sum_elim_nodep (A := A) (B := B) (const x) idmap
    ) .
  change (paths (D (right x)) (D (right y))) .
  refine (ap D _) .
  exact (p (right y)) .
Defined.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

(*i $Id: NZCyclic.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Export NZAxioms.
Require Import BigNumPrelude.
Require Import DoubleType.
Require Import CyclicAxioms.

(** * From [CyclicType] to [NZAxiomsSig] *)

(** A [Z/nZ] representation given by a module type [CyclicType]
    implements [NZAxiomsSig], e.g. the common properties between
    N and Z with no ordering. Notice that the [n] in [Z/nZ] is
    a power of 2.
*)

Module NZCyclicAxiomsMod (Import Cyclic : CyclicType) <: NZAxiomsSig.

Local Open Scope Z_scope.

Definition t := w.

Definition NZ_to_Z : t -> Z := znz_to_Z w_op.
Definition Z_to_NZ : Z -> t := znz_of_Z w_op.
Local Notation wB := (base w_op.(znz_digits)).

Local Notation "[| x |]" := (w_op.(znz_to_Z) x) (at level 0, x at level 99).

Definition eq (n m : t) := [| n |] = [| m |].
Definition zero := w_op.(znz_0).
Definition succ := w_op.(znz_succ).
Definition pred := w_op.(znz_pred).
Definition add := w_op.(znz_add).
Definition sub := w_op.(znz_sub).
Definition mul := w_op.(znz_mul).

Local Infix "=="  := eq (at level 70).
Local Notation "0" := zero.
Local Notation S := succ.
Local Notation P := pred.
Local Infix "+" := add.
Local Infix "-" := sub.
Local Infix "*" := mul.

Hint Rewrite w_spec.(spec_0) w_spec.(spec_succ) w_spec.(spec_pred)
 w_spec.(spec_add) w_spec.(spec_mul) w_spec.(spec_sub) : w.
Ltac wsimpl :=
 unfold eq, zero, succ, pred, add, sub, mul; autorewrite with w.
Ltac wcongruence := repeat red; intros; wsimpl; congruence.

Instance eq_equiv : Equivalence eq.
Proof.
unfold eq. firstorder.
Qed.

Instance succ_wd : Proper (eq ==> eq) succ.
Proof.
wcongruence.
Qed.

Instance pred_wd : Proper (eq ==> eq) pred.
Proof.
wcongruence.
Qed.

Instance add_wd : Proper (eq ==> eq ==> eq) add.
Proof.
wcongruence.
Qed.

Instance sub_wd : Proper (eq ==> eq ==> eq) sub.
Proof.
wcongruence.
Qed.

Instance mul_wd : Proper (eq ==> eq ==> eq) mul.
Proof.
wcongruence.
Qed.

Theorem gt_wB_1 : 1 < wB.
Proof.
unfold base. apply Zpower_gt_1; unfold Zlt; auto with zarith.
Qed.

Theorem gt_wB_0 : 0 < wB.
Proof.
pose proof gt_wB_1; auto with zarith.
Qed.

Lemma succ_mod_wB : forall n : Z, (n + 1) mod wB = ((n mod wB) + 1) mod wB.
Proof.
intro n.
pattern 1 at 2. replace 1 with (1 mod wB). rewrite <- Zplus_mod.
reflexivity.
now rewrite Zmod_small; [ | split; [auto with zarith | apply gt_wB_1]].
Qed.

Lemma pred_mod_wB : forall n : Z, (n - 1) mod wB = ((n mod wB) - 1) mod wB.
Proof.
intro n.
pattern 1 at 2. replace 1 with (1 mod wB). rewrite <- Zminus_mod.
reflexivity.
now rewrite Zmod_small; [ | split; [auto with zarith | apply gt_wB_1]].
Qed.

Lemma NZ_to_Z_mod : forall n, [| n |] mod wB = [| n |].
Proof.
intro n; rewrite Zmod_small. reflexivity. apply w_spec.(spec_to_Z).
Qed.

Theorem pred_succ : forall n, P (S n) == n.
Proof.
intro n. wsimpl.
rewrite <- pred_mod_wB.
replace ([| n |] + 1 - 1)%Z with [| n |] by auto with zarith. apply NZ_to_Z_mod.
Qed.

Lemma Z_to_NZ_0 : Z_to_NZ 0%Z == 0.
Proof.
unfold NZ_to_Z, Z_to_NZ. wsimpl.
rewrite znz_of_Z_correct; auto.
exact w_spec. split; [auto with zarith |apply gt_wB_0].
Qed.

Section Induction.

Variable A : t -> Prop.
Hypothesis A_wd : Proper (eq ==> iff) A.
Hypothesis A0 : A 0.
Hypothesis AS : forall n, A n <-> A (S n).
 (* Below, we use only -> direction *)

Let B (n : Z) := A (Z_to_NZ n).

Lemma B0 : B 0.
Proof.
unfold B. now rewrite Z_to_NZ_0.
Qed.

Lemma BS : forall n : Z, 0 <= n -> n < wB - 1 -> B n -> B (n + 1).
Proof.
intros n H1 H2 H3.
unfold B in *. apply -> AS in H3.
setoid_replace (Z_to_NZ (n + 1)) with (S (Z_to_NZ n)). assumption.
wsimpl.
unfold NZ_to_Z, Z_to_NZ.
do 2 (rewrite znz_of_Z_correct; [ | exact w_spec | auto with zarith]).
symmetry; apply Zmod_small; auto with zarith.
Qed.

Lemma B_holds : forall n : Z, 0 <= n < wB -> B n.
Proof.
intros n [H1 H2].
apply Zbounded_induction with wB.
apply B0. apply BS. assumption. assumption.
Qed.

Theorem bi_induction : forall n, A n.
Proof.
intro n. setoid_replace n with (Z_to_NZ (NZ_to_Z n)).
apply B_holds. apply w_spec.(spec_to_Z).
unfold eq, NZ_to_Z, Z_to_NZ; rewrite znz_of_Z_correct.
reflexivity.
exact w_spec.
apply w_spec.(spec_to_Z).
Qed.

End Induction.

Theorem add_0_l : forall n, 0 + n == n.
Proof.
intro n. wsimpl.
rewrite Zplus_0_l. rewrite Zmod_small; [reflexivity | apply w_spec.(spec_to_Z)].
Qed.

Theorem add_succ_l : forall n m, (S n) + m == S (n + m).
Proof.
intros n m. wsimpl.
rewrite succ_mod_wB. repeat rewrite Zplus_mod_idemp_l; try apply gt_wB_0.
rewrite <- (Zplus_assoc ([| n |] mod wB) 1 [| m |]). rewrite Zplus_mod_idemp_l.
rewrite (Zplus_comm 1 [| m |]); now rewrite Zplus_assoc.
Qed.

Theorem sub_0_r : forall n, n - 0 == n.
Proof.
intro n. wsimpl. rewrite Zminus_0_r. apply NZ_to_Z_mod.
Qed.

Theorem sub_succ_r : forall n m, n - (S m) == P (n - m).
Proof.
intros n m. wsimpl. rewrite Zminus_mod_idemp_r, Zminus_mod_idemp_l.
now replace ([|n|] - ([|m|] + 1))%Z with ([|n|] - [|m|] - 1)%Z
     by auto with zarith.
Qed.

Theorem mul_0_l : forall n, 0 * n == 0.
Proof.
intro n. wsimpl. now rewrite Zmult_0_l.
Qed.

Theorem mul_succ_l : forall n m, (S n) * m == n * m + m.
Proof.
intros n m. wsimpl. rewrite Zplus_mod_idemp_l, Zmult_mod_idemp_l.
now rewrite Zmult_plus_distr_l, Zmult_1_l.
Qed.

End NZCyclicAxiomsMod.


Require Import Queue.
Require Import Coq.Structures.Equalities.
Require Import Lists.List.

Module QueueImpl(T: Typ) <: Queue.

  Definition queue : Type := (list T.t * list T.t).
  Definition t : Type := T.t.
  Definition empty : queue := (nil, nil).

  Definition enqueue (x : t)(q : queue) :=
    match q with
    | (l, l') => (x :: l, l')
    end.

  (*Flips the first stack and puts in the position of the second stack*)
  Fixpoint flip (l1: list t) (l2: list t) : queue :=
    match l1 with
      | nil => (l1, l2)
      | x :: tl => flip tl (x :: l2)
    end.

  Definition flip_queue (q: queue) : queue :=
    match q with
    | (_ :: _, nil) => flip (fst q) nil
    | (_, _) => q
    end.

  Definition peek (q: queue) : option t :=
    match (flip_queue q) with
    | (_, x :: _) => Some x
    | (_, _) => None
    end.

  Definition dequeue (q: queue) : queue :=
    match (flip_queue q) with
    | (l1, x :: t) => (l1, t)
    | (_, _) => (nil, nil)
    end.

  Definition is_empty (q: queue) : bool :=
    match q with
    | (nil, nil) => true
    | (_, _) => false
    end.

  Definition size (q: queue) : nat :=
    length (fst q) + length (snd q).

  Definition to_list (q: queue) : list t :=
    snd q ++ rev (fst q).

  Lemma empty_spec: is_empty empty = true.
  Proof.
    unfold empty. reflexivity.
  Qed.

  Lemma enqueue_spec: forall q x,
    to_list (enqueue x q) = (to_list q) ++ (x :: nil).
  Proof.
    intros. unfold to_list. unfold enqueue. destruct q. simpl. rewrite app_assoc. reflexivity.
  Qed.

  Lemma flip_spec: forall l1 l2,
    flip l1 l2 = (nil, (rev l1) ++ l2).
  Proof.
    intros. generalize dependent l2. induction l1; intros; simpl.
    - reflexivity.
    - rewrite IHl1. assert ((rev l1 ++ a :: nil) ++ l2 = rev l1 ++ a :: l2). {
      rewrite <- app_assoc. simpl. reflexivity. } rewrite H. reflexivity.
  Qed.

  Lemma flip_fst_nil: forall l1 l2 x y,
     (flip l1 l2) = (x, y) -> x = nil.
  Proof.
    intros. generalize dependent l2. induction l1; intros; simpl in H.
    - inversion H; subst; reflexivity.
    - apply (IHl1 (a :: l2)). apply H.
  Qed.

  Lemma flip_queue_spec: forall q,
    to_list (flip_queue q) = to_list q.
  Proof.
    intros. unfold flip_queue. destruct q. destruct l.
    - reflexivity.
    - destruct l0; simpl.
      + unfold to_list. rewrite flip_spec. simpl. rewrite app_nil_r. reflexivity.
      + reflexivity.
    Qed.

  Lemma peek_spec_some: forall q x,
    peek q = Some x <-> exists l, to_list q = x :: l.
  Proof.
    intros. split; intros.
    - unfold peek in H. destruct (flip_queue q) eqn : A. destruct l0. inversion H.
      inversion H; subst. pose proof (flip_queue_spec). specialize (H0 q). rewrite A in H0.
      unfold to_list at 1 in H0. simpl in H0. exists (l0 ++ rev l). rewrite <- H0. reflexivity.
    - unfold peek. destruct H. pose proof (flip_queue_spec q). rewrite <- H0 in H.
      destruct (flip_queue q) eqn : A.
      destruct l0. destruct l. unfold to_list in H. simpl in H. inversion H.
      destruct q. simpl in A. destruct l0. inversion A. destruct l1.
      simpl in A. apply flip_fst_nil in A. inversion A. inversion A. unfold to_list in H.
       simpl in H. inversion H; subst; reflexivity.
  Qed.

  Lemma dequeue_spec_empty: forall q,
    to_list q = nil ->
    to_list (dequeue q) = nil.
  Proof.
    intros. destruct q. unfold to_list in H. simpl in H. destruct l0.
    destruct l. unfold dequeue. simpl. unfold to_list. simpl. reflexivity.
    simpl in H. destruct (rev l); inversion H. inversion H.
  Qed.

  Lemma dequeue_spec_nonempty: forall q h tl,
    to_list q = h :: tl ->
    to_list (dequeue q) = tl.
  Proof.
    intros. pose proof (flip_queue_spec q).
    rewrite H in H0. unfold dequeue. destruct (flip_queue q) eqn : A.
    destruct l0. destruct q. simpl in A. destruct l0. inversion A; subst. unfold to_list in H. simpl in H.
    inversion H. destruct l1. apply flip_fst_nil in A. subst. unfold to_list in H0; simpl in H0; inversion H0.
    inversion A. unfold to_list in H0. simpl in H0.
    destruct q. simpl in A. destruct l1. inversion A; subst. unfold to_list; simpl. simpl in H0.
    inversion H0; subst. reflexivity. destruct l2. apply flip_fst_nil in A. subst. inversion H0; subst.
    unfold to_list. simpl. reflexivity. inversion A; subst. unfold to_list; simpl. unfold to_list in H; simpl in H.
    inversion H; subst. reflexivity.
  Qed.

  Lemma is_empty_spec: forall q,
    is_empty q = true <-> to_list q = nil.
  Proof.
    intros. split; intros; destruct q; destruct l; destruct l0; simpl in *;
    unfold to_list in *; simpl in H; try(reflexivity); try(inversion H).
    destruct (rev l); inversion H.
  Qed.

  Lemma size_spec: forall q,
    size q = length (to_list q).
  Proof.
    intros. unfold size. unfold to_list. rewrite app_length. rewrite rev_length. intuition.
  Qed.

  Lemma peek_spec_none: forall q,
    peek q = None <-> is_empty q = true.
  Proof.
    intros. setoid_rewrite is_empty_spec. split; intros.
    - unfold peek in H. pose proof (flip_queue_spec q). destruct (flip_queue q) eqn : A.
      destruct q. simpl in A. destruct l1. destruct l0. inversion A; subst. unfold to_list; reflexivity.
      inversion H. destruct l2. apply flip_fst_nil in A. subst. destruct l0. unfold to_list in H0; simpl in H0.
      destruct (rev l1); inversion H0. inversion H. inversion A; subst. inversion H.
    - unfold to_list in H. destruct q. simpl in *. apply app_eq_nil in H. destruct H.
      subst. assert (l = nil). destruct l. reflexivity. simpl in H0. destruct (rev l); inversion H0. subst.
      unfold peek. reflexivity.
  Qed.

End QueueImpl.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e256m189_12limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.