(********************************

   Monads with Predicate Liftings on Coq
   --- Monadic Hoare Triple

 ********************************)

Set Implicit Arguments.

Notation "A '(.)' B" := (fun x => A (B x)) (at level 50, left associativity).

Definition relation (A: Type) := A -> A -> Prop.

Class Reflexive {A: Type}(R: relation A) :=
  Reflexivity: forall x: A, R x x.

Class Symmetric {A: Type}(R: relation A) :=
  Symmetry: forall x y: A, R x y -> R y x.

Class Transitive {A: Type}(R: relation A) :=
  Transitivity: forall x y z: A, R x y -> R y z -> R x z.

Class Equivalence (A: Type) :=
  {
    equiv_eq: relation A;
    equiv_refl :> Reflexive equiv_eq;
    equiv_sym :> Symmetric equiv_eq;
    equiv_trans :> Transitive equiv_eq
  }.

Implicit Arguments equiv_eq [[A] [Equivalence]].
Notation "A == B" := (equiv_eq A B) (at level 90, no associativity).

Class Antisymmetric {A: Type}(eq: Equivalence A)(R: relation A) :=
  Antisymmetry: forall x y: A, R x y -> R y x -> x == y.

Class PartialOrder {A: Type}(eq: Equivalence A) :=
  {
    pord_ord: relation A;
    pord_refl:> Reflexive pord_ord;
    pord_trans:> Transitive pord_ord;
    pord_antisym:> Antisymmetric eq pord_ord;

    pord_refl_eq:
      forall x y: A,
        x == y -> pord_ord x y
  }.

Implicit Arguments pord_ord [[A] [eq] [PartialOrder]].
Notation "A <= B" := (pord_ord A B) (at level 70, no associativity).

Section eq_Equivalence.
  Require Import List.

  Program Instance eq_Reflexive (A: Type): Reflexive (eq (A:=A)).

  Program Instance eq_Symmetric (A: Type): Symmetric (eq (A:=A)).

  Program Instance eq_Transitive (A: Type): Transitive (eq (A:=A)).

  Program Instance eq_Equivalence (A: Type): Equivalence A :=
    {
      equiv_eq := eq (A:=A)
    }.
End eq_Equivalence.

Section iff_Equivalence.
  Program Instance iff_Reflexive: Reflexive iff.
  Next Obligation.
    tauto.
  Qed.

  Program Instance iff_Symmetric: Symmetric iff.
  Next Obligation.
    tauto.
  Qed.

  Program Instance iff_Transitive: Transitive iff.
  Next Obligation.
    tauto.
  Qed.

  Program Instance iff_Equivalence: Equivalence Prop | 100 :=
    {
      equiv_eq := iff
    }.

End iff_Equivalence.

(****************************************************************

   MonadDef.v

 ****************************************************************)

Module Monad.
  Section MonadDef.

    Reserved Notation "x >>= y" (at level 55, left associativity).
    Class Monad (T: Set -> Set): Type :=
      {
        monad_eq {A: Set}:> Equivalence (T A);

        ret {A: Set}: A -> T A;

        bind {A B: Set}: (A -> T B) -> T A -> T B
                                                where "x >>= y" := (bind y x);

        bind_subst:
          forall (A B: Set)(m m': T A)(f f': A -> T B),
            m == m' ->
            (forall a: A, f a == f' a) ->
            m >>= f == m' >>= f';

        (* monad law *)
        unit_left:
          forall (A B: Set)(f: A -> T B)(a: A),
            (ret a) >>= f == f a;

        unit_right:
          forall (A: Set)(m: T A),
            m >>= ret == m;

        assoc:
          forall (A B C: Set)(f: A -> T B)(g: B -> T C)(m: T A),
            m >>= f >>= g == m >>= fun x => (f x) >>= g
      }.

  End MonadDef.

  Notation "^| A" := (ret A)
                       (at level 0, no associativity): monad_scope.
  Notation "x >>= y" := (bind y x)
                          (at level 55, left associativity): monad_scope.

  Open Scope monad_scope.

  Notation "x >> y" := (x >>= fun _ => y)
                         (at level 55, left associativity): monad_scope.
  Notation "x <- y ; z" := (y >>= (fun x => z))
                             (at level 60, right associativity): monad_scope.
  Notation " x :[ A ] <- y ; z" := (y >>= (fun x: A => z))
                                     (at level 60, right associativity): monad_scope.

  Notation "x <- y ; [ M ] z" := (bind (Monad:=M) (fun x => z) y)
                                   (at level 60, right associativity): monad_scope.

  Notation "f |> g" := (bind g(.)f) (at level 55, left associativity).
  Definition monadic_arrow `{monad: Monad}(X Y: Set) := X -> T Y.
  Notation "X ->> Y" := (monadic_arrow X Y) (at level 60, right associativity).

  Ltac apply_sym e := apply Symmetry; apply e.
  Ltac eapply_sym e := apply Symmetry; eapply e.
  Ltac rewrite_assoc_l :=
    eapply Transitivity; [apply assoc |].
  Ltac rewrite_assoc_r :=
    eapply Transitivity; [| apply assoc].
  Ltac rewrite_assoc_inv_l :=
    eapply Transitivity; [apply Symmetry; apply assoc |].
  Ltac rewrite_assoc_inv_r :=
    eapply Transitivity; [| apply Symmetry; apply assoc].
End Monad.

Section MonadProp.
  Import Monad.

  Context `{mon: Monad}.

  Definition skip: T unit := ret tt.

  Lemma skip_inv:
    forall {A: Set}(m: T A),
      skip >> m == m.
  Proof.
    unfold skip.
    intros.
    apply unit_left.
  Qed.

  Lemma ret_bind:
    forall {A B: Set}(a: A)(f: A ->>B),
      x:[A] <- ret a; f x == (fun x: A => f x) a.
  Proof.
    intros.
    apply unit_left.
  Qed.

  Lemma bind_ret:
    forall {A B: Set}(m: T A)(a: A)(f: A ->>B),
      ret a == m ->
      x <- m; f x == f a.
  Proof.
    intros A B m a f Heq.
    apply Symmetry in Heq.
    eapply Transitivity.
    apply bind_subst.
    apply Heq.
    intro; apply Reflexivity.
    apply unit_left.
  Qed.

  Corollary bind_m_subst:
    forall (A B: Set)(m m': T A)(f: A ->>B),
      m == m' ->
      m >>= f == m' >>= f.
  Proof.
    intros.
    apply bind_subst with (f':=f);
      [| intro; apply Reflexivity].
    apply H.
  Qed.

  Corollary bind_f_subst:
    forall (A B: Set)(m: T A)(f f': A ->>B),
      (forall a: A, f a == f' a) ->
      m >>= f == m >>= f'.
  Proof.
    intros.
    apply bind_subst with (m':=m);
      [apply Reflexivity |].
    apply H.
  Qed.

  Definition fmap {A B: Set}(f: A -> B) := bind (ret(.)f).

  (* monads on [Set] are always strong monads *)
  Definition strength {A B: Set}(p: A*T B) :=
    let (a, m) := p in b <- m; ^|(a, b).

  Lemma strength_property_1:
    forall (A: Set)(m: T A),
      fmap (fun p: unit*A => snd p) (strength (tt, m)) == m.
  Proof.
    intros.
    unfold fmap, strength.
    eapply Transitivity; [ apply assoc |].
    { eapply Transitivity; [ apply bind_f_subst; intro a |].
      - eapply Transitivity; [ apply unit_left |].
        simpl.
        apply Reflexivity.
      - apply unit_right.
    }
  Qed.

  Lemma strength_property_2:
    forall (A B C: Set)(a: A)(b: B)(m: T C),
      fmap (fun t => match t with (x, y, z) => (x, (y, z)) end) (strength ((a,b), m))
      ==
      strength ((fun t => match t with (a, p) => (a, strength p) end) (a, (b, m))).
  Proof.
    unfold fmap, strength.
    intros.
    eapply Transitivity; [ apply assoc |].
    eapply Transitivity; [| apply Symmetry; apply assoc].
    apply bind_f_subst; intro c.
    eapply Transitivity; [ apply unit_left |].
    simpl.
    apply Symmetry.
    eapply Transitivity; [ apply unit_left |].
    apply Reflexivity.
  Qed.

  Definition swap {A B: Set}(p: A*B) :=
    let (a, b) := p in (b, a).

  Definition swap_strength {A B: Set} :=
    (fmap swap)(.)strength(.)(swap (A:=T A)(B:=B)).

End MonadProp.

(*
   Monads with Predicate Liftings
 *)

Module MPL.

  Import Monad.

  Local Open Scope type_scope.

  Section MPLDef.

    Reserved Notation "f # P" (at level 60, right associativity).
    Class MPL (gpr: Set -> Type)`(monad: Monad): Type :=
      {
        gpr_eq {X: Set}:> Equivalence (gpr X);

        modal {X Y: Set}(f: X ->> Y): (gpr Y) -> gpr X
                                                     where "f # P" := (modal f P);

        modal_subst:
          forall (X Y: Set)(f f': X ->> Y)(Q Q': gpr Y),
            (forall x: X, f x == f' x) -> Q == Q' -> f#Q == f'#Q';

        modal_ident:
          forall (X: Set)(P: gpr X),
            P == ret#P;

        modal_compose:
          forall (X Y Z: Set)(f: X ->> Y)(g: Y ->> Z)(R: gpr Z),
            f#g#R == (f|>g)#R

      }.

  End MPLDef.

  Notation "f # P" := (modal f P) (at level 60, right associativity).

  Definition swap `{mpl: MPL}{X Y: Set}
             (P: gpr (X*Y)): gpr (Y*X) :=
    (fun p:Y*X => let (y, x) := p in ret (x, y))#P.

  Section MPLProp.
    Context `{mpl: MPL}.

    Lemma modal_subst_p:
      forall (X Y: Set)(f: X ->> Y)(Q Q': gpr Y),
        Q == Q' -> f#Q == f#Q'.
    Proof.
      intros; apply modal_subst; [| assumption].
      intro; apply Reflexivity.
    Qed.

    Lemma modal_subst_f:
      forall (X Y: Set)(f f': X ->> Y)(Q: gpr Y),
        (forall x: X, f x == f' x) -> f#Q == f'#Q.
    Proof.
      intros; apply modal_subst; [assumption | apply Reflexivity].
    Qed.
  End MPLProp.

End MPL.

Module SemiLat.

  Delimit Scope sl_scope with sl.
  Local Close Scope type_scope.
  Local Open Scope sl_scope.

  Section SemiLattice.
    Context {A: Type}(equiv: Equivalence A).

    Class SemiLattice :=
      {
        sl_binop: A -> A -> A;

        sl_binop_refl:
          forall (x: A),
            sl_binop x x == x;

        sl_binop_comm:
          forall (x y: A),
            sl_binop x y == sl_binop y x;

        sl_binop_assoc:
          forall (x y z: A),
            sl_binop x (sl_binop y z) == sl_binop (sl_binop x y) z;

        sl_binop_subst:
          forall (x x' y y': A),
            x == x' -> y == y' ->
            sl_binop x y == sl_binop x' y'
      }.
    Infix "(+)" := sl_binop
                     (at level 80, right associativity): sl_scope.

    Definition BoundedWith (sl: SemiLattice)(e: A) :=
      forall (x: A), x(+)e == x.

    Definition meet_pord {sl: SemiLattice}(x y: A) :=
      x(+)y == x.

    Program Instance meet_pord_refl
            (sl: SemiLattice): Reflexive (meet_pord).
    Next Obligation.
      unfold meet_pord.
      apply sl_binop_refl.
    Qed.

    Program Instance meet_pord_trans
            (sl: SemiLattice): Transitive (meet_pord).
    Next Obligation.
      unfold meet_pord.
      apply Transitivity with (sl_binop (sl_binop x y) z).
      apply sl_binop_subst; [apply Symmetry; assumption | apply Reflexivity].
      { apply Transitivity with (sl_binop x (sl_binop y z)).
        - apply Symmetry.
          apply sl_binop_assoc.
        - apply Transitivity with (sl_binop x y);
          [| assumption].
          apply sl_binop_subst; [apply Reflexivity | assumption].
      }
    Qed.

    Program Instance meet_pord_antisym
            (sl: SemiLattice): Antisymmetric (equiv ) (meet_pord).
    Next Obligation.
      unfold meet_pord.
      apply Transitivity with (sl_binop y x); [| assumption].
      apply Transitivity with (sl_binop x y); [| apply sl_binop_comm].
      apply Symmetry; assumption.
    Qed.

    Program Instance meet_POrd (sl: SemiLattice): PartialOrder equiv :=
      {
        pord_ord := meet_pord (sl:=sl)
      }.
    Next Obligation.
      unfold meet_pord.
      intros.
      apply Transitivity with (x(+)x);
        [| apply sl_binop_refl].
      apply sl_binop_subst; [apply Reflexivity | apply Symmetry; assumption].
    Qed.
  End SemiLattice.

  Infix "(+)" := sl_binop
                   (at level 80, right associativity): sl_scope.

  Section Homomorphism.
    Context {A B: Type}{equivA: Equivalence A}{equivB: Equivalence B}.

    Definition isSemiLatHom
               (f: A -> B)
               (slA: SemiLattice equivA)
               (slB: SemiLattice equivB) :=
      forall (x y: A),
        f (x(+)y) == (f x)(+)(f y).

  End Homomorphism.

End SemiLat.

Section MPLProperties.
  Import Monad.
  Import MPL.

  Class hasPord `(mpl: MPL) :=
    {
      gpr_pord {X: Set}:> PartialOrder (gpr_eq (X:=X));

      modal_monotone:
        forall {X Y: Set}(f: X ->> Y)(P Q: gpr Y),
          P <= Q -> f#P <= f#Q
    }.

  (* Monadic-Hoare-Triple *)
  Definition MHT `{mpl: MPL}{hp: hasPord mpl}{X Y: Set}(P: gpr X)(f: X ->> Y)(Q: gpr Y) :=
    P <= f#Q.

  Notation "P {- f -} Q" := (MHT P f Q) (at level 70, no associativity).

  Class hasTop `(mpl: MPL)(hp: hasPord mpl) :=
    {
      gpr_top (X: Set): gpr X;

      gpr_pord_top:
        forall {X: Set}(P: gpr X),
          P <= gpr_top X;

      modal_top:
        forall {X Y: Set}(f: X ->> Y),
          f#(gpr_top Y) == gpr_top X
    }.

  Import SemiLat.
  Local Open Scope sl_scope.

  Class hasSL `(mpl: MPL) :=
    {
      gpr_sl (X: Set):> SemiLattice (gpr_eq (X:=X));

      modal_semilathom:
        forall {X Y: Set}(f: X ->> Y),
          isSemiLatHom (modal f) (gpr_sl Y) (gpr_sl X)
    }.

  Program Instance hasPordSL `(mpl: MPL)(hsl: hasSL mpl): hasPord mpl :=
    {
      gpr_pord X := meet_POrd (gpr_sl X)
    }.
  Next Obligation.
    unfold meet_pord in *.
    apply Symmetry.
    eapply Transitivity; [| apply modal_semilathom].
    apply Symmetry.
    apply modal_subst_p; assumption.
  Qed.

  Local Open Scope type_scope.
  Class hasForall `(mpl: MPL) :=
    {
      gpr_forall {X Y: Set}: gpr (X*Y) -> gpr X;

      modal_forall:
        forall {X Y Z: Set}(f: X*Y ->> T Z) P,
        forall y, gpr_forall (modal f P) == modal (fun x => f (x,y)) P
    }.

End MPLProperties.

Notation "P {- f -} Q" := (MHT P f Q) (at level 70, no associativity).

Section MPLProp.
  Import Monad.
  Import MPL.
  Context `{mpl: MPL}{hp: hasPord mpl}.

  Lemma gpr_le_subst:
    forall {X: Set}(P P' Q Q': gpr X),
      P == P' -> Q == Q' -> (P <= Q) -> P' <= Q'.
  Proof.
    do 5 intro.
    intros Heqp Heqq Hpq.
    apply Transitivity with Q; [| apply pord_refl_eq; assumption].
    apply Transitivity with P;
      [apply pord_refl_eq; apply Symmetry |]; assumption.
  Qed.

  Lemma gpr_le_subst_l:
    forall {X: Set}(P P' Q: gpr X),
      P == P' -> P <= Q -> P' <= Q.
  Proof.
    do 4 intro.
    intros Heq.
    apply gpr_le_subst; [assumption | apply Reflexivity].
  Qed.

  Lemma gpr_le_subst_r:
    forall {X: Set}(P Q Q': gpr X),
      Q == Q' -> P <= Q -> P <= Q'.
  Proof.
    do 4 intro.
    intros Heq.
    apply gpr_le_subst; [apply Reflexivity | assumption].
  Qed.

  Lemma MHT_ret:
    forall {X: Set}(P: gpr X),
      P{-ret-}P.
  Proof.
    intros X P.
    unfold MHT.
    apply gpr_le_subst_r with P.
    - apply modal_ident.
    - apply Reflexivity.
  Qed.

  Lemma MHT_compose:
    forall (X Y Z: Set)
           (P: gpr X)(f: X ->> Y)(Q: gpr Y)(g: Y ->> Z)(R: gpr Z),
      P{-f-}Q -> Q{-g-}R -> P{-f|>g-}R.
  Proof.
    intros X Y Z P f Q g R Hpq Hqr.
    unfold MHT in *.
    apply (modal_monotone f) in Hqr.
    apply Transitivity with (f#Q).
    - apply Hpq.
    - generalize dependent Hqr; apply gpr_le_subst_r.
      apply modal_compose.
  Qed.

  Lemma MHT_result:
    forall (X Y: Set)
           (P P': gpr X)(f: X ->> Y)(Q Q': gpr Y),
      P' <= P -> Q <= Q' ->
      P{-f-}Q -> P'{-f-}Q'.
  Proof.
    intros.
    unfold MHT in *.
    apply Transitivity with P; [assumption |].
    apply Transitivity with (f#Q); [assumption |].
    apply modal_monotone.
    assumption.
  Qed.

  Lemma MHT_result_l:
    forall (X Y: Set)
           (P P': gpr X)(f: X ->> Y)(Q: gpr Y),
      P' <= P -> P{-f-}Q -> P'{-f-}Q.
  Proof.
    do 7 intro; apply MHT_result; [assumption | apply Reflexivity].
  Qed.

  Lemma MHT_result_r:
    forall (X Y: Set)
           (P: gpr X)(f: X ->> Y)(Q Q': gpr Y),
      Q <= Q' -> P{-f-}Q -> P{-f-}Q'.
  Proof.
    do 7 intro; apply MHT_result; [apply Reflexivity | assumption].
  Qed.

  Lemma MHT_compose_inverse:
    forall (X Y Z: Set)
           (P: gpr X)(f: X ->> Y)(g: Y ->> Z)(R: gpr Z),
      P{-f|>g-}R ->
      exists Q: gpr Y,
        P{-f-}Q/\Q{-g-}R.
  Proof.
    do 7 intro.
    unfold MHT.
    intro Hle.
    exists (g#R).
    split.
    - generalize dependent Hle; apply gpr_le_subst_r.
      apply Symmetry; apply modal_compose.
    - apply Reflexivity.
  Qed.

  Lemma MHT_subst:
    forall {X Y: Set}(P: gpr X)(f f': X ->> Y)(Q: gpr Y),
      P {- f -} Q ->
      (forall x, f x == f' x) ->
      P {- f' -} Q.
  Proof.
    do 6 intro.
    intros Hht Heq; generalize dependent Hht.
    unfold MHT in *.
    apply gpr_le_subst_r.
    apply modal_subst_f.
    apply Heq.
  Qed.

End MPLProp.

Import Monad.

Program Instance IdMonad: Monad id :=
  {
    monad_eq A := eq_Equivalence A;
    ret A a := a;
    bind A B f m := f m
  }.

Section Pred.

  Import SemiLat.
  Definition Pred (A: Set) := A -> Prop.

  Program Instance PredEquiv (X: Set)
  : Equivalence (Pred X) :=
    {
      equiv_eq P Q := forall (x: X), P x <-> Q x
    }.
  Next Obligation.
    intros P; tauto.
  Qed.
  Next Obligation.
    intros P Q Hpq x.
    destruct (Hpq x).
    tauto.
  Qed.
  Next Obligation.
    intros P Q R Hpq Hqr x.
    generalize (Hpq x); generalize (Hqr x).
    tauto.
  Qed.

  Program Instance PredSemiLat (X: Set): SemiLattice (PredEquiv X) :=
    {
      sl_binop P Q := fun x => P x/\Q x
    }.
  Next Obligation.
    tauto.
  Qed.
  Next Obligation.
    tauto.
  Qed.
  Next Obligation.
    tauto.
  Qed.
  Next Obligation.
    rewrite H.
    rewrite H0.
    tauto.
  Qed.

  Definition Pred_pord {X: Set}: relation (Pred X) :=
    fun P Q => forall x, P x -> Q x.

  Program Instance Pred_pord_Refl X: Reflexive (Pred_pord (X:=X)).
  Next Obligation.
    unfold Pred_pord; tauto.
  Qed.

  Program Instance Pred_pord_Antisym X
  : Antisymmetric (PredEquiv X) (Pred_pord(X:=X)).
  Next Obligation.
    unfold Pred_pord in *.
    split; [apply H | apply H0].
  Qed.

  Program Instance Pred_pord_Trans X: Transitive (Pred_pord (X:=X)).
  Next Obligation.
    unfold Pred_pord in *.
    intros.
    apply H0; apply H; assumption.
  Qed.

  Program Instance PredPOrd (X: Set): PartialOrder (PredEquiv X) :=
    {
      pord_ord P Q := Pred_pord P Q
    }.
  Next Obligation.
    unfold Pred_pord.
    apply H; assumption.
  Qed.

End Pred.

(* trivial example *)
Section IdMPL.

  Import MPL.
  Import SemiLat.

  Existing Instance PredEquiv.
  Existing Instance PredSemiLat.
  Existing Instance PredPOrd.

  Program Instance IdMPL: MPL (fun X: Set => X -> Prop) IdMonad :=
    {
      modal X Y f Q m := Q (f m)
    }.
  Next Obligation.
    rewrite H.
    apply H0.
  Qed.
  Next Obligation.
    tauto.
  Qed.
  Next Obligation.
    tauto.
  Qed.

  Program Instance IdMPLhasSemiLat: hasSL IdMPL.
  Next Obligation.
    unfold isSemiLatHom.
    simpl.
    intros P Q x.
    tauto.
  Qed.

  Program Instance IdMPLhasPord : hasPord IdMPL.
  Next Obligation.
    unfold Pred_pord in *.
    intro x; apply H.
  Qed.

End IdMPL.

Section MPLTR.

  Record NonEmptySet: Type :=
    {
      nes_Set:> Set;
      nes_base: nes_Set
    }.

  Lemma nes_exact:
    forall (S: NonEmptySet),
    exists e: S, True.
  Proof.
    intros.
    exists (nes_base S).
    apply I.
  Qed.

  Import Monad.

  Class MonadState (S: NonEmptySet)`(monad: Monad): Type :=
    {
      get: T S;
      put: S ->>unit;

      put_put:
        forall (s s': S),
          put s >> put s' == put s';

      put_get:
        forall s: S,
          put s >> get == put s >> ^| s;

      get_put:
        get >>= put == skip;

      get_get:
        forall {A: Set}(k: S -> S ->>A),
          s <- get; (get >>= k s) == s <- get; (k s s)
    }.

  Section MonadStateProp.
    Context {S: NonEmptySet}`{ms: MonadState S}.

    Lemma get_put_m_m:
      forall (A: Set)(m: T A),
        (s <- get; put s >> m) == m.
    Proof.
      intros.
      eapply Transitivity.
      apply Symmetry.
      apply assoc.
      eapply Transitivity; [| apply skip_inv].
      apply bind_m_subst.
      apply get_put.
    Qed.

    Lemma put_get_put:
      forall (s: S)(f: S -> S),
        (put s >> (x <- get; put (f x))) == put (f s).
    Proof.
      intros s f.
      eapply Transitivity.
      apply Symmetry.
      apply assoc.
      eapply Transitivity.
      apply bind_m_subst.
      apply put_get.
      eapply Transitivity.
      apply assoc.
      eapply Transitivity.
      apply bind_f_subst.
      intros.
      eapply Transitivity.
      apply unit_left; apply put_put.
      apply Reflexivity.
      apply put_put.
    Qed.

    Lemma put_bind_comm:
      forall {A B: Set}(m: T A)(s: S)(f: A ->>B),
        put s >> (x <- m; f x)  == x <- (put s >> m); f x.
    Proof.
      intros.
      apply Symmetry.
      apply assoc.
    Qed.

    Lemma ret_state_inv:
      forall (A: Set)(a: A),
        ret a >> get == get.
    Proof.
      intros.
      eapply Transitivity.
      apply unit_left.
      apply Reflexivity.
    Qed.

    Corollary put_ret_get:
      forall (A: Set)(a: A)(s: S),
        put s >> ^| a >> get == put s >> get.
    Proof.
      intros.
      eapply Transitivity; [apply assoc |].
      apply bind_f_subst; intro.
      apply ret_state_inv.
    Qed.

    Definition state_modify
               {A: Set}(f: S -> S)(m: T A): T A :=
      s <- get; put (f s) >> m.

  End MonadStateProp.

  (**
   ** State Monad Transformer
   *)
  Section StateM.
    Context (S: NonEmptySet)`(monad: Monad).

    Existing Instance monad_eq.
    Local Open Scope type_scope.
    Definition StateM (A: Set): Set := S ->> (A*S).

    Definition StateM_eq (A: Set): relation (StateM A) :=
      fun m1 m2: StateM A => (forall s: S, m1 s == m2 s).

    Program Instance StateM_eq_Equivalence (A: Set): Equivalence (StateM A) :=
      {
        equiv_eq := @StateM_eq A
      }.
    Next Obligation.
    Proof.
      simpl.
      intros x s.
      apply Reflexivity.
    Qed.
    Next Obligation.
    Proof.
      intros x y Heq s.
      apply Symmetry.
      apply Heq.
    Qed.
    Next Obligation.
    Proof.
      intros x y z Heqxy Heqyz s.
      apply Transitivity with (y s).
      apply Heqxy.
      apply Heqyz.
    Qed.

    Program Instance StateTrans: Monad StateM | 30:=
      {
        monad_eq A := StateM_eq_Equivalence A;
        ret A a := fun s: S => ret (a, s);
        bind A B f m :=
          fun (s: S) =>
            p :[A*S] <- m s; let (a, s') := p in f a s'
      }.
    Next Obligation.
    Proof.
      simpl.
      intros s.
      apply bind_subst.
      apply H.

      intros [a s'].
      apply H0.
    Qed.
    Next Obligation.
    Proof.
      intros s.
      eapply Transitivity.
      apply unit_left.
      apply Reflexivity.
    Qed.
    Next Obligation.
    Proof.
      intros s.
      eapply Transitivity.
      apply bind_f_subst.
      intros [a s'].
      apply Reflexivity.
      apply unit_right.
    Qed.
    Next Obligation.
    Proof.
      intros s.
      eapply Transitivity.
      apply assoc.
      apply bind_f_subst.
      intros [a s'].
      apply Reflexivity.
    Qed.

    Definition StateM_get: StateM S :=
      fun s: S => ret (s, s).

    Definition StateM_put (s: S): StateM unit :=
      fun _: S => ret (tt, s).

    Program Instance S_StateTrans: MonadState S StateTrans | 30:=
      {
        get := StateM_get;
        put s := StateM_put s
      }.
    Next Obligation.
    Proof.
      simpl.
      intros s''.
      unfold StateM_get, StateM_put.
      eapply Transitivity.
      apply unit_left.
      apply Reflexivity.
    Qed.
    Next Obligation.
    Proof.
      simpl.
      intros s'.
      unfold StateM_put, StateM_get.
      eapply Transitivity.
      apply unit_left.
      apply Symmetry.
      eapply Transitivity.
      apply unit_left.
      apply Reflexivity.
    Qed.
    Next Obligation.
    Proof.
      simpl.
      intro s.
      unfold StateM_put, StateM_get.
      eapply Transitivity.
      apply unit_left.
      apply Reflexivity.
    Qed.
    Next Obligation.
    Proof.
      simpl.
      intros s.
      unfold StateM_get.
      eapply Transitivity.
      apply unit_left.
      eapply Transitivity.
      apply unit_left.
      apply Symmetry.
      eapply Transitivity.
      apply unit_left.
      apply Reflexivity.
    Qed.

    Definition runState {A: Set}(m: StateM A)(s: S) := m s.

  End StateM.

  Definition State (S: NonEmptySet):= StateM S IdMonad.
  Instance StateMonad (S: NonEmptySet): Monad (State S) |50 := StateTrans S IdMonad.
  Instance S_StateMonad (S: NonEmptySet): MonadState S (StateMonad S) |50 := S_StateTrans S IdMonad.

  Definition nes_nat :=
    {| nes_Set := nat; nes_base := 0 |}.

  Section SPred.
    Open Scope type_scope.

    Import SemiLat.
    Definition SPred (S: NonEmptySet)(A: Set) := A -> S -> Prop.

    Program Instance SPredEquiv S (X: Set)
    : Equivalence (SPred S X) :=
      {
        equiv_eq P Q := forall (s: S)(x: X), P x s <-> Q x s
      }.
    Next Obligation.
      intros P; tauto.
    Qed.
    Next Obligation.
      intros P Q Hpq s x.
      destruct (Hpq s x).
      tauto.
    Qed.
    Next Obligation.
      intros P Q R Hpq Hqr s x.
      generalize (Hpq s x); generalize (Hqr s x).
      tauto.
    Qed.

    Program Instance SPredSemiLat S (X: Set): SemiLattice (SPredEquiv S X) :=
      {
        sl_binop P Q := fun x s => P x s/\Q x s
      }.
    Next Obligation.
      tauto.
    Qed.
    Next Obligation.
      tauto.
    Qed.
    Next Obligation.
      tauto.
    Qed.
    Next Obligation.
      rewrite H.
      rewrite H0.
      tauto.
    Qed.

    Definition SPred_pord {S: NonEmptySet}{X: Set}: relation (SPred S X) :=
      fun P Q => forall x s, P x s -> Q x s.

    Program Instance SPred_pord_Refl S X: Reflexive (SPred_pord (S:=S)(X:=X)).
    Next Obligation.
      unfold SPred_pord; tauto.
    Qed.

    Program Instance SPred_pord_Antisym S X
    : Antisymmetric (SPredEquiv S X) (SPred_pord (S:=S)(X:=X)).
    Next Obligation.
      unfold SPred_pord in *.
      split; [apply H | apply H0].
    Qed.

    Program Instance SPred_pord_Trans S X: Transitive (SPred_pord (S:=S)(X:=X)).
    Next Obligation.
      unfold SPred_pord in *.
      intros.
      apply H0; apply H; assumption.
    Qed.

    Program Instance SPredPOrd S (X: Set): PartialOrder (SPredEquiv S X) :=
      {
        pord_ord P Q := forall x s, P x s -> Q x s
      }.
    Next Obligation.
      apply H; assumption.
    Qed.

  End SPred.

  Import MPL.
  Import SemiLat.

  Existing Instance SPredEquiv.
  Existing Instance SPredPOrd.
  Existing Instance SPredSemiLat.

  Program Instance StateMonadMPL (S: NonEmptySet): MPL (SPred S) (StateMonad S) :=
    {
      modal A B f P x :=
        fun s: S =>
          let (y, s') := f x s in P y s'
    }.
  Next Obligation.
    remember (f x s) as fxs.
    destruct fxs as [y s'].
    rewrite <- H.
    rewrite <- Heqfxs.
    apply H0.
  Qed.
  Next Obligation.
    tauto.
  Qed.
  Next Obligation.
    remember (f x s) as fxs.
    destruct fxs as [y s'].
    tauto.
  Qed.

  Program Instance SMMPLhasSemiLat S: hasSL (StateMonadMPL S).
  Next Obligation.
    unfold isSemiLatHom.
    simpl.
    intros P Q s x.
    destruct (f x s); tauto.
  Qed.

  Program Instance SMMPLhasPord S : hasPord (StateMonadMPL S).
  Next Obligation.
    destruct (f x s); apply H; tauto.
  Qed.

  Program Instance SMMPLhasTop S : hasTop (SMMPLhasPord S) :=
    {
      gpr_top X := fun _ _ => True
    }.
  Next Obligation.
    destruct (f x s); tauto.
  Qed.

  Program Instance SMMPLhasPordSL S : hasPord (StateMonadMPL S) :=
    hasPordSL (StateMonadMPL S) (SMMPLhasSemiLat S).

  Class MSPL (S: NonEmptySet)(gpr: Set -> Type)`(monad: Monad): Type :=
    {
      mspl_mpl :> MPL gpr monad;
      mspl_monadstate :> MonadState S monad
    }.

  (* Tree Relabeling *)
  Section TreeRelabeling.

    Require Import Arith.
    Require Import List.
    Notation "[]" := nil.
    Notation "[ X ; .. ; Y ]" := (X:: .. (Y::[]) ..)
                                   (at level 60, right associativity).

    Let T := State nes_nat.
    Import MPL.

    Existing Instance StateMonadMPL.

    Inductive Tree (A: Set): Set :=
    | Leaf (a: A)
    | Node (l r: Tree A).

    Fixpoint relabel {A: Set}(t: Tree A): T (Tree nat) :=
      match t with
        | Leaf _ => x <- get;
                   put ((S x):nes_nat) >> ret (Leaf x)
        | Node l r => l' <- relabel l;
                     r' <- relabel r;
                     ret (Node l' r')
      end.

    Fixpoint flatten {A: Set}(t: Tree A): list A :=
      match t with
        | Leaf a => [a]
        | Node l r => flatten l ++ flatten r
      end.

    Local Open Scope nat_scope.
    Fixpoint size {A: Set}(t: Tree A): nat :=
      match t with
        | Leaf a => 1
        | Node l r => size l + size r
      end.

    Fixpoint seq (x n: nat): list nat :=
      match n with
        | 0 => nil
        | S n' => x::seq (S x) n'
      end.

    Lemma seq_split:
      forall (x y z: nat),
        seq x (y+z) = seq x y ++ seq (x+y) z.
    Proof.
      intros x y; generalize dependent x.
      induction y as [| y].
      - simpl.
        intro.
        rewrite plus_comm; reflexivity.
      - simpl; intros x z.
        rewrite (IHy (S x) z).
        rewrite <- plus_n_Sm; simpl.
        reflexivity.
    Qed.

    Definition plus_size_eq {A: Set}(n: nat): SPred nes_nat (Tree A)
      := (fun t final => (final = n + size t)).

    Definition StateIs {S: NonEmptySet}{X: Set}(i: S): SPred S X
      := fun (_:X)(s: S) => s = i.

    Existing Instance SMMPLhasPord.

    Lemma relabel_state_plus_size:
      forall (A: Set)(n: nes_nat),
        StateIs n {-relabel (A:=A)-} plus_size_eq n.
    Proof.
      intros A i.
      unfold MHT, StateIs, plus_size_eq.
      simpl.
      intros t s Heq; subst s.
      generalize dependent i.
      induction t as  [a | l IHl r IHr]; simpl.
      - intro i; rewrite plus_comm; auto with arith.
      - intro i.
        generalize (IHl i); intro IHli.
        destruct (relabel l i) as [l' m].
        generalize (IHr m); intro IHrm.
        destruct (relabel r m) as [r' f].
        subst m f.
        simpl.
        auto with arith.
    Qed.

    Lemma size_flatten:
      forall {A: Set}(t: Tree A),
        size t = length (flatten t).
    Proof.
      induction t as [a | l IHl r IHr]; simpl.
      - reflexivity.
      - rewrite app_length; auto.
    Qed.

    Definition flat_seq_eq {A: Set}(n: nat): SPred nes_nat (Tree nat) :=
      (fun t final => (flatten t = seq n (size t))).

    Notation "P & Q" := (fun x s => P x s /\ Q x s)
                          (at level 55, left associativity).

    Notation "P ! Q" := (fun x s => P x s \/ Q x s)
                          (at level 56, left associativity).

    Lemma relabelNoDup_aux:
      forall (A: Set)(n: nes_nat),
        StateIs n {-relabel (A:=A)-} plus_size_eq n & flat_seq_eq (A:=A) n.
    Proof.
      intros A i.
      unfold MHT, StateIs, plus_size_eq, flat_seq_eq.
      simpl.
      intros t s Heq; subst s.
      generalize dependent i.
      induction t as  [a | l IHl r IHr]; simpl.
      - intro i; split; [rewrite plus_comm; auto with arith | reflexivity].
      - intro i.
        generalize (IHl i); intro IHli.
        destruct (relabel l i) as [l' m].
        generalize (IHr m); intro IHrm.
        destruct (relabel r m) as [r' f].
        destruct IHli as [Hndl  IHli].
        destruct IHrm as [Hndr  IHrm].
        simpl; split.
        + subst m f.
          auto with arith.
        + rewrite seq_split.
          rewrite <- IHli.
          rewrite <- Hndl.
          rewrite <- IHrm.
          reflexivity.
    Qed.

    Lemma lt_notIn:
      forall (n x y: nat),
        x < y -> ~In x (seq y n).
    Proof.
      induction n as [| n].
      - simpl; intros; tauto.
      - simpl.
        intros x y Hlt [Heq | HIn].
        + subst; elim (lt_irrefl _ Hlt).
        + apply IHn in HIn; [tauto | auto with arith].
    Qed.

    Lemma seq_NoDup:
      forall (x y: nat),
        NoDup (seq x y).
    Proof.
      intros x y; generalize dependent x.
      induction y as [| y].
      - simpl; intros; try constructor.
      - simpl; intros; try constructor.
        + apply lt_notIn; auto with arith.
        + apply IHy.
    Qed.

    Definition state_ignore {X: Set}{S: NonEmptySet}(P: X -> Prop): SPred S X :=
      fun x _ => P x.

    Notation "$ P" := (state_ignore P) (at level 50, no associativity).

    Implicit Arguments NoDup [[A]].
    Lemma relabelNoDup:
      forall (A: Set)(n: nes_nat),
        StateIs n {- relabel (A:=A) -}$(NoDup(.)flatten).
    Proof.
      intros A n.
      eapply MHT_result_r; [| apply relabelNoDup_aux].
      intros t s [_ Heq].
      unfold state_ignore.
      rewrite Heq; clear Heq.
      apply seq_NoDup.
    Qed.

  End TreeRelabeling.

End MPLTR.


Definition identity {A : Type} (x : A) := x.

Class functor (f : Type -> Type) :=
  { fmap : forall {a b}, (a -> b) -> f a -> f b

  ; identity_law : forall a (x : f a), fmap identity x = identity x
  }.

Fixpoint option_map {A B : Type} (f : A -> B) (o : option A): option B :=
  match o with
    | None => None
    | Some x => Some (f x)
  end.

Instance option_functor : functor option :=
  { fmap := @option_map
  }.
intros.
destruct x.
reflexivity.
reflexivity.
Qed.


Require Import Coq.Arith.Arith.

Set Implicit Arguments.

Local Open Scope nat.

Lemma fold_4_mult : forall n, n + (n + (n + (n + 0))) = 4 * n.
  intros; ring.
Qed.

Lemma fold_4_mult_2 : 4 * 2 = 8.
  eauto.
Qed.

Lemma fold_4_mult_1 : 4 * 1 = 4.
  eauto.
Qed.

Require Import Bedrock.Word.
Require Import Bedrock.IL.
Require Import Bedrock.Memory.

Lemma wplus_0 : forall w : W, w ^+ $0 = w.
  intros; rewrite wplus_comm; eapply wplus_unit.
Qed.

Require Import Bedrock.SepIL.

Ltac rewrite_natToW_plus :=
  repeat match goal with
           | H : context [ natToW (_ + _) ] |- _ => rewrite natToW_plus in H
           | |- context [ natToW (_ + _) ] => rewrite natToW_plus
         end.

Lemma wplus_wminus : forall (a b : W), a ^+ b ^- b = a.
  intros; W_eq.
Qed.

Lemma wordToNat_natToW_le : forall n, (wordToNat (natToW n) <= n)%nat.
  unfold natToW; intros.
  edestruct wordToNat_natToWord as [ ? [ ] ].
  rewrite H.
  generalize dependent (x * pow2 32); intros.
  omega.
Qed.

Require Import Bedrock.Arrays.

Lemma wle_goodSize_le : forall a b, (natToW a <= natToW b)%word -> goodSize a -> (a <= b)%nat.
  intros; eapply le_wordToN in H; eauto; eapply le_trans; eauto; eapply wordToNat_natToW_le.
Qed.

Lemma wordToNat_eq_eq : forall x y : W, wordToNat x = wordToNat y -> x = y.
  intros.
  assert (natToW (wordToNat x) = natToW (wordToNat y)).
  congruence.
  unfold natToW in *.
  repeat erewrite natToWord_wordToNat in *.
  eauto.
Qed.


Require Import Iron.Language.SystemF2Cap.Value.Relation.TyJudge.

(* Weakening Store Typing in Type Judgement. *)
Lemma typex_stenv_snoc
 :  forall ke te se sp t2 x t1 e1
 ,  ClosedT t2
 -> TypeX  ke te se         sp x t1 e1
 -> TypeX  ke te (t2 <: se) sp x t1 e1.
Proof.
 intros. gen ke te se sp t1 e1 t2.
 induction x using exp_mutind with
  (PV := fun v => forall ke te se sp t1 t2
      ,  ClosedT t2
      -> TypeV ke te se         sp v t1
      -> TypeV ke te (t2 <: se) sp v t1)
  ; intros; inverts_type; eauto.

 - Case "VLAM".
   eapply TvLAM.
   spec IHx H8 H. clear H8.
   unfold liftTE in *.
   simpl. norm.
   rrwrite (liftTT 1 0 t2 = t2).
   auto.

 - Case "XPrivate".
   eapply TxPrivate with (t := t) (e := e); eauto.
   spec IHx H12 H. clear H12.
   unfold liftTE in *.
   simpl. norm.
   rrwrite (liftTT 1 0 t2 = t2).
   auto.

 - Case "XExtend".
   eapply TxExtend; eauto.
   spec IHx H11 H. clear H11.
   unfold liftTE in *.
   simpl. norm.
   rrwrite (liftTT 1 0 t2 = t2).
   eauto.
Qed.
Hint Resolve typex_stenv_snoc.

Lemma typev_stenv_snoc
 :  forall ke te se sp t2 v t1
 ,  ClosedT t2
 -> TypeV ke te se         sp v t1
 -> TypeV ke te (t2 <: se) sp v t1.
Proof.
 intros.
 have HX: (TypeX ke te se sp (XVal v) t1 (TBot KEffect)).
 eapply typex_stenv_snoc in HX.
 inverts HX; eauto.
 eauto.
Qed.
Hint Resolve typev_stenv_snoc.

Lemma typex_stenv_weaken
 :  forall ke te se1 se2 sp x t1 e1
 ,  Forall ClosedT se2
 -> TypeX  ke te  se1         sp x t1 e1
 -> TypeX  ke te (se2 >< se1) sp x t1 e1.
Proof.
 intros. gen ke te se1 sp.
 induction se2; intros.
 - burn.
 - rrwrite ((se2 :> a) >< se1 = se2 >< (a <: se1)).
   inverts H. rip.
Qed.
Hint Resolve typex_stenv_weaken.

Lemma typex_stenv_extends
 :  forall ke te se1 se2 sp x t1 e1
 ,  Forall ClosedT se2
 -> extends se2 se1
 -> TypeX ke te se1 sp x t1 e1
 -> TypeX ke te se2 sp x t1 e1.
Proof.
 intros.
 unfold extends in *.
 destruct H0 as [se3]. subst.
 eapply typex_stenv_weaken; auto.
  eauto.
Qed.
Hint Resolve typex_stenv_extends.

Lemma typev_stenv_extends
 :  forall ke te sp se1 se2 v t1
 ,  Forall ClosedT se2
 -> extends se2 se1
 -> TypeV ke te se1 sp v t1
 -> TypeV ke te se2 sp v t1.
Proof.
 intros.
 unfold extends in *.
 destruct H0 as [se3]. subst.
 assert (TypeX ke te (se3 >< se1) sp (XVal v) t1 (TBot KEffect)) as HX.
  eauto.
 inverts HX. auto.
Qed.
Hint Resolve typex_stenv_extends.


Require Import Verse.Types.Internal.
Require Import Verse.Language.
Require Import Verse.Syntax.
Require Import Verse.DecFacts.
Require Import Verse.Semantics.Store.

Require Import Eqdep_dec.

Set Implicit Arguments.

Generalizable All Variables.

Section Context.

  Variable var : VariableT.
  Variable var_eqb : forall {k} {ty : type k} (v1 v2 : var ty), bool.

  Variable var_eqb_eq
    : forall {k} {ty : type k} (v1 v2 : var ty), var_eqb v1 v2 = true <-> v1 = v2.

  Definition contextUpdate (tyD : typeC TypeDenote)
             k {ty : type k} (v : var ty)
             (f : @typeDenote TypeDenote _ _ ty -> @typeDenote TypeDenote _ _ ty) :
    context var -> context var.
    unfold context in *. intros oldctxt k0 ty0 x.
    destruct (kind_eq_dec k0 k); subst.
    destruct (ty_eq_dec ty0 ty); subst.
    exact (if var_eqb x v then
             f (oldctxt _ _ x)               (* update according to f at var *)
           else
             oldctxt _ _ x).
    all: exact (oldctxt _ _ x).              (* use initial state value at all other points *)
  Defined.

  Lemma evalSane (tyD : typeC TypeDenote)
    : forall (s : context var) k (ty : type k) (v : var ty) f,
      forall k' (ty' : type k') (v' : var ty'),
        (v_sig_eqb var (@var_eqb) _ _ v' v = false -> (contextUpdate v f s) _ _ v' = s _ _ v')
        /\
        (contextUpdate v f s) _ _ v = f (s _ _ v).
    intros.
    constructor.
    unfold contextUpdate.
    unfold v_sig_eqb.
    intro.
    destruct (kind_eq_dec k' k).
    subst k'.
    unfold eq_rect_r.
    simpl in *.
    destruct (ty_eq_dec ty' ty).
    subst ty'.
    simpl in *.
    rewrite H.
    trivial.
    trivial.
    trivial.

    unfold contextUpdate.
    destruct (kind_eq_dec k k).
    pose (eq_proofs_unicity (eq_dec_eq_dec_P kind_eq_dec) e eq_refl).
    rewrite e0.
    unfold eq_rect_r.
    simpl.
    destruct (ty_eq_dec ty ty).
    pose (eq_proofs_unicity (eq_dec_eq_dec_P ty_eq_dec) e1 eq_refl).
    subst e1.
    simpl.
    assert (var_eqb v v = true).

    apply (var_eqb_eq); trivial.
    rewrite H.
    trivial.
    contradict n; trivial.
    contradict n; trivial.
  Qed.

  Definition ctxtStore (tyD : typeC TypeDenote) : Store :=
    {| v := var;
       v_eqb := var_eqb;

       v_eqb_eq := var_eqb_eq;

       store := context var;

       eval  := id;
       storeUpdate := @contextUpdate tyD;

       evalUpdate := @evalSane tyD
    |}.

End Context.


(** Tactics to help write packages

  In this module we define handy tactics to deal with obligations generated
  by packages operations and packages in general.

  - in_fset_auto
    This tactic should solve goals of the form
    x \in S
    where S is a concrete finite set that contains x.

  - inseq_try
    This tactic should solve goals of the form
    x \in S
    where S is a sequence that contains x syntactically.

  - inset_try
    Similar to inseq_try but for fset.
    It is slightly stronger than in_fset_auto in that it also works in case
    the mem predicate doesn't compute in itself.

  - package_obtac
    This tactic can be used as an obligation tactic for Program or Equations
    mode.
    It can be set with
    Obligation Tactic := package_obtac.

**)

Set Warnings "-notation-overridden,-ambiguous-paths".
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq eqtype
  choice.
Set Warnings "notation-overridden,ambiguous-paths".
From extructures Require Import ord fset fmap.
From Crypt Require Import Prelude pkg_core_definition
  pkg_composition pkg_notation choice_type
  RulesStateProb.
From Coq Require Import Utf8 FunctionalExtensionality
  Setoids.Setoid Classes.Morphisms.

From Equations Require Import Equations.
Require Equations.Prop.DepElim.

Import PackageNotation.
#[local] Open Scope package_scope.

Set Bullet Behavior "Strict Subproofs".
Set Default Goal Selector "!".
Set Primitive Projections.

Ltac package_obtac :=
  (* Or try (Tactics.program_simpl; fail); simpl ? *)
  Tactics.program_simplify ;
  CoreTactics.equations_simpl ;
  try Tactics.program_solve_wf ;
  try in_fset_auto ;
  try inset_try.

(* With the following, one can rewrite under λ with setoid_rewrite *)

#[export] Instance pointwise_eq_ext {A B : Type} {RB : relation B} (sb : subrelation RB eq) :
  subrelation (pointwise_relation A RB) eq.
Proof.
  intros f g Hfg.
  apply functional_extensionality.
  intro x. apply sb. apply Hfg.
Qed.

(** Rewriting under binders with setoid_rewrite *)

#[export] Instance opr_morphism (A : choiceType) o :
  Proper (eq ==> pointwise_relation (tgt o) eq ==> eq) (@opr A o).
Proof.
  simpl_relation.
  f_equal. apply functional_extensionality. auto.
Qed.

#[export] Instance getr_morphism (A : choiceType) l :
  Proper (pointwise_relation (Value l.π1) eq ==> eq) (@getr A l).
Proof.
  simpl_relation.
  f_equal. apply functional_extensionality. auto.
Qed.

#[export] Instance sampler_morphism (A : choiceType) o :
  Proper (pointwise_relation (Arit o) eq ==> eq) (@sampler A o).
Proof.
  simpl_relation.
  f_equal. apply functional_extensionality. auto.
Qed.

#[export] Instance bind_morphism (A B : choiceType) :
  Proper (eq ==> pointwise_relation A eq ==> eq) (@bind A B).
Proof.
  simpl_relation.
  f_equal. apply functional_extensionality. auto.
Qed.

(** Some validity lemmata and hints *)
(* TODO MOVE? *)

Definition fromEmpty {B} {v : opsig} (H : v \in fset0) : B.
Proof.
  rewrite in_fset0 in H.
  move: H. move /eqP. move /eqP => H.
  discriminate.
Defined.

Lemma valid_empty_package :
  ∀ L I,
    ValidPackage L I [interface] emptym.
Proof.
  intros L I.
  rewrite -fset0E.
  apply prove_valid_package.
  intros [id [S T]] ho. eapply fromEmpty. eauto.
Qed.

#[export] Hint Extern 1 (ValidPackage ?L ?I ?E (mkfmap [::])) =>
  try (replace E with [interface] by eapply fset0E) ;
  eapply valid_empty_package
  : typeclass_instances ssprove_valid_db.

Lemma valid_package1 :
  ∀ L I i A B f,
    (∀ x, ValidCode L I (f x)) →
    ValidPackage L I (fset [:: (i, (A, B))]) (mkfmap [:: (i, mkdef A B f)]).
Proof.
  intros L I i A B f hf.
  apply prove_valid_package.
  intros o ho. rewrite in_fset in ho.
  rewrite mem_seq1 in ho. move: ho => /eqP ho. subst o.
  cbn. exists f.
  destruct (eqn i i) eqn:e.
  2:{ move: e => /eqP. contradiction. }
  intuition auto.
Qed.

(* Would be a shortcut, but when backtracking, this has an unnecessary cost *)
(* #[export] Hint Extern 1 (ValidPackage ?L ?I ?E (mkfmap [:: (?i, mkdef ?A ?B ?f)])) =>
  eapply valid_package1 ;
  intro ; eapply valid_code_from_class
  : typeclass_instances. *)

Lemma flat_valid_package :
  ∀ L I E p,
    ValidPackage L I E p →
    flat E.
Proof.
  intros L I E p hp.
  intros i [u1 u2] [v1 v2] h1 h2.
  eapply from_valid_package in hp.
  specialize (hp _ h1) as h1'.
  specialize (hp _ h2) as h2'.
  simpl in *.
  destruct h1' as [f [ef _]].
  destruct h2' as [g [eg _]].
  rewrite ef in eg. noconf eg.
  reflexivity.
Qed.

Lemma valid_package_cons :
  ∀ L I i A B f E p,
    ValidPackage L I (fset E) (mkfmap p) →
    (∀ x, ValidCode L I (f x)) →
    i \notin (λ '(i,_), i) @: fset E →
    ValidPackage L I (fset ((i, (A, B)) :: E))
      (mkfmap ((i, mkdef A B f) :: p)).
Proof.
  intros L I i A B f E p hp hf hi.
  apply prove_valid_package.
  intros o ho. rewrite in_fset in ho. rewrite in_cons in ho.
  move: ho => /orP [ho | ho].
  - move: ho => /eqP ho. subst o.
    rewrite mkfmapE. cbn. exists f.
    destruct (eqn i i) eqn:e.
    2:{ move: e => /eqP. contradiction. }
    intuition auto.
  - rewrite -in_fset in ho.
    eapply from_valid_package in hp.
    specialize (hp _ ho).
    destruct o as [id [S T]].
    destruct hp as [g [eg hg]].
    rewrite mkfmapE. cbn.
    destruct (eqn id i) eqn:e.
    1:{
      move: e => /eqP e. subst id.
      eapply mem_imfset with (f := λ '(i,_), i) in ho.
      unfold "\notin" in hi. rewrite ho in hi.
      discriminate.
    }
    rewrite mkfmapE in eg.
    exists g. intuition auto.
Qed.

Lemma valid_package_cons_upto :
  ∀ L I i A B A' B' f E p,
    ValidPackage L I (fset E) (mkfmap p) →
    (∀ x, ValidCode L I (f x)) →
    i \notin (λ '(i,_), i) @: fset E →
    A = A' →
    B = B' →
    ValidPackage L I (fset ((i, (A', B')) :: E))
      (mkfmap ((i, mkdef A B f) :: p)).
Proof.
  intros L I i A B A' B' f E p hp hf hi eA eB. subst.
  eapply valid_package_cons. all: eauto.
Qed.

(* TODO MOVE *)
Lemma notin_fset :
  ∀ (T : ordType) (s : seq T) (x : T),
    (x \notin fset s) = (x \notin s).
Proof.
  intros T s x.
  unfold "\notin". rewrite in_fset. reflexivity.
Qed.

#[export] Hint Extern 100 =>
  shelve : ssprove_valid_db.

#[export] Hint Extern 2 (is_true (?x \in fset ?I)) =>
  rewrite in_fset
  : typeclass_instances ssprove_valid_db.

#[export] Hint Extern 3 (is_true (?x \in ?I)) =>
  reflexivity
  : typeclass_instances ssprove_valid_db.

#[export] Hint Extern 3 (is_true (?x \in ?I)) =>
  inseq_try
  : typeclass_instances ssprove_valid_db.

#[export] Hint Extern 2 (is_true (?x \notin fset ?I)) =>
  rewrite notin_fset
  : typeclass_instances ssprove_valid_db.

#[export] Hint Extern 3 (is_true (?x \notin ?I)) =>
  reflexivity
  : typeclass_instances ssprove_valid_db.

#[export] Hint Extern 3 (is_true (fsubset [interface] ?L)) =>
  rewrite <- fset0E ; eapply fsub0set
  : typeclass_instances ssprove_valid_db.

#[export] Hint Extern 2 (ValidPackage ?L ?I ?E (mkfmap ((?i, mkdef ?A ?B ?f) :: ?p)))
  =>
  eapply valid_package_cons ; [
    idtac
  | intro
  | rewrite imfset_fset ; rewrite notin_fset
  ]
  : typeclass_instances ssprove_valid_db.

Lemma trimmed_empty_package :
  trimmed [interface] (mkfmap nil).
Proof.
  unfold trimmed. simpl. unfold trim.
  apply eq_fmap. intro n.
  rewrite filtermE. rewrite emptymE. reflexivity.
Qed.

Lemma trimmed_package_cons :
  ∀ i A B f p E,
    trimmed (fset E) (mkfmap p) →
    trimmed (fset ((i, (A, B)) :: E)) (mkfmap ((i, mkdef A B f) :: p)).
Proof.
  intros i A B f p E h.
  unfold trimmed. unfold trim.
  apply eq_fmap. intro n.
  rewrite filtermE.
  rewrite mkfmapE. simpl.
  destruct (n == i) eqn:e.
  - simpl. move: e => /eqP e. subst.
    rewrite in_fset. rewrite in_cons. rewrite eqxx. simpl.
    reflexivity.
  - unfold trimmed, trim in h.
    apply eq_fmap in h. specialize (h n).
    rewrite filtermE in h. rewrite mkfmapE in h.
    rewrite -[X in _ = X]h.
    destruct (getm_def p n) as [[S [T g]]|] eqn:e'.
    2:{ rewrite e'. reflexivity. }
    rewrite e'. simpl.
    rewrite !in_fset. rewrite in_cons.
    destruct ((n, (S, T)) == (i, (A, B))) eqn:e2.
    1:{
      exfalso. move: e2 => /eqP e2. noconf e2.
      rewrite eqxx in e. discriminate.
    }
    rewrite e2. simpl. reflexivity.
Qed.

#[export] Hint Extern 1 (trimmed ?E (mkfmap [::])) =>
  eapply trimmed_empty_package
: typeclass_instances ssprove_valid_db.

#[export] Hint Extern 2 (trimmed ?E (mkfmap ((?i, mkdef ?A ?B ?f) :: ?p))) =>
  eapply trimmed_package_cons
: typeclass_instances ssprove_valid_db.

Lemma valid_scheme :
  ∀ A L I c,
    @ValidCode fset0 [interface] A c →
    ValidCode L I c.
Proof.
  intros A L I c h.
  eapply valid_injectMap. 2: eapply valid_injectLocations.
  1-2: eapply fsub0set.
  rewrite -fset0E in h. auto.
Qed.

Ltac choice_type_eq_prove :=
  lazymatch goal with
  | |- chProd _ _ = chProd _ _ => f_equal ; choice_type_eq_prove
  | |- chMap _ _ = chMap _ _ => f_equal ; choice_type_eq_prove
  | |- chOption _ = chOption _ => f_equal ; choice_type_eq_prove
  | |- chFin _ = chFin _ => f_equal ; apply positive_ext ; reflexivity
  | |- _ = _ => reflexivity
  end.

#[export] Hint Extern 4 (ValidPackage ?L ?I ?E (mkfmap ((?i, mkdef ?A ?B ?f) :: ?p)))
  =>
  eapply valid_package_cons_upto ; [
    idtac
  | intro
  | rewrite imfset_fset ; rewrite notin_fset
  | choice_type_eq_prove
  | choice_type_eq_prove
  ]
  : typeclass_instances ssprove_valid_db.

#[export] Hint Extern 10 (ValidCode ?L ?I (let u := _ in _)) =>
  cbv zeta
  : typeclass_instances ssprove_valid_db.

#[export] Hint Extern 2 (ValidCode ?L ?I (match ?t with _ => _ end)) =>
  destruct t
  : typeclass_instances ssprove_valid_db.

Ltac ssprove_valid :=
  (unshelve typeclasses eauto with ssprove_valid_db) ; shelve_unifiable.


From Hammer Require Import Hammer.

Require Import Setoid.
Require Import RelationClasses.
Require Import Morphisms.

Set Implicit Arguments.
Set Strict Implicit.

Theorem Proper_red : forall T U (rT : relation T) (rU : relation U) (f : T -> U),
(forall x x', rT x x' -> rU (f x) (f x')) ->
Proper (rT ==> rU) f.
intuition.
Qed.

Theorem respectful_red : forall T U (rT : relation T) (rU : relation U) (f g : T -> U),
(forall x x', rT x x' -> rU (f x) (g x')) ->
respectful rT rU f g.
intuition.
Qed.
Theorem respectful_if_bool T : forall (x x' : bool) (t t' f f' : T) eqT,
x = x' ->
eqT t t' -> eqT f f' ->
eqT (if x then t else f) (if x' then t' else f') .
intros; subst; auto; destruct x'; auto.
Qed.

Ltac derive_morph :=
repeat
first [ lazymatch goal with
| |- Proper _ _ => red; intros
| |- (_ ==> _)%signature _ _ => red; intros
end
| apply respectful_red; intros
| apply respectful_if_bool; intros
| match goal with
| [ H : (_ ==> ?EQ)%signature ?F ?F' |- ?EQ (?F _) (?F' _) ] =>
apply H
| [ |- ?EQ (?F _) (?F _) ] =>
let inst := constr:(_ : Proper (_ ==> EQ) F) in
apply inst
| [ H : (_ ==> _ ==> ?EQ)%signature ?F ?F' |- ?EQ (?F _ _) (?F' _ _) ] =>
apply H
| [ |- ?EQ (?F _ _) (?F' _ _) ] =>
let inst := constr:(_ : Proper (_ ==> _ ==> EQ) F) in
apply inst
| [ |- ?EQ (?F _ _ _) (?F _ _ _) ] =>
let inst := constr:(_ : Proper (_ ==> _ ==> _ ==> EQ) F) in
apply inst
| [ |- ?EQ (?F _) (?F _) ] => unfold F
| [ |- ?EQ (?F _ _) (?F _ _) ] => unfold F
| [ |- ?EQ (?F _ _ _) (?F _ _ _) ] => unfold F
end ].

Global Instance Proper_andb : Proper (@eq bool ==> @eq bool ==> @eq bool) andb.
derive_morph; auto.
Qed.

Section K.
Variable F : bool -> bool -> bool.
Hypothesis Fproper : Proper (@eq bool ==> @eq bool ==> @eq bool) F.
Existing Instance Fproper.

Definition food (x y z : bool) : bool :=
F x (F y z).

Global Instance Proper_food : Proper (@eq bool ==> @eq bool ==> @eq bool ==> @eq bool) food.
Proof. hammer_hook "Parametric" "Parametric.Proper_food".
derive_morph; auto.
Qed.

Global Instance Proper_S : Proper (@eq nat ==> @eq nat) S.
Proof. hammer_hook "Parametric" "Parametric.Proper_S".
derive_morph; auto.
Qed.
End K.

Require Import List.

Section Map.
Variable T : Type.
Variable eqT : relation T.
Inductive listEq {T} (eqT : relation T) : relation (list T) :=
| listEq_nil : listEq eqT nil nil
| listEq_cons : forall x x' y y', eqT x x' -> listEq eqT y y' ->listEq eqT (x :: y) (x' :: y').

Theorem listEq_match V U (eqV : relation V) (eqU : relation U) : forall x x' : list V,
forall X X' Y Y',
eqU X X' ->
(eqV ==> listEq eqV ==> eqU)%signature Y Y' ->
listEq eqV x x' ->
eqU (match x with
| nil => X
| x :: xs => Y x xs
end)
(match x' with
| nil => X'
| x :: xs => Y' x xs
end).
Proof. hammer_hook "Parametric" "Parametric.listEq_match".
intros. induction H1; auto. derive_morph; auto.
Qed.

Variable U : Type.
Variable eqU : relation U.
Variable f : T -> U.
Variable fproper : Proper (eqT ==> eqU) f.

Definition hd (l : list T) : option T :=
match l with
| nil => None
| l :: _ => Some l
end.

Fixpoint map' (l : list T) : list U :=
match l with
| nil => nil
| l :: ls => f l :: map' ls
end.

Global Instance Proper_map' : Proper (listEq eqT ==> listEq eqU) map'.
Proof. hammer_hook "Parametric" "Parametric.Proper_map'".
derive_morph. induction H; econstructor; derive_morph; auto.
Qed.
End Map.


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

Require Export List.
Require Export Bintree.
Require Import Bool.

Declare ML Module "rtauto_plugin".

Ltac caseq t := generalize (refl_equal t); pattern t at -1; case t.
Ltac clean:=try (simpl;congruence).

Inductive form:Set:=
  Atom : positive -> form
| Arrow : form -> form -> form
| Bot
| Conjunct : form -> form -> form
| Disjunct : form -> form -> form.

Notation "[ n ]":=(Atom n).
Notation "A =>> B":= (Arrow A B) (at level 59, right associativity).
Notation "#" := Bot.
Notation "A //\\ B" := (Conjunct A B) (at level 57, left associativity).
Notation "A \\// B" := (Disjunct A B) (at level 58, left associativity).

Definition ctx := Store form.

Fixpoint pos_eq (m n:positive) {struct m} :bool :=
match m with
  xI mm => match n with xI nn => pos_eq mm nn | _ => false end
| xO mm => match n with xO nn => pos_eq mm nn | _ => false end
| xH => match n with xH => true | _ => false end
end.

Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n.
induction m;simpl;destruct n;congruence ||
(intro e;apply f_equal;auto).
Qed.

Fixpoint form_eq (p q:form) {struct p} :bool :=
match p with
  Atom m => match q with Atom n => pos_eq m n | _ => false end
| Arrow p1 p2 =>
match q with
  Arrow q1 q2 => form_eq p1 q1 && form_eq p2 q2
| _ => false end
| Bot => match q with Bot => true | _ => false end
| Conjunct p1 p2 =>
match q with
  Conjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2
| _ => false
end
| Disjunct p1 p2 =>
match q with
  Disjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2
| _ => false
end
end.

Theorem form_eq_refl: forall p q, form_eq p q = true -> p = q.
induction p;destruct q;simpl;clean.
intro h;generalize (pos_eq_refl _ _ h);congruence.
caseq (form_eq p1 q1);clean.
intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence.
caseq (form_eq p1 q1);clean.
intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence.
caseq (form_eq p1 q1);clean.
intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence.
Qed.

Implicit Arguments form_eq_refl [p q].

Section with_env.

Variable env:Store Prop.

Fixpoint interp_form (f:form): Prop :=
match f with
[n]=> match get n env with PNone => True | PSome P => P end
| A =>> B => (interp_form A) -> (interp_form B)
| # => False
| A //\\ B => (interp_form A) /\ (interp_form B)
| A \\// B => (interp_form A) \/ (interp_form B)
end.

Notation "[[ A ]]" := (interp_form A).

Fixpoint interp_ctx (hyps:ctx) (F:Full hyps) (G:Prop) {struct F} : Prop :=
match F with
  F_empty => G
| F_push H hyps0 F0 =>  interp_ctx hyps0 F0  ([[H]] -> G)
end.

Require Export BinPos.

Ltac wipe := intros;simpl;constructor.

Lemma compose0 :
forall hyps F (A:Prop),
 A ->
 (interp_ctx hyps F A).
induction F;intros A H;simpl;auto.
Qed.

Lemma compose1 :
forall hyps F (A B:Prop),
 (A -> B) ->
 (interp_ctx hyps F A) ->
 (interp_ctx hyps F B).
induction F;intros A B H;simpl;auto.
apply IHF;auto.
Qed.

Theorem compose2 :
forall hyps F (A B C:Prop),
 (A -> B -> C) ->
 (interp_ctx hyps F A) ->
 (interp_ctx hyps F B) ->
 (interp_ctx hyps F C).
induction F;intros A B C H;simpl;auto.
apply IHF;auto.
Qed.

Theorem compose3 :
forall hyps F (A B C D:Prop),
 (A -> B -> C -> D) ->
 (interp_ctx hyps F A) ->
 (interp_ctx hyps F B) ->
 (interp_ctx hyps F C) ->
 (interp_ctx hyps F D).
induction F;intros A B C D H;simpl;auto.
apply IHF;auto.
Qed.

Lemma weaken : forall hyps F f G,
 (interp_ctx hyps F G) ->
 (interp_ctx (hyps\f)  (F_push f hyps F) G).
induction F;simpl;intros;auto.
apply compose1 with ([[a]]-> G);auto.
Qed.

Theorem project_In : forall hyps F g,
In g hyps F ->
interp_ctx hyps F [[g]].
induction F;simpl.
contradiction.
intros g H;destruct H.
subst;apply compose0;simpl;trivial.
apply compose1 with [[g]];auto.
Qed.

Theorem project : forall hyps F p g,
get  p hyps = PSome g->
interp_ctx hyps F [[g]].
intros hyps F p g e; apply project_In.
apply get_In with p;assumption.
Qed.

Implicit Arguments project [hyps p g].

Inductive proof:Set :=
  Ax : positive -> proof
| I_Arrow : proof -> proof
| E_Arrow : positive -> positive -> proof -> proof
| D_Arrow : positive -> proof -> proof -> proof
| E_False : positive -> proof
| I_And: proof -> proof -> proof
| E_And: positive -> proof -> proof
| D_And: positive -> proof -> proof
| I_Or_l: proof -> proof
| I_Or_r: proof -> proof
| E_Or: positive -> proof -> proof -> proof
| D_Or: positive -> proof -> proof
| Cut: form -> proof -> proof -> proof.

Notation "hyps \ A" := (push A hyps) (at level 72,left associativity).

Fixpoint check_proof (hyps:ctx) (gl:form) (P:proof) {struct P}: bool :=
 match P with
   Ax i =>
     match get i hyps with
         PSome F => form_eq F gl
 | _ => false
    end
| I_Arrow p =>
   match gl with
      A  =>> B  => check_proof (hyps \ A) B p
   | _ => false
    end
| E_Arrow i j p =>
   match get i hyps,get j hyps with
       PSome A,PSome (B =>>C) =>
         form_eq A B && check_proof (hyps \ C) (gl) p
    | _,_ => false
    end
| D_Arrow i p1 p2 =>
   match get i hyps with
      PSome  ((A =>>B)=>>C) =>
     (check_proof ( hyps \ B =>> C \ A) B p1) && (check_proof (hyps \ C) gl p2)
    | _ => false
  end
| E_False i =>
  match get i hyps with
    PSome # => true
  | _ => false
  end
| I_And p1 p2 =>
   match gl with
      A //\\ B =>
      check_proof hyps A p1 && check_proof hyps B p2
      | _ => false
      end
| E_And i p =>
   match get i hyps with
      PSome  (A //\\ B) => check_proof (hyps \ A \ B) gl p
    | _=> false
   end
| D_And i p =>
   match get i hyps with
      PSome  (A //\\ B =>> C) => check_proof (hyps \ A=>>B=>>C) gl p
    | _=> false
   end
| I_Or_l p =>
   match gl with
      (A \\// B) => check_proof hyps A p
      | _ => false
      end
| I_Or_r p =>
   match gl with
      (A \\// B) => check_proof hyps B p
      | _ => false
      end
| E_Or i p1 p2 =>
  match get i hyps with
  PSome (A \\// B) =>
  check_proof (hyps \ A) gl p1 && check_proof (hyps \ B) gl p2
  | _=> false
  end
| D_Or i p =>
   match get i hyps with
      PSome  (A \\// B =>> C) =>
      (check_proof (hyps \ A=>>C \ B=>>C) gl p)
    | _=> false
   end
| Cut A p1 p2 =>
  check_proof hyps A p1 && check_proof (hyps \ A) gl p2
end.

Theorem interp_proof:
forall p hyps F gl,
check_proof hyps gl p = true -> interp_ctx hyps F [[gl]].

induction p;intros hyps F gl.

(* cas Axiom *)
Focus 1.
simpl;caseq (get p hyps);clean.
intros f nth_f e;rewrite <- (form_eq_refl e).
apply project with p;trivial.

(* Cas Arrow_Intro *)
Focus 1.
destruct gl;clean.
simpl;intros.
change (interp_ctx (hyps\gl1)  (F_push gl1 hyps F) [[gl2]]).
apply IHp;try constructor;trivial.

(* Cas Arrow_Elim *)
Focus 1.
simpl check_proof;caseq (get p hyps);clean.
intros f ef;caseq (get p0 hyps);clean.
intros f0 ef0;destruct f0;clean.
caseq (form_eq f f0_1);clean.
simpl;intros e check_p1.
generalize  (project  F ef) (project  F ef0)
(IHp (hyps \ f0_2) (F_push f0_2 hyps F) gl check_p1);
clear check_p1 IHp p p0 p1 ef ef0.
simpl.
apply compose3.
rewrite (form_eq_refl e).
auto.

(* cas Arrow_Destruct *)
Focus 1.
simpl;caseq (get p1 hyps);clean.
intros f ef;destruct f;clean.
destruct f1;clean.
caseq (check_proof (hyps \ f1_2 =>> f2 \ f1_1) f1_2 p2);clean.
intros check_p1 check_p2.
generalize (project F ef)
(IHp1 (hyps \ f1_2 =>> f2 \ f1_1)
(F_push f1_1 (hyps \ f1_2 =>> f2)
 (F_push (f1_2 =>> f2) hyps F)) f1_2 check_p1)
(IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2).
simpl;apply compose3;auto.

(* Cas False_Elim *)
Focus 1.
simpl;caseq (get p hyps);clean.
intros f ef;destruct f;clean.
intros _; generalize (project F ef).
apply compose1;apply False_ind.

(* Cas And_Intro *)
Focus 1.
simpl;destruct gl;clean.
caseq (check_proof hyps gl1 p1);clean.
intros Hp1 Hp2;generalize (IHp1 hyps F gl1 Hp1) (IHp2 hyps F gl2 Hp2).
apply compose2 ;simpl;auto.

(* cas And_Elim *)
Focus 1.
simpl;caseq (get p hyps);clean.
intros f ef;destruct f;clean.
intro check_p;generalize  (project F ef)
(IHp (hyps \ f1 \ f2) (F_push f2 (hyps \ f1) (F_push f1 hyps F)) gl check_p).
simpl;apply compose2;intros [h1 h2];auto.

(* cas And_Destruct *)
Focus 1.
simpl;caseq (get p hyps);clean.
intros f ef;destruct f;clean.
destruct f1;clean.
intro H;generalize  (project F ef)
(IHp (hyps \ f1_1 =>> f1_2 =>> f2)
(F_push (f1_1 =>> f1_2 =>> f2) hyps F) gl H);clear H;simpl.
apply compose2;auto.

(* cas Or_Intro_left *)
Focus 1.
destruct gl;clean.
intro Hp;generalize (IHp hyps F gl1 Hp).
apply compose1;simpl;auto.

(* cas Or_Intro_right *)
Focus 1.
destruct gl;clean.
intro Hp;generalize (IHp hyps F gl2 Hp).
apply compose1;simpl;auto.

(* cas Or_elim *)
Focus 1.
simpl;caseq (get p1 hyps);clean.
intros f ef;destruct f;clean.
caseq (check_proof (hyps \ f1) gl p2);clean.
intros check_p1 check_p2;generalize (project F ef)
(IHp1 (hyps \ f1) (F_push f1 hyps F) gl check_p1)
(IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2);
simpl;apply compose3;simpl;intro h;destruct h;auto.

(* cas Or_Destruct *)
Focus 1.
simpl;caseq (get p hyps);clean.
intros f ef;destruct f;clean.
destruct f1;clean.
intro check_p0;generalize (project F ef)
(IHp (hyps \ f1_1 =>> f2 \ f1_2 =>> f2)
(F_push (f1_2 =>> f2) (hyps \ f1_1 =>> f2)
 (F_push (f1_1 =>> f2) hyps F)) gl check_p0);simpl.
apply compose2;auto.

(* cas Cut *)
Focus 1.
simpl;caseq (check_proof hyps f p1);clean.
intros check_p1 check_p2;
generalize (IHp1 hyps F f check_p1)
(IHp2 (hyps\f) (F_push f hyps F) gl check_p2);
simpl; apply compose2;auto.
Qed.

Theorem Reflect: forall gl prf, if check_proof empty gl prf then [[gl]] else True.
intros gl prf;caseq (check_proof empty gl prf);intro check_prf.
change (interp_ctx empty F_empty [[gl]]) ;
apply interp_proof with prf;assumption.
trivial.
Qed.

End with_env.

(*
(* A small example *)
Parameters A B C D:Prop.
Theorem toto:A /\ (B \/ C) -> (A /\ B) \/ (A /\ C).
exact (Reflect (empty \ A \ B \ C)
([1] //\\ ([2] \\// [3]) =>> [1] //\\ [2] \\// [1] //\\ [3])
(I_Arrow (E_And 1 (E_Or 3
  (I_Or_l (I_And (Ax 2) (Ax 4)))
  (I_Or_r (I_And (Ax 2) (Ax 4))))))).
Qed.
Print toto.
*)


Require Export mindless.erasable.
Import ErasableNotation.
Require Export Coq.ZArith.ZArith.
Require Import mindless.utils.
Require Import mindless.factorevars.
Require Import mindless.hypiter.
Require Import Coq.micromega.Lia.

Notation EZ := ##Z (only parsing).

Open Scope Z_scope.

Arguments Z.add x y : simpl nomatch.
Arguments Z.sub m n : simpl nomatch.
Arguments Z.opp x : simpl nomatch.
Arguments Z.mul x y : simpl nomatch.

Definition ezadd(x y : EZ) := (lift2 Z.add) x y.
Arguments ezadd !x !y.
Definition ezsub(x y : EZ) := (lift2 Z.sub) x y.
Arguments ezsub !x !y.
Definition ezopp(x : EZ) := (lift1 Z.opp) x.
Arguments ezopp !x.
Definition ezmul(x y : EZ) := (lift2 Z.mul) x y.
Arguments ezmul !x !y.

Declare Scope E_scope.
Notation "x + y" := (ezadd x y) : E_scope.
Notation "x - y" := (ezsub x y) : E_scope.
Notation "- x" := (ezopp x) : E_scope.
Notation "x * y" := (ezmul x y) : E_scope.

Notation "x < y" := ((liftP2 Z.lt) x y) : E_scope.
Notation "x > y" := ((liftP2 Z.gt) x y) : E_scope.
Notation "x <= y" := ((liftP2 Z.le) x y) : E_scope.
Notation "x >= y" := ((liftP2 Z.ge) x y) : E_scope.

Opaque Z.mul.

Notation EB := ##bool (only parsing).

Definition Enegb := lift1 negb.

Definition b2Z(b : bool) : Z := if b then 1 else 0.
Definition Eb2Z := lift1 b2Z.

Hint Unfold ezadd ezsub ezopp ezmul Enegb Eb2Z : lift_unfolds.

Notation "^ b" := (b2Z b) (at level 30, format "^ b") : Z_scope.
Notation "^ b" := (Eb2Z b) (at level 30, format "^ b") : E_scope.

Lemma b2Zbounds : forall b, ^b >= 0 /\ ^b <= 1.
Proof.
  dintros.
  destruct b; cbn; lia.
Qed.

(* How should we classify rewrite rules?  By their applicability -
meaning by the type of formula in which they would have a chance of
rewriting something. *)

(*Set Default Proof Using "Type".
Set Proof Using Clear Unused.*)

Set Default Proof Using "Type".
Set Suggest Proof Using.

Section Bool_Rewrites.

  Variables b b1 b2 : bool.

  Tactic Notation "!!" :=
    repeat destruct_goal_bool; cbn; intuition congruence.

  (*bool term rewrites*)
  Lemma negbf_rw : negb false = true.  Proof. !!.  Qed.
  Lemma negbt_rw : negb true = false. Proof. !!. Qed.
  Lemma dubnegb_rw : negb (negb b) = b. Proof. !!. Qed.

  (*bool equality rewrites*)
  Lemma teqt_rw : true = true <-> True. Proof. !!. Qed.
  Lemma feqf_rw : false = false <-> True. Proof. !!. Qed.
  Lemma teqf_rw : true = false <-> False. Proof. !!. Qed.
  Lemma feqt_rw : false = true <-> False. Proof. !!. Qed.
  Lemma bneq_rw : b1 <> b2 <-> b1 = negb b2. Proof. !!. Qed.
  Lemma negbfl_rw : negb b = false <-> b = true. Proof. !!. Qed.
  Lemma negbfr_rw : false = negb b <-> b = true. Proof. !!. Qed.
  Lemma negbtl_rw : negb b = true <-> b = false. Proof. !!. Qed.
  Lemma negbtr_rw : true = negb b <-> b = false. Proof. !!. Qed.
  Lemma negb_inj_rw : negb b1 = negb b2 <-> b1 = b2. Proof. !!. Qed.

End Bool_Rewrites.

Hint Rewrite
     negbf_rw negbt_rw dubnegb_rw
  : bool_term_rws simp_rws term_rws.

Hint Rewrite
     teqt_rw feqf_rw teqf_rw feqt_rw bneq_rw negbfl_rw negbfr_rw negbtl_rw
     negbtr_rw negb_inj_rw
  : bool_eq_rws simp_rws eq_rws.

Section EB_Rewrites.
  Variables b b1 b2 : EB.

  Tactic Notation "!!" :=
    clear; unerase; cbn; autorewrite with bool_term_rws bool_eq_rws unerase_rws; tauto.

  (*EB term rewrites*)
  Lemma Enegbf_rw : Enegb #false = #true. Proof. !!. Qed.
  Lemma Enegbt_rw : Enegb #true = #false. Proof. !!. Qed.
  Lemma Edubnegb_rw : Enegb (Enegb b) = b. Proof. !!. Qed.

  (*EB equality rewrites*)
  Lemma Eteqt_rw : #true = #true <-> True. Proof. !!. Qed.
  Lemma Efeqf_rw : #false = #false <-> True. Proof. !!. Qed.
  Lemma Eteqf_rw : #true = #false <-> False. Proof. !!. Qed.
  Lemma Efeqt_rw : #false = #true <-> False. Proof. !!. Qed.
  Lemma Ebneq_rw : b1 <> b2 <-> b1 = Enegb b2. Proof. !!. Qed.
  Lemma Enegbfl_rw : Enegb b = #false <-> b = #true. Proof. !!. Qed.
  Lemma Enegbfr_rw : #false = Enegb b <-> b = #true. Proof. !!. Qed.
  Lemma Enegbtl_rw : Enegb b = #true <-> b = #false. Proof. !!. Qed.
  Lemma Enegbtr_rw : #true = Enegb b <-> b = #false. Proof. !!. Qed.
  Lemma Enegb_inj_rw : Enegb b1 = Enegb b2 <-> b1 = b2. Proof. !!. Qed.

End EB_Rewrites.

Hint Rewrite
     Enegbf_rw Enegbt_rw Edubnegb_rw
  : EB_term_rws simp_rws term_rws.

Hint Rewrite
     Eteqt_rw Efeqf_rw Eteqf_rw Efeqt_rw Ebneq_rw Enegbfl_rw Enegbfr_rw
     Enegbtl_rw Enegbtr_rw Enegb_inj_rw
  : EB_eq_rws eq_rws.

Section EZ_Desharping_Rewrites.
  Variables m n : Z.
  Variable b : bool.

  Tactic Notation "!!" := clear; cbn; reflexivity.
  Open Scope E_scope.
  Lemma eadd_desharp_rw : (#n + #m) = #(n + m)%Z. Proof. !!. Qed.
  Lemma esub_desharp_rw : (#n - #m) = #(n - m)%Z. Proof. !!. Qed.
  Lemma emul_desharp_rw : (#n * #m) = #(n * m)%Z. Proof. !!. Qed.
  Lemma eopp_desharp_rw : - #n = #(- n)%Z. Proof. !!. Qed.
  Lemma Enegb_desharp_rw : Enegb #b = #(negb b). Proof. !!. Qed.
  Lemma Eb2Z_desharp_rw : ^#b = #(^b)%Z. Proof. !!. Qed.

End EZ_Desharping_Rewrites.

Hint Rewrite
     eadd_desharp_rw esub_desharp_rw emul_desharp_rw eopp_desharp_rw
     Enegb_desharp_rw Eb2Z_desharp_rw
  : desharping_rws unerase_rws.

Hint Rewrite <-
     eadd_desharp_rw esub_desharp_rw emul_desharp_rw eopp_desharp_rw
     Enegb_desharp_rw Eb2Z_desharp_rw
  : ensharping_rws simp_rws.

Section B2Z_Rewrites.
  Variable b b1 b2 : bool.

  Tactic Notation "!!" :=
    repeat destruct_goal_bool; cbn; intuition congruence.

  (*b2Z term rewrites*)
  Lemma b2Zt_rw : ^true = 1. Proof. !!. Qed.
  Lemma b2Zf_rw : ^false = 0. Proof. !!. Qed.
  Lemma b2Z_negb_rw : ^(negb b) = 1 - ^b. Proof. !!. Qed.

  (*b2Z equality rewrites*)
  Lemma b2Z_inj_rw : ^b1 = ^b2 <-> b1 = b2. Proof. !!. Qed.
  Lemma b2Zeq1l_rw : ^b = 1 <-> b = true. Proof. !!. Qed.
  Lemma b2Zeq1r_rw : 1 = ^b <-> b = true. Proof. !!. Qed.
  Lemma b2Zeq0l_rw : ^b = 0 <-> b = false. Proof. !!. Qed.
  Lemma b2Zeq0r_rw : 0 = ^b <-> b = false. Proof. !!. Qed.
  Lemma b2Zeq1mb2Z_rw : ^b1 = 1 - ^b2 <-> b1 = negb b2. Proof. !!. Qed.
  Lemma b2Zeq1mb2Zs_rw : 1 - ^b2 = ^b1 <-> b1 = negb b2. Proof. !!. Qed.
  Lemma b2Zeqnb2Zp1_rw : ^b1 = - ^b2 + 1 <-> b1 = negb b2. Proof. !!. Qed.
  Lemma b2Zeqnb2Zp1s_rw : - ^b2 + 1 = ^b1 <-> b1 = negb b2. Proof. !!. Qed.

End B2Z_Rewrites.

Hint Rewrite
     b2Zt_rw b2Zf_rw b2Z_negb_rw
  : b2Z_term_rws simp_rws term_rws bang_rws.

Hint Rewrite
     b2Z_inj_rw b2Zeq1l_rw b2Zeq1r_rw b2Zeq0l_rw b2Zeq0r_rw
     b2Zeq1mb2Z_rw b2Zeq1mb2Zs_rw b2Zeqnb2Zp1_rw b2Zeqnb2Zp1s_rw
  : b2Z_eq_rws eq_rws.

Hint Rewrite <- b2Z_inj_rw : simp_rws.

Section Eb2Z_Rewrites.
  Variables b b1 b2 : EB.

  Tactic Notation "!!" :=
    clear; unerase; autorewrite with b2Z_term_rws b2Z_eq_rws; tauto.
  Open Scope E_scope.
  (*Eb2Z term rewrites*)
  Lemma Eb2Zt_rw : ^#true = #1. Proof. !!. Qed.
  Lemma Eb2Zf_rw : ^#false = #0. Proof. !!. Qed.
  Lemma Eb2Z_negb_rw : ^(Enegb b) = #1 - ^b. Proof. !!. Qed.

  (*Eb2Z equality rewrites*)
  Lemma Eb2Z_inj_rw : ^b1 = ^b2 <-> b1 = b2. Proof. !!. Qed.
  Lemma Eb2Zeq1l_rw : ^b = #1 <-> b = #true. Proof. !!. Qed.
  Lemma Eb2Zeq1r_rw : #1 = ^b <-> b = #true. Proof. !!. Qed.
  Lemma Eb2Zeq0l_rw : ^b = #0 <-> b = #false. Proof. !!. Qed.
  Lemma Eb2Zeq0r_rw : #0 = ^b <-> b = #false. Proof. !!. Qed.
  Lemma Eb2Zeq1mb2Z_rw : ^b1 = #1 - ^b2 <-> b1 = Enegb b2. Proof. !!. Qed.
  Lemma Eb2Zeq1mb2Zs_rw : #1 - ^b2 = ^b1 <-> b1 = Enegb b2. Proof. !!. Qed.
  Lemma Eb2Zeqnb2Zp1_rw :
    ^b1 = - ^b2 + #1 <-> b1 = Enegb b2. Proof. !!. Qed.
  Lemma Eb2Zeqnb2Zp1s_rw :
    - ^b2 + #1 = ^b1 <-> b1 = Enegb b2. Proof. !!. Qed.

End Eb2Z_Rewrites.

Hint Rewrite Eb2Zt_rw Eb2Zf_rw Eb2Z_negb_rw
  : Eb2Z_term_rws simp_rws term_rws.

Hint Rewrite
     Eb2Z_inj_rw Eb2Zeq1l_rw Eb2Zeq1r_rw Eb2Zeq0l_rw Eb2Zeq0r_rw
     Eb2Zeq1mb2Z_rw Eb2Zeq1mb2Zs_rw Eb2Zeqnb2Zp1_rw Eb2Zeqnb2Zp1s_rw
  : Eb2Z_eq_rws eq_rws.

Hint Rewrite <- Eb2Z_inj_rw : simp_rws.

Section Z_LHSify_Rewrites.
  Variables x y z : Z.

  Tactic Notation "!!" := lia.

  Lemma zlhs_rw : x = y <-> x - y = 0. Proof. !!. Qed.
  Lemma zadd1_lhs_rw : x + y = z <-> x = z - y. Proof. !!. Qed.
  Lemma zadd2_lhs_rw : x + y = z <-> y = z - x. Proof. !!. Qed.
  Lemma zsub1_lhs_rw : x - y = z <-> x = z + y. Proof. !!. Qed.
  Lemma zsub2_lhs_rw : x - y = z <-> y = x - z. Proof. !!. Qed.
  Lemma zopp_lhs_rw : -x = y <-> x = -y. Proof. !!. Qed.

  Lemma ziso1_rw : y = 0 <-> x = x + y. Proof. !!. Qed.
  Lemma ziso2_rw : y = 0 <-> x = x - y. Proof. !!. Qed.

End Z_LHSify_Rewrites.

Section EZ_LHSify_Rewrites.
  Variables x y z : EZ.

  Tactic Notation "!!" := clear; unerase; lia.
  Open Scope E_scope.
  Lemma Ezlhs_rw : x = y <-> x - y = #0. Proof. !!. Qed.
  Lemma Ezadd1_lhs_rw : x + y = z <-> x = z - y. Proof. !!. Qed.
  Lemma Ezadd2_lhs_rw : x + y = z <-> y = z - x. Proof. !!. Qed.
  Lemma Ezsub1_lhs_rw : x - y = z <-> x = z + y. Proof. !!. Qed.
  Lemma Ezsub2_lhs_rw : x - y = z <-> y = x - z. Proof. !!. Qed.
  Lemma Ezopp_lhs_rw : - x = y <-> x = - y. Proof. !!. Qed.

  Lemma Eziso1_rw : y = #0 <-> x = x + y. Proof. !!. Qed.
  Lemma Eziso2_rw : y = #0 <-> x = x - y. Proof. !!. Qed.

End EZ_LHSify_Rewrites.

Lemma ezring_theory :
  ring_theory (R:=EZ) #0 #1 ezadd ezmul ezsub ezopp eq.
Proof.
  constructor.
  all: intros; unerase; ring.
Qed.

Ltac ezconst term :=
  match term with
  | # ?x => Zcst x
  | _ => InitialRing.NotConstant
  end.

Ltac EZring_preprocess :=
  autorewrite with term_rws;
  autorewrite with ensharping_rws.

Ltac EZring_postprocess :=
  idtac.

Add Ring ezring :
  ezring_theory (abstract,
                 (*cannot be decidable, because no equality function is: EZ -> EZ -> bool*)
                 constants [ezconst],
                 preprocess [EZring_preprocess],
                 postprocess [EZring_postprocess]
                ).

Ltac safe_ring_simplify_in H :=
  factor_evars H;
  try ring_simplify in H;
  defactor_all_evars.

Ltac safe_ring_simplify :=
  factor_conc_evars;
  try ring_simplify;
  defactor_all_evars.

Ltac rsimp_term T :=
  lazymatch T with
  | ?F ?A => rsimp_fun F A
  | ?A -> ?C => rsimp_term A; rsimp_term C
  | _ => idtac
  end
with rsimp_fun F A :=
  let T:=constr:(F A) in
  let tT:=type of T in
  tryif first [constr_eq tT Z|constr_eq tT (##Z)]
  then let e:=fresh in
       let ee:=fresh in
       remember T as e eqn:ee in *;
       (*safe_ring_simplify_in ee;*) try ring_simplify in ee;
       (*do not use subst e - it causes problems*)
       rewrite ?ee in *; clear e ee
  else (rsimp_term F; rsimp_term A).

Ltac rsimp_in H :=
  try rewrite Ezlhs_rw in H;
  try rewrite zlhs_rw in H;
  autorewrite with ensharping_rws in H;
  autorewrite with term_rws in H;
  let T:=type of H in rsimp_term T.

Ltac rsimp_conc :=
  try rewrite Ezlhs_rw;
  try rewrite zlhs_rw;
  autorewrite with ensharping_rws;
  autorewrite with term_rws;
  try ring_simplify.
  (* lazymatch goal with *)
  (* | |- ?G => rsimp_term G *)
  (* end. *)

Ltac try_rsimp_in H := let T := type of H in rsimp_term T.

Ltac rsimp :=
  autorewrite with b2Z_term_rws in *;
  try ring_simplify;
  allhyps_reverting try_rsimp_in.

(************************************************************************)

Hint Rewrite <- b2Z_inj_rw : bang_rws.

Ltac bang_setup_tactic := idtac. (*to be redefined*)

Ltac pose_b2Zbounds :=
  let f H := try generalize (b2Zbounds H) in
  allhyps_reverting_stop f;
  pose proof (b2Zbounds true);
  pose proof (b2Zbounds false).

Ltac bang_internal setup :=
  dintros;
  unsetall;
  try tauto;
  first[check_in_prop|exfalso];
  setup;
  unerase;
  autorewrite with bang_rws in *;
  pose_b2Zbounds;
  (lia ||
   lazymatch goal with
   | |- _ /\ _ => deconj; first[congruence|lia]
   | _ => congruence
   end).

Ltac bang := bang_internal bang_setup_tactic.
Ltac bang0 := bang_internal idtac.

Ltac clear_evars :=
  (*assumes all evars are factored*)
  repeat match goal with
         | H := ?V |- _ => is_evar V; clearbody H
         end.

Ltac hyps_have_evars :=
  (*assumes all evars are factored*)
  match goal with
    H := ?V |- _ =>
    is_evar V;
    lazymatch goal with
    | _ : context[H] |- _ => idtac
    | _ := context[H] |- _ => idtac
    end
  end.

Ltac nbang :=
  (*assumes all evars are factored*)
  intros;
  tryif hyps_have_evars then idtac
  else
  lazymatch goal with
    |- ?G =>
    tryif (let x := constr:((ltac:(intros; clear_evars; bang)):(G -> False)) in idtac)
    then fail
    else idtac
  end.

Ltac check_cycle V Sub :=
  lazymatch Sub with context[V] => fail | _ => idtac end.

Ltac notin_conc_rhs E :=
  lazymatch goal with
  | |- _ = ?R => check_cycle E R
  | |- ?G => fail 99 "notin_conc_rhs when conc is " G
  end.

(* TBD: can we speed up the inst funs by using a bool xor fun to
combine b/negb b by delaying the sign?
 *)

Ltac unify_evar E V :=
  (*instantiate (1:=V) in (Value of E).*)
  let Ee := get_value E in
  is_evar Ee;
  tryif constr_eq Ee V
  then fail
  else unify Ee V.

Ltac inst_bool E :=
  ((multimatch goal with
     | b := ?V : bool |- _ =>
       is_evar V;
       (unify_evar E (V) +
        unify_evar E (negb V))
     end) +
   (unify_evar E (true)) +
   (unify_evar E (false)) +
   (multimatch goal with
     | b : bool |- _ =>
       tryif has_value b
       then fail
       else (unify_evar E (b) +
             unify_evar E (negb b))
     end));
  unfold E in *; clear E.

Ltac inst_EB E :=
  ((multimatch goal with
     | b := ?V : EB |- _ =>
       is_evar V;
       (unify_evar E (V) +
        unify_evar E (Enegb V))
     | b := ?V : bool |- _ =>
       is_evar V;
       (unify_evar E (#V) +
        unify_evar E (Enegb #V))
     end) +
   (unify_evar E (#true)) +
   (unify_evar E (#false)) +
   (multimatch goal with
     | b : EB |- _ =>
       tryif has_value b
       then fail
       else (unify_evar E (b) +
             unify_evar E (Enegb b))
     | b : bool |- _ =>
       tryif has_value b
       then fail
       else (unify_evar E (#b) +
             unify_evar E (Enegb #b))
     end));
  unfold E in *; clear E.

Ltac unify_booleq E :=
  first [rewrite (Eziso1_rw (Eb2Z #E));
          ring_simplify; notin_conc_rhs E
        |rewrite (Eziso2_rw (Eb2Z #E));
          ring_simplify; notin_conc_rhs E];
  autorewrite with Eb2Z_eq_rws;
  autorewrite with desharping_rws;
  defactor_all_evars;
  reflexivity.

Ltac unify_EBeq E :=
  first [rewrite (Eziso1_rw (Eb2Z E));
          ring_simplify; notin_conc_rhs E
        |rewrite (Eziso2_rw (Eb2Z E));
          ring_simplify; notin_conc_rhs E];
  autorewrite with Eb2Z_eq_rws;
  defactor_all_evars;
  reflexivity.

Ltac unify_Zeq E :=
  first[rewrite (Eziso1_rw #E);
         ring_simplify; notin_conc_rhs E
       |rewrite (Eziso2_rw #E);
        ring_simplify; notin_conc_rhs E];
  autorewrite with desharping_rws;
  defactor_all_evars;
  reflexivity.

Ltac unify_EZeq E :=
  first[rewrite (Eziso1_rw E);
         ring_simplify; notin_conc_rhs E
       |rewrite (Eziso2_rw E);
         ring_simplify; notin_conc_rhs E];
  defactor_all_evars;
  reflexivity.

Ltac boom_internal doinsts :=
  dintros;
  defactor_all_evars;
  lazymatch goal with
  | |- (@eq EB _ _) => try reflexivity; rewrite <-Eb2Z_inj_rw
  | _ => idtac
  end;
  rsimp_conc;
  try simple_reflex;
  factor_all_evars;
  match goal with
  | [E := ?V : Z |- (@eq EZ _ _)] => is_evar V; unify_Zeq E
  | [E := ?V : EZ |- (@eq EZ _ _)] => is_evar V; unify_EZeq E
  | [E := ?V : EB |- (@eq EZ _ _)] => is_evar V; unify_EBeq E
  | [E := ?V : bool |- (@eq EZ _ _)] => is_evar V; unify_booleq E
  | _ =>  try bang
  end;
  match goal with
  | [E := ?V : EB |- _] => is_evar V
  | [E := ?V : bool |- _] => is_evar V
  end;
  check_in_prop;
  lazymatch doinsts with
  | 0 => idtac
  | false => fail "boom prevented from trying bool/EB instantiations"
  | true => nbang
  | I => shelve
  end;
  (*TBD - the following multimatch does too much, in that it tries all
    permutations of instantiations instead of just all combinations.*)
  multimatch goal with
  | [E := ?V : EB |- _] => is_evar V; inst_EB E; boom_internal 0
  | [E := ?V : bool |- _] => is_evar V; inst_bool E; boom_internal 0
  end.

Ltac boom := boom_internal 0.


Set Warnings "-notation-overridden".

Require Import Coq.Program.Basics.

From Equations Require Import Equations.
Unset Equations With Funext.

Require Import Category.Lib.
Require Import Category.Theory.

Require Import Embed.Theory.Btree.
Require Import Embed.Theory.Lattice.

Generalizable All Variables.
Set Universe Polymorphism.
Set Nested Proofs Allowed.

Notation "btree!" := (@btree ()) (only parsing, at level 0).
Notation "bnil!" := (@bnil () tt) (only parsing, at level 0).
Notation "btree2!" := (@btree () * @btree ()) (only parsing, at level 0).

Equations and_btree : magma btree! :=
and_btree (bnil _) (bnil _) := bnil () ;
and_btree (bnil _) (bcons _ _) := bnil () ;
and_btree (bcons _ _) (bnil x) := bnil () ;
and_btree (bcons x y) (bcons z w) := bcons (and_btree x z) (and_btree y w).
Global Transparent and_btree.

Global Program Instance and_btree_Idempotent : Idempotent and_btree :=
  { idempotency := _ }.
Next Obligation.
revert x.
fix H 1.
intro.
destruct x.

rewrite and_btree_equation_1.
destruct u.
reflexivity.

rewrite and_btree_equation_4.
refine (bcons_eq _ _).

exact (@idempotency _ _ H _).

exact (@idempotency _ _ H _).
Defined.

Program Instance and_btree_Commutative : Commutative and_btree :=
  { commutativity := _ }.
Next Obligation.
revert b. revert a.
fix and_btree_Commutative 2.
intros.
destruct a, b.

reflexivity.

reflexivity.

reflexivity.

exact (bcons_eq (and_btree_Commutative _ _) (and_btree_Commutative _ _)).
Defined.

Fixpoint and_btree_associative (a b c : btree!) :
  and_btree (and_btree a b) c = and_btree a (and_btree b c).
destruct a, b, c.

reflexivity.

reflexivity.

reflexivity.

reflexivity.

reflexivity.

reflexivity.

reflexivity.

unfold and_btree.
refine (bcons_eq _ _).

exact (and_btree_associative _ _ _).

exact (and_btree_associative _ _ _).
Defined.

(* Fails with fix *)
Program Instance and_btree_Associative : Associative and_btree :=
  { associativity := and_btree_associative }.

Equations or_btree : magma btree! :=
or_btree (bnil _) (bnil _) := bnil tt ;
or_btree (bcons x y) (bnil _) := bcons x y ;
or_btree (bnil _) (bcons x y) := bcons x y ;
or_btree (bcons x y) (bcons z w) := bcons (or_btree x z) (or_btree y w).
Global Transparent or_btree.

(* Almost the same proof as for and_btree *)
Program Instance or_btree_Idempotent : Idempotent or_btree :=
  { idempotency := _ }.
Next Obligation.
revert x.
fix H 1.
intro.
destruct x.

rewrite or_btree_equation_1.
destruct u.
reflexivity.

rewrite or_btree_equation_4.
refine (bcons_eq _ _).

exact (@idempotency _ _ H _).

exact (@idempotency _ _ H _).
Defined.

(* Almost the same proof as for and_btree *)
Program Instance or_btree_Commutative : Commutative or_btree :=
  { commutativity := _ }.
Next Obligation.
revert b. revert a.
fix or_btree_Commutative 2.
intros.
destruct a, b.

reflexivity.

reflexivity.

reflexivity.

exact (bcons_eq (or_btree_Commutative _ _) (or_btree_Commutative _ _)).
Defined.

(* Almost the same proof as for and_btree *)
Fixpoint or_btree_associative (a b c : btree!) :
  or_btree (or_btree a b) c = or_btree a (or_btree b c).
destruct a, b, c.

reflexivity.

reflexivity.

reflexivity.

reflexivity.

reflexivity.

reflexivity.

reflexivity.

unfold or_btree.
refine (bcons_eq _ _).

exact (or_btree_associative _ _ _).

exact (or_btree_associative _ _ _).
Defined.

Program Instance or_btree_Associative : Associative or_btree :=
  { associativity := or_btree_associative }.

Fixpoint and_or_absorptive (a b : btree!) :
  and_btree a (or_btree a b) = a.
destruct a, b.

unfold or_btree.
unfold and_btree.
destruct u.
reflexivity.

unfold or_btree.
unfold and_btree.
destruct u.
reflexivity.

unfold or_btree.
unfold and_btree.
refine (bcons_eq _ _).

exact (@idempotency _ _ and_btree_Idempotent _).

exact (@idempotency _ _ and_btree_Idempotent _).

unfold or_btree.
unfold and_btree.
refine (bcons_eq _ _).

exact (and_or_absorptive a1 b1).

exact (and_or_absorptive a2 b2).
Defined.

(* May not need Fixpoint, but doesn't allow funelim *)
Program Instance and_or_Absorptive :
  Absorptive and_btree or_btree := { absorptivity := and_or_absorptive }.

(* Almost the same proof as for and_or_absorptive *)
Fixpoint or_and_absorptive (a b : btree!) :
  or_btree a (and_btree a b) = a.
destruct a, b.

unfold or_btree.
unfold and_btree.
destruct u.
reflexivity.

unfold or_btree.
unfold and_btree.
destruct u.
reflexivity.

unfold or_btree.
unfold and_btree.
refine (bcons_eq _ _).

reflexivity.

reflexivity.

rewrite and_btree_equation_4.
rewrite or_btree_equation_4.
refine (bcons_eq _ _).

exact (or_and_absorptive a1 b1).

exact (or_and_absorptive a2 b2).
Defined.

Program Instance or_and_Absorptive :
  Absorptive or_btree and_btree := { absorptivity := or_and_absorptive }.

Program Instance btree_unit_Lattice : Lattice btree := {
  lmeet := and_btree;
  ljoin := or_btree;

  lmeet_commutative := and_btree_Commutative;
  lmeet_associative := and_btree_Associative;
  lmeet_absorptive  := and_or_Absorptive;
  lmeet_idempotent  := and_btree_Idempotent;

  ljoin_commutative := or_btree_Commutative;
  ljoin_associative := or_btree_Associative;
  ljoin_absorptive  := or_and_Absorptive;
  ljoin_idempotent  := or_btree_Idempotent
}.

Fixpoint and_or_distributive (a b c : btree!) :
  and_btree a (or_btree b c) = or_btree (and_btree a b) (and_btree a c).
destruct a, b, c.

unfold or_btree.
unfold and_btree.
reflexivity.

unfold or_btree.
unfold and_btree.
reflexivity.

unfold or_btree.
unfold and_btree.
reflexivity.

unfold or_btree.
unfold and_btree.
reflexivity.

unfold or_btree.
unfold and_btree.
reflexivity.

unfold or_btree.
unfold and_btree.
reflexivity.

unfold or_btree.
unfold and_btree.
reflexivity.

unfold or_btree.
unfold and_btree.
refine (bcons_eq _ _).

exact (and_or_distributive _ _ _).

exact (and_or_distributive _ _ _).
Defined.

Program Instance and_or_Distributive :
  Distributive and_btree or_btree := { distributivity := and_or_distributive }.

Obligations.


(***************************************************************************
* Safety for Simply Typed Lambda Calculus (CBV) - Proofs                   *
* Brian Aydemir & Arthur Charguéraud, July 2007                            *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN
  STLC_Core_Definitions
  STLC_Core_Infrastructure.

(* ********************************************************************** *)
(** * Proofs *)

(** Typing is preserved by weakening. *)

Require Import Coq.Program.Equality.

Lemma typing_weaken : forall G E F t T,
   (E & G) |= t ~: T ->
   ok (E & F & G) ->
   (E & F & G) |= t ~: T.
Proof.
  introv Typ. inductions Typ; introv Ok.
  apply* typing_var. apply* binds_weaken.
  apply_fresh* typing_abs. apply_ih_bind* H0.
  apply* typing_app.
Qed.

(** Typing is preserved by substitution. *)

Lemma typing_subst : forall F U E t T z u,
  (E & z ~ U & F) |= t ~: T ->
  E |= u ~: U ->
  (E & F) |= [z ~> u]t ~: T.
Proof.
  introv Typt Typu. inductions Typt; introv; simpl.
  case_var.
    binds_mid~. apply_empty* typing_weaken.
    apply~ typing_var. apply* binds_subst.
  apply_fresh typing_abs.
   rewrite* subst_open_var.
   apply_ih_bind* H0.
  apply* typing_app.
Qed.

(** Preservation (typing is preserved by reduction). *)

Lemma preservation_result : preservation.
Proof.
  introv Typ. gen t'. inductions Typ; introv Red; inversions Red.
  inversions Typ1. pick_fresh x. rewrite* (@subst_intro x).
   apply_empty* typing_subst.
  apply* typing_app.
  apply* typing_app.
Qed.

(** Progress (a well-typed term is either a value or it can
  take a step of reduction). *)

Lemma progress_result : progress.
Proof.
  introv Typ. lets Typ': Typ. inductions Typ.
  false* binds_empty_inv.
  left*.
  right. destruct~ IHTyp1 as [Val1 | [t1' Red1]].
    destruct~ IHTyp2 as [Val2 | [t2' Red2]].
      inversions Typ1; inversions Val1. exists* (t0 ^^ t2).
      exists* (trm_app t1 t2').
    exists* (trm_app t1' t2).
Qed.