Require Export Util.

(*-----  Abstract Data Type  -----*)

(*  DType Type  *)

Module Type DTYPE.

Parameter name : Set.
Parameter rtype : Set.
Parameter dtype : Type.
Parameter init_dtype : dtype.

Parameter beq : dtype -> dtype -> bool.
Parameter peq : dtype -> dtype -> Prop.
Parameter get_dtype : name -> dtype -> option rtype.
Parameter update_dtype : name -> rtype -> dtype -> dtype.

Axiom equal_1 : forall x y: dtype, beq x y = true <-> peq x y.

Axiom beq_refl : forall x : dtype, beq x x = true.
Axiom beq_sym : forall x y : dtype, beq x y = true <-> beq y x = true.
Axiom beq_trans : forall x y z : dtype, beq x y = true -> beq y z = true -> beq x z = true.

Axiom eq_refl : forall x : dtype, peq x x.
Axiom eq_sym : forall x y : dtype, peq x y -> peq y x.
Axiom eq_trans : forall x y z : dtype, peq x y -> peq y z -> peq x z.

End DTYPE.

(*  Stack Type  *)

Module Type STACK.

Parameter name : Set.
Parameter ref : Set.
Parameter rtype : Set.
Parameter super_env : Type.
Parameter dtype : Type.

Parameter stack : Type.
Parameter init_stack : stack.

Parameter pin : name -> ref -> stack -> Prop.
Parameter beq : stack -> stack -> bool.
Parameter peq : stack -> stack -> Prop.
Parameter get : name -> stack -> option ref.
Parameter update : name -> ref -> stack -> stack.
Parameter update_null : name -> stack -> stack.

Parameter well_formed : super_env -> stack -> dtype -> Prop.

Axiom beq_refl : forall x : stack, beq x x = true.
Axiom beq_sym : forall x y : stack, beq x y = true <-> beq y x = true.
Axiom beq_trans : forall x y z : stack, beq x y = true -> beq y z = true -> beq x z = true.

Axiom eq_refl : forall x : stack, peq x x.
Axiom eq_sym : forall x y : stack, peq x y -> peq y x.
Axiom eq_trans : forall x y z : stack, peq x y -> peq y z -> peq x z.

Axiom in_update_1 : forall n r s, pin n r (update n r s).
Axiom in_update_2 : forall n1 n2 r1 r2 s,
    n1 <> n2 -> pin n1 r1 s -> pin n1 r1 (update n2 r2 s).
Axiom in_update_3 : forall n1 n2 r1 r2 s,
    n1 <> n2 -> pin n1 r1 (update n2 r2 s) -> pin n1 r1 s.
Axiom in_get : forall n r s, pin n r s <-> get n s = Some r.
Axiom not_in_get : forall n s, (forall r, ~ pin n r s) <-> get n s = None.

End STACK.

(*-----  Data  -----*)

Open Scope string_scope.

(*  DType  *)

Module DType <: DTYPE.

Definition name := Name.name.
Definition rtype := RType.rtype.
Definition dtype := Smap.t rtype.
Definition empty_dtype := Smap.empty rtype.
Definition init_dtype :=
    Smap.add "this" "Object"
    (Smap.add "res" "Object"
    (Smap.add "true" "Bool"
    (Smap.add "false" "Bool"
    (Smap.add "null" "Null" empty_dtype)))).

Definition beq (d1 d2 : dtype) : bool :=
    Smap.equal RType.beq d1 d2.

Definition peq (d1 d2 : dtype) : Prop :=
    Smap.Equivb RType.beq d1 d2.

Definition get_dtype (n : name) (d : dtype) : option rtype :=
    Smap.find n d.

Definition update_dtype (n : name) (t : rtype) (d : dtype) : dtype :=
    Smap.add n t d.

Lemma equal_1 : forall x y: dtype, beq x y = true <-> peq x y.
Proof.
  unfold beq. unfold peq.
  intros x y. split.
  apply Smap.equal_2.
  apply Smap.equal_1.
Qed.

Lemma beq_refl : forall x : dtype, beq x x = true.
Proof.
  unfold beq. intro.
  apply smap_refl_2. apply RType.beq_refl.
Qed.
Lemma beq_sym : forall x y : dtype, beq x y = true <-> beq y x = true.
Proof.
  unfold beq. intros. split.
  apply smap_sym_2. apply RType.beq_sym.
  apply smap_sym_2. apply RType.beq_sym.
Qed.
Lemma beq_trans : forall x y z : dtype, beq x y = true -> beq y z = true -> beq x z = true.
Proof.
  unfold beq. intros x y z.
  apply smap_trans_2. apply RType.beq_trans.
Qed.

Lemma eq_refl : forall x : dtype, peq x x.
Proof.
  intro x. apply equal_1.
  apply beq_refl.
Qed.
Lemma eq_sym : forall x y : dtype, peq x y -> peq y x.
Proof.
  intros x y H. apply equal_1.
  apply equal_1 in H.
  apply beq_sym. assumption.
Qed.
Lemma eq_trans : forall x y z : dtype, peq x y -> peq y z -> peq x z.
Proof.
  intros x y z H H0.
  apply equal_1.
  apply equal_1 in H.
  apply equal_1 in H0.
  apply beq_trans with (y := y).
  assumption. assumption.
Qed.

End DType.

(*  Stack  *)

Module Stack <: STACK.

Definition name := Name.name.
Definition ref := Ref.ref.
Definition rtype := RType.rtype.
Definition super_env := RType.super_env.
Definition dtype := DType.dtype.

Definition stack := Smap.t ref.
Definition empty_stack := Smap.empty ref.
Definition init_stack :=
    Smap.add "this" Ref.rnull
    (Smap.add "res" Ref.rnull
    (Smap.add "true" Ref.rtrue
    (Smap.add "false" Ref.rfalse
    (Smap.add "null" Ref.rnull empty_stack)))).

Definition pin (n : name) (r : ref) (s : stack) : Prop :=
    Smap.MapsTo n r s.

Definition beq (s1 s2 : stack) : bool :=
    Smap.equal Ref.beq s1 s2.

Definition peq (s1 s2 : stack) : Prop :=
    forall n r, pin n r s1 <-> pin n r s2.

Definition get (n : name) (s : stack) : option ref :=
    Smap.find n s.

Definition update (n : name) (r : ref) (s : stack) : stack :=
    Smap.add n r s.

Definition update_null (n : name) (s : stack) : stack :=
    Smap.add n Ref.rnull s.

Definition check_type (se : super_env) (d : dtype) (n : name) (r : ref) (p : Prop) : Prop :=
    match Smap.find n d with
        | None => False
        | Some t => RType.subtype (Ref.get_type r) t se /\ p
    end.
Definition well_formed (se : super_env) (s : stack) (d : dtype) : Prop :=
    Smap.fold (check_type se d) s True.

Lemma equal_1 : forall s1 s2 : stack, peq s1 s2 -> beq s1 s2 = true.
Proof.
  unfold peq. unfold beq.
  intros s1 s2 H. apply Smap.equal_1.
  unfold Smap.Equivb.
  unfold Smap.Raw.Equivb.
  split. intro k. split.
  unfold Smap.Raw.PX.In.
  intro H0. destruct H0.
  apply H in H0. exists x.
  assumption.
  unfold Smap.Raw.PX.In.
  intro H0. destruct H0.
  apply H in H0. exists x.
  assumption.
  intros k e e' H0 H1.
  apply Ref.equal_1.
  apply Ref.equal_2.
  apply smap_inject with (k := k) (m := s2).
  apply H in H0. assumption. assumption.
Qed.
Lemma equal_2 : forall s1 s2 : stack, beq s1 s2 = true -> peq s1 s2.
Proof.
  unfold peq. unfold beq.
  intros s1 s2 H n r.
  apply Smap.equal_2 in H.
  unfold Smap.Equivb in H.
  unfold Smap.Raw.Equivb in H.
  destruct H. unfold Smap.Raw.PX.In in H.
  destruct H with (k := n).
  split. unfold pin. intro H3.
  assert (exists e, Smap.Raw.PX.MapsTo n e (Smap.this s1)).
  exists r; assumption.
  apply H1 in H4.
  clear H1; clear H2.
  destruct H4.
  assert (Ref.beq r x = true).
  apply H0 with (k := n).
  assumption. assumption.
  apply Ref.equal_1 in H2.
  apply Ref.equal_2 in H2.
  rewrite H2. assumption.
  unfold pin. intro H3.
  assert (exists e, Smap.Raw.PX.MapsTo n e (Smap.this s2)).
  exists r; assumption.
  apply H2 in H4.
  clear H1; clear H2.
  destruct H4.
  assert (Ref.beq x r = true).
  apply H0 with (k := n).
  assumption. assumption.
  apply Ref.equal_1 in H2.
  apply Ref.equal_2 in H2.
  rewrite <- H2. assumption.
Qed.
Axiom equal_3 : forall s1 s2 : stack, s1 = s2 <-> peq s1 s2.

Lemma beq_refl : forall x : stack, beq x x = true.
Proof.
  unfold beq. intro.
  apply smap_refl_2. apply Ref.beq_refl.
Qed.
Lemma beq_sym : forall x y : stack, beq x y = true <-> beq y x = true.
Proof.
  unfold beq. intros. split.
  apply smap_sym_2. apply Ref.beq_sym.
  apply smap_sym_2. apply Ref.beq_sym.
Qed.
Lemma beq_trans : forall x y z : stack, beq x y = true -> beq y z = true -> beq x z = true.
Proof.
  unfold beq. intros x y z.
  apply smap_trans_2. apply Ref.beq_trans.
Qed.

Lemma eq_refl : forall x : stack, peq x x.
Proof.
  unfold peq. intros; split.
  intro; assumption.
  intro; assumption.
Qed.
Lemma eq_sym : forall x y : stack, peq x y -> peq y x.
Proof.
  unfold peq. intros; split.
  apply H. apply H.
Qed.
Lemma eq_trans : forall x y z : stack, peq x y -> peq y z -> peq x z.
Proof.
  unfold peq. intros; split.
  intro; apply H0; apply H; assumption.
  intro; apply H; apply H0; assumption.
Qed.

Lemma in_update_1 : forall n r s, pin n r (update n r s).
Proof.
  intros n r s. unfold update.
  apply Smap.add_1; reflexivity.
Qed.

Lemma in_update_2 : forall n1 n2 r1 r2 s,
    n1 <> n2 -> pin n1 r1 s -> pin n1 r1 (update n2 r2 s).
Proof.
  intros n1 n2 r1 r2 s H H0.
  unfold update. unfold pin in H0.
  apply Smap.add_2. auto.
  assumption.
Qed.

Lemma in_update_3 : forall n1 n2 r1 r2 s,
    n1 <> n2 -> pin n1 r1 (update n2 r2 s) -> pin n1 r1 s.
Proof.
  intros n1 n2 r1 r2 s H H0.
  unfold update in H0. unfold pin in H0.
  apply Smap.add_3 with (x := n2) (e' := r2). auto.
  assumption.
Qed.

Lemma in_get : forall n r s, pin n r s <-> get n s = Some r.
Proof.
  intros n r s.
  split. intro H.
  unfold pin in H.
  apply Smap.find_1 in H.
  unfold get. assumption.
  intro H. unfold get in H.
  apply Smap.find_2 in H.
  assumption.
Qed.

Lemma not_in_get : forall n s, (forall r, ~ pin n r s) <-> get n s = None.
Proof.
  intros n s. split. intro H.
  unfold pin in H. unfold get.
  inductS (Smap.find n s).
  apply Smap.find_2 in H0.
  elim H with (r := x). assumption. reflexivity.
  intros H r H0. unfold get in H.
  apply Smap.find_1 in H0. rewrite H0 in H.
  inversion H.
Qed.

End Stack.

Close Scope string_scope.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  The typing module.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.
Require Import Coq.Bool.Bool.

Require Export BoolEqualitySigDef.
Require Export TVarModuleDef.
Require Export KappaModuleDef.
Require Export PhiModuleDef.
Require Export CpdtTactics.
Require Export Case.
Require Export MoreTacticals.

Module TauModule <: BoolEqualitySig.
Module Base.
 Module TV  := TVarModule. (* So terms can expose it in language module. *)
 Module K := KappaModule.

 Include KappaModule.Base.
 Include PhiModule.

Inductive Tau : Type :=
 | tv_t   : TV.Var -> Tau                             (* A type variable is a type. *)
 | cint   : Tau                                      (* Cyclone's Integers. *)
 | cross  : Tau -> Tau -> Tau                        (* Pairs. *)
 | arrow  : Tau -> Tau -> Tau                        (* Function    type. *)
 | ptype  : Tau -> Tau                               (* Pointer     type. *)
 | utype  : TV.Var -> Kappa -> Tau -> Tau           (* Universal   type. *)
 | etype  : Phi -> TV.Var -> Kappa -> Tau -> Tau. (* Existential type. *)

Hint Resolve   beq_kappa_refl.
Hint Immediate beq_kappa_sym.
Hint Resolve   beq_kappa_trans.
Hint Resolve   beq_kappa_eq.
Hint Resolve   beq_kappa_neq.

Hint Resolve   beq_phi_refl.
Hint Immediate beq_phi_sym.
Hint Resolve   beq_phi_trans.
Hint Resolve   beq_phi_eq.
Hint Resolve   beq_phi_neq.

Function beq_tau (t t' : Tau) : bool :=
 match t, t' with
 | tv_t alpha, tv_t beta => TV.beq_t alpha beta
 | cint, cint => true
 | (cross t0 t1), (cross t0' t1') => andb (beq_tau t0 t0') (beq_tau t1 t1')
 | (arrow t0 t1), (arrow t0' t1') => andb (beq_tau t0 t0') (beq_tau t1 t1')
 | ptype t, ptype t' => (beq_tau t t')
(* No alpha conversion for the moment. *)
 | utype alpha kappa tau, utype alpha' kappa' tau' =>
   andb (andb (TV.beq_t alpha alpha') (beq_kappa kappa kappa'))
        (beq_tau tau tau')
 | etype p alpha kappa tau, etype p' alpha' kappa' tau' =>
   andb (andb (beq_phi p p')  (TV.beq_t alpha alpha'))
        (andb (beq_kappa kappa kappa') (beq_tau tau tau'))

 | _ , _ => false
end.
Hint Unfold beq_tau.
Hint Resolve beq_tau.

Lemma beq_tau_refl:
 forall (t : Tau),
   beq_tau t t = true.
Proof.
  intros.
  induction t; crush.
Qed.
Hint Resolve beq_tau_refl.

(* not quite sure why I have to change the proof structure here at all. *)
Lemma beq_tau_sym : forall x y, beq_tau x y = beq_tau y x.
Proof.
  induction x; induction y; auto.
  try solve [crush].
  try solve [crush].
  try solve [crush].
  try solve [crush].
  unfold beq_tau.
  fold beq_tau.
  rewrite TV.beq_t_sym.
  rewrite beq_kappa_sym.
  rewrite IHx.
  reflexivity.
  unfold beq_tau.
  fold beq_tau.
  rewrite TV.beq_t_sym.
  rewrite beq_phi_sym.
  rewrite beq_kappa_sym.
  rewrite IHx.
  reflexivity.
Qed.
Hint Immediate beq_tau_sym.

Lemma beq_tau_eq:
  forall t0 t1, beq_tau t0 t1 = true -> t0 = t1.
Proof.
  induction t0; induction t1; intros; try solve [inversion H].

  inversion H.
  apply TV.beq_t_eq in H1.
  rewrite H1.
  reflexivity.

  reflexivity.

  unfold beq_tau in H.
  fold beq_tau in H.
  apply andb_true_iff in H.
  inversion H.
  apply IHt0_1 in H0.
  apply IHt0_2 in H1.
  subst.
  reflexivity.

  unfold beq_tau in H.
  fold beq_tau in H.
  apply andb_true_iff in H.
  inversion H.
  apply IHt0_1 in H0.
  apply IHt0_2 in H1.
  subst.
  reflexivity.

  unfold beq_tau in H.
  fold beq_tau in H.
  apply IHt0 in H.
  rewrite H.
  reflexivity.

  unfold beq_tau in H.
  fold beq_tau in H.
  apply andb_true_iff in H.
  inversion H.
  apply andb_true_iff in H0.
  inversion H0.
  apply IHt0 in H1.
  apply TV.beq_t_eq in H2.
  apply beq_kappa_eq in H3.
  subst.
  reflexivity.

  unfold beq_tau in H.
  fold beq_tau in H.
  apply andb_true_iff in H.
  inversion H.
  apply andb_true_iff in H0.
  inversion H0.
  apply andb_true_iff in H1.
  inversion H1.
  apply IHt0 in H5.
  apply beq_phi_eq in H2.
  apply TV.beq_t_eq in H3.
  apply beq_kappa_eq in H4.
  subst.
  reflexivity.
Qed.
Hint Resolve beq_tau_eq.

Lemma beq_tau_neq:
  forall t0 t1, beq_tau t0 t1 = false -> t0 <> t1.
Proof.
  induction t0; induction t1; intros; try solve [inversion H]; try solve [discriminate].
  apply TV.beq_t_neq in H.
  crush.

  unfold beq_tau in H.
  fold beq_tau in H.
  apply andb_false_iff in H.
  destruct H.
  apply IHt0_1 in H.
  crush.
  apply IHt0_2 in H.
  crush.

  unfold beq_tau in H.
  fold beq_tau in H.
  apply andb_false_iff in H.
  destruct H.
  apply IHt0_1 in H.
  crush.
  apply IHt0_2 in H.
  crush.

  unfold beq_tau in H.
  fold beq_tau in H.
  apply IHt0 in H.
  crush.

  unfold beq_tau in H.
  fold beq_tau in H.
  apply andb_false_iff in H.
  destruct H.
  apply andb_false_iff in H.
  destruct H.
  apply TV.beq_t_neq in H.
  crush.
  apply beq_kappa_neq in H.
  crush.
  apply IHt0 in H.
  crush.

  unfold beq_tau in H.
  fold beq_tau in H.
  apply andb_false_iff in H.
  destruct H.
  apply andb_false_iff in H.
  destruct H.
  apply beq_phi_neq in H.
  crush.
  apply TV.beq_t_neq in H.
  crush.
  apply andb_false_iff in H.
  destruct H.
  apply beq_kappa_neq in H.
  crush.
  apply IHt0 in H.
  crush.
Qed.
Hint Resolve beq_tau_neq.

Ltac apply_beq_eqs :=
  repeat match goal with
    | [ I : beq_tau _ _ = true
        |- _ ] => apply beq_tau_eq in I; subst; try reflexivity
    | [ I : beq_phi _ _ = true
        |- _ ] => apply beq_phi_eq in I; subst; try reflexivity
    | [ I : beq_kappa _ _ = true
        |- _ ] => apply beq_kappa_eq in I; subst; try reflexivity
    | [ I : TV.beq_t _ _ = true
        |- _ ] => apply TV.beq_t_eq in I; subst; try reflexivity
end.

Lemma beq_tau_iff_eq:    forall a b, beq_tau a b = true <-> a = b.
Proof.
  destruct a; destruct b; try solve[crush];
  split;
  intros;
  unfold beq_tau in H;
  fold beq_tau in H;
  simplify_boolean_and_true;
  apply_beq_eqs;
  intros;
  inversion H;
  subst;
  apply beq_tau_refl.
Qed.
Hint Resolve beq_tau_iff_eq.

Ltac fold_n_neq :=
  repeat match goal with
    | [ I : beq_tau ?x ?y = false |- ?x <> ?y  ] =>
      fold beq_tau in I; unfold beq_tau in I; simplify_boolean_and_false
    | [ I : beq_tau ?x _ = false,
        IH: forall _, beq_tau ?x _ = false <-> ?x <> _
       |- _ <> _  ] =>
       apply IH in I; congruence
    | [ H : TV.beq_t _ _ = false |- _ ] =>
      apply TV.beq_t_neq in H; try congruence
    | [ H : beq_kappa _ _ = false |- _ ] =>
      apply beq_kappa_neq in H; try congruence
    | [ H : beq_phi _ _ = false |- _ ] =>
      apply beq_phi_neq in H; try congruence
end.

Lemma beq_tau_iff_neq:   forall a b, beq_tau a b = false <-> a <> b.
Proof.
  induction a; induction b; try split; try intros;
  try solve[congruence];
  try solve[simpl; reflexivity];  try solve[simpl in H; inversion H];
  try solve [unfold beq_tau in H;
             fold beq_tau in H;
             simplify_boolean_and_false;
             try apply beq_tau_neq in H;
             try apply beq_tau_neq in H0;
             congruence];
  try solve[unfold beq_tau in H;
            fold beq_tau in H;
            simplify_boolean_and_false;
            fold_n_neq;
            congruence].
Admitted.
Hint Resolve beq_tau_iff_neq.

Lemma beq_tau_trans:
  forall x y z,
    beq_tau x y = true -> beq_tau y z = true -> beq_tau x z = true.
Proof.
  intros.
  pose proof H as H'.
  pose proof H0 as H0'.
  apply beq_tau_eq in H.
  apply beq_tau_eq in H0.
  subst.
  assumption.
Qed.
Hint Resolve beq_tau_trans.

Function NotFreeInTau (beta : TV.Var) (tau : Tau) : Prop :=
  match tau with
    | tv_t alpha =>
      if TV.beq_t beta alpha then False else True
    | cint        => True
    | cross t0 t1 =>
       (NotFreeInTau beta t0) /\ (NotFreeInTau beta t1)
    | arrow t0 t1 =>
        (NotFreeInTau beta t0) /\ (NotFreeInTau beta t1)
    | ptype t     => NotFreeInTau beta t
    | utype alpha _ t =>
      if TV.beq_t beta alpha then True else NotFreeInTau beta t
    | etype _ alpha _ t =>
      if TV.beq_t beta alpha then True else NotFreeInTau beta t
  end.
End Base.
Include Base.

Definition T := Tau.
Definition beq_t := beq_tau.
Definition beq_t_refl := beq_tau_refl.
Definition beq_t_sym := beq_tau_sym.
Definition beq_t_trans := beq_tau_trans.
Definition beq_t_eq := beq_tau_eq.
Definition beq_t_neq := beq_tau_neq.
Definition beq_t_iff_eq := beq_tau_iff_eq.
Definition beq_t_iff_neq := beq_tau_iff_neq.
End TauModule.


(*
The purpose of this file is to check some proofs presented in a research paper
on unification in the context of Matching Logic.

The contents of this file:
1. The syntax of Matching Logic formulae (patterns): line 25
2. Substitution function and helper lemmas : line 73
3. Axiomatisation of Definedness, Totality, Membership, Equality: line 54
4. Axioms and rules of a sub-proof system of Matching Logic: line 152
5. Helper lemmas and theorems, intermediate results: line 194
6. The main paper proofs: line 659
*)

Require Import String.
Require Import List.
Require Import ZArith.
Import ListNotations.

Definition sort := string.
Inductive Symbol := symb : string -> list sort -> sort -> Symbol.
Variable s₁ : sort.
Variable s₂ : sort.

(* ML Pattern syntax *)
Inductive Pattern :=
| var : string -> Pattern
| symbol : Symbol -> list Pattern -> Pattern
| not : Pattern -> Pattern
| and : Pattern -> Pattern -> Pattern
| Exists : string -> Pattern -> Pattern.

Notation "¬ A" := (not A) (at level 80).
Notation "A ∧ B" := (and A B) (at level 81).

(* Other (allowed) syntactical connectives in ML are axiomatised. *)
Parameter or : Pattern -> Pattern -> Pattern.
Notation "A ∨ B" := (or A B) (at level 82).
Axiom or_and : forall A B, (A ∧ B) = ¬ (¬ A ∨ ¬ B).

Parameter implies : Pattern -> Pattern -> Pattern.
Notation "A → B" := (implies A B) (at level 84).
Axiom implies_or : forall A B, (A → B) = ¬ A ∨ B.

Parameter equiv : Pattern -> Pattern -> Pattern.
Notation "A ↔ B" := (equiv A B) (at level 83).
Axiom equivalence : forall A B, (A ↔ B) = ((A → B) ∧ (B → A)).

Parameter Top : Pattern.
Notation "⊤" := (Top).

(* Definedness, Totality, Membership, Equality are also axiomatised. *)
(* These axioms are in fact trivial lemma in our term pattern setting. *)
Parameter definedness : Pattern -> sort -> sort -> Pattern.
Notation "⌈ A ⌉ " := (definedness A s₁ s₂) (at level 90).

Definition totality (φ : Pattern) (s₁ s₂ : string) : Pattern :=  ¬ ⌈ ¬ φ ⌉.
Notation "⌊ A ⌋ " := (totality A s₁ s₂) (at level 90).

Definition equal (φ φ' : Pattern) : Pattern := ⌊ φ ↔ φ' ⌋.
Notation "A == B" := (equal A B) (at level 80).
Axiom equal_symmetry: forall A B, (A == B) = (B == A).
Axiom equal_equiv: forall φ φ', (φ ↔ φ') = (φ == φ').

Definition membership (φ φ' : Pattern) : Pattern := ⌈ φ ∧ φ' ⌉.
Notation "A ∈ B" := (membership A B) (at level 80).
Lemma membership_helper: forall A B, (⌈ A ∧ B ⌉) = (A ∈ B).
Proof. intros. unfold membership. reflexivity. Qed.

(* Substitution functions and helpers. *)
Fixpoint substitution' (h : nat) (φ' : Pattern) (x : string) (φ : Pattern) : Pattern :=
  match h with
  | O => φ
  | S m => match φ with
           | var y => if (string_dec x y) then φ' else φ
           | symbol σ args => (symbol σ (map (substitution' m  φ' x) args))
           | not ψ => not (substitution' m φ' x ψ)
           | and ψ ψ' => and (substitution' m  φ' x ψ) (substitution' m φ' x ψ')
           | Exists y ψ => if (string_dec x y)
                           then Exists y ψ
                           else Exists y (substitution' m φ' x ψ)
           end
  end.

Lemma subst_id': forall h φ x,
    substitution' h (var x) x φ = φ.
Proof.
  induction h; intros; simpl; try reflexivity.
  case φ; intros.
  - case_eq (string_dec x s); intros; simpl; try subst; trivial.
  - induction l; simpl; try reflexivity.
    inversion IHl. rewrite H0. rewrite H0.
    rewrite IHh. reflexivity.
  - rewrite IHh. reflexivity.
  - rewrite IHh, IHh. reflexivity.
  - case_eq (string_dec x s); intros; try rewrite IHh; reflexivity.
Qed.

Fixpoint max_list (l : list nat) :=
  match l with
  | nil => 0
  | cons x xs => let y := (max_list xs) in (if (leb x y) then y else x)
  end.

Fixpoint height (p : Pattern) :=
  match p with
  | var s => 1
  | symbol s ss => 1 + max_list (map height ss)
  | not s => 1 + (height s)
  | and a b => 1 + max_list (map height [a;b])
  | Exists y ψ => 1 + (height ψ)
  end.

Definition substitution (φ' : Pattern) (x : string) (φ : Pattern) : Pattern :=
  substitution' (height φ) φ' x φ.

Lemma subst_id: forall φ x, substitution (var x) x φ = φ.
Proof. unfold substitution. intros. apply subst_id'. Qed.

(* One-to-one conjunction for lists *)
Fixpoint list_conjunction (tᵢ tᵢ' : list Pattern) : option Pattern :=
  match tᵢ, tᵢ' with
  | [], [] => Some ⊤
  | _, []  => None
  | [], _  => None
  | t :: l, t' :: l' => match (list_conjunction l l') with
                          | None => None
                          | Some φ => Some ((t == t') ∧ φ)
                          end
  end.

Lemma list_conjunction_helper : forall tᵢ tᵢ',
    (length tᵢ) = (length tᵢ') ->
    exists ψ, (list_conjunction tᵢ tᵢ') = Some ψ.
Proof.
  induction tᵢ; intros.
  - exists ⊤.
    induction tᵢ'; simpl. reflexivity.
    simpl in H. inversion H.
  - induction tᵢ'; simpl in H. inversion H.
    inversion H. apply IHtᵢ in H1. destruct H1 as (ψ & H1).
    exists (a == a0 ∧ ψ).
    simpl. rewrite H1. reflexivity.
Qed.

(* ******************************************************************************* *)
(* Axioms and Rules of the ML proof system: only a subset of the rules of the      *)
(* ML proof system are used.                                                       *)
(* ******************************************************************************* *)
Inductive step (Γ : list Pattern) (φ : Pattern) : Prop :=
| premise : In φ Γ -> step Γ φ
| mp : forall φ', step Γ (φ' → φ) -> step Γ φ' -> step Γ φ.
Notation "A ⊢ B" := (step A B) (at level 85).

Axiom axiom₁ :
  forall Γ φ φ',
    Γ ⊢ (φ → (φ' → φ)).
Axiom axiom₂ :
  forall Γ φ φ' φ'',
    Γ ⊢ ((φ → (φ' → φ'')) → ((φ → φ') → (φ → φ''))) .
Axiom axiom₃ :
  forall Γ φ φ',
    Γ ⊢ (¬ φ → ¬ φ') → (φ' → φ).
Axiom equality_elimination:
  forall Γ φ φ₁ φ₂ x,
    Γ ⊢ ((φ₁ == φ₂) ∧ (substitution φ₁ x φ)) → (substitution φ₂ x φ).
Axiom eq_membership:
  forall Γ φ φ',
    Γ ⊢ (φ ∈ φ') == (φ == φ').
Axiom definedness_axiom :
  forall Γ φ,
    Γ ⊢ φ -> Γ ⊢ ⌈ φ ⌉.
Axiom totality_axiom :
  forall Γ φ,
    Γ ⊢ φ -> Γ ⊢ ⌊ φ ⌋.
Axiom injectivity:
  forall Γ f args args',
    exists ψ, Some ψ  = (list_conjunction args args') /\
      (Γ ⊢ ((f args) == (f args')) → ψ).
Axiom equal_refl: forall Γ φ,
    Γ ⊢ φ == φ.
(* ******************************************************************************* *)
(* End ML proof rules and axioms                                                   *)
(* ******************************************************************************* *)

(* ******************************************************************************* *)
(* Helper lemmas and theorems                                                      *)
(* ******************************************************************************* *)
Lemma conjunction_as_implication : forall Γ φ φ',
    Γ ⊢ ¬ (φ → ¬ φ') <-> Γ ⊢ φ ∧ φ'.
Proof.
  split; intros; rewrite implies_or, <- or_and in *; assumption.
Qed.

Lemma refl : forall Γ φ, Γ ⊢ φ → φ.
Proof.
  intros.

  assert (Γ ⊢ (φ → ((φ → φ) → φ)) → ((φ → (φ → φ)) → (φ → φ))).
  apply axiom₂.

  assert (Γ ⊢ (φ → ((φ → φ) → φ))).
  apply axiom₁.

  assert (Γ ⊢ ((φ → (φ → φ)) → (φ → φ))).
  apply mp with (φ' := (φ → ((φ → φ) → φ))); assumption.

  assert (Γ ⊢ (φ  → (φ → φ))).
  apply axiom₁.

  apply mp with (φ' := (φ  → (φ → φ))); assumption.
Qed.

Theorem transitivity : forall Γ φ φ' φ'',
    Γ ⊢ φ → φ' ->
    Γ ⊢ φ' → φ'' ->
    Γ ⊢ φ → φ''.
Proof.
  intros.

  assert (Γ ⊢ (φ' → φ'') → (φ → (φ' → φ''))).
  apply axiom₁.

  assert (Γ ⊢ (φ → (φ' → φ''))).
  apply mp with (φ' := φ' → φ''); assumption.

  assert (Γ ⊢ (φ → (φ' → φ'')) → ((φ → φ') → (φ → φ''))).
  apply axiom₂.

  assert (Γ ⊢ ((φ → φ') → (φ → φ''))).
  apply mp with (φ' := (φ → (φ' → φ''))); assumption.

  apply mp with (φ' := (φ → φ')); assumption.
Qed.

(* A particular instance of the deduction theorem for the (sub-)proof system of Matching Logic shown in this file. *)
Lemma DT₁ : forall Γ φ φ',
    φ :: Γ ⊢ φ' ->
    Γ ⊢ φ → φ'.
Proof.
  intros.
  induction H.
  - simpl in H. destruct H.
    + subst. apply refl.
    + assert (Γ ⊢ φ0 → (φ → φ0)).
      apply axiom₁.

      assert (Γ ⊢ φ0).
      apply premise. assumption.

      apply mp with (φ' := φ0); assumption.
  - assert (Γ ⊢ φ → (φ' → φ0) → ((φ → φ') → (φ → φ0))).
    apply axiom₂.

    assert (Γ ⊢ (φ → φ') → (φ → φ0)).
    apply mp with (φ' := φ → (φ' → φ0)); assumption.

    apply mp with (φ' := φ → φ'); assumption.
Qed.

Lemma DT₂ : forall Γ φ φ',
    Γ ⊢ φ → φ' ->
    φ :: Γ ⊢ φ'.
Proof.
  intros.

  assert (φ :: Γ ⊢ φ).
  apply premise. simpl. left. reflexivity.

  assert (φ :: Γ ⊢ φ → φ').
  induction H.
  - apply premise. simpl. right. assumption.
  - apply mp with (φ' := φ'0); assumption.
  - apply mp with (φ' := φ); assumption.
Qed.

Theorem DT : forall Γ φ φ',
    Γ ⊢ φ → φ' <-> φ :: Γ ⊢ φ'.
Proof.
  split; intros.
  apply DT₂; assumption.
  apply DT₁; assumption.
Qed.

Lemma negation_consequence : forall Γ φ φ',
    Γ ⊢ ¬ φ → (φ → φ').
Proof.
  intros.

  apply DT.

  assert ((¬ φ) :: Γ ⊢ ((¬ φ') → ¬ φ) → (φ → φ')).
  apply axiom₃.

  assert ((¬ φ) :: Γ ⊢ ¬ φ → ((¬ φ') → ¬ φ)).
  apply axiom₁.

  assert ((¬ φ) :: Γ ⊢ ¬ φ).
  apply premise. simpl. left. reflexivity.

  assert ((¬ φ) :: Γ ⊢ ((¬ φ') → ¬ φ)).
  apply mp with (φ' := ¬ φ) in H0; assumption.

  apply mp with (φ' := ¬ φ' → ¬ φ); assumption.
Qed.

Lemma double_negation_elimination : forall Γ φ,
    Γ ⊢ (¬ ¬ φ) → φ.
Proof.
  intros.

  apply DT.

  assert ((¬ ¬ φ) :: Γ ⊢ ¬ ¬ φ).
  apply premise. simpl. left. reflexivity.

  assert ((¬ ¬ φ) :: Γ ⊢ (¬ ¬ φ) → ((¬ ¬ ¬ ¬ φ) → (¬ ¬ φ))).
  apply axiom₁.

  assert ((¬ ¬ φ) :: Γ ⊢ (¬ ¬ ¬ ¬ φ) → (¬ ¬ φ)).
  apply mp with (φ' := (¬ ¬ φ)); assumption.

  assert ((¬ (¬ φ)) :: Γ ⊢ ((¬ ¬ ¬ ¬ φ) → ¬ (¬ φ)) → ((¬ φ) → (¬ ¬ ¬ φ))).
  apply axiom₃.

  assert ((¬ (¬ φ)) :: Γ ⊢ (¬ φ) → ¬ ¬ ¬ φ).
  apply mp with (φ' := (¬ ¬ ¬ ¬ φ) → ¬ (¬ φ)); assumption.

  assert ((¬ (¬ φ)) :: Γ ⊢ ((¬ φ) → ¬ (¬ (¬ φ))) → ((¬ ¬ φ) → φ)).
  apply axiom₃.

  assert ((¬ ¬ φ) :: Γ ⊢  ((¬ ¬ φ) → φ)).
  apply mp with (φ' := ((¬ φ) → ¬ (¬ (¬ φ)))); assumption.

  apply mp with (φ' := ¬ ¬ φ); assumption.
Qed.

Lemma negation_elimination : forall Γ φ,
    Γ ⊢ (¬ ¬ φ) -> Γ ⊢ φ.
Proof.
  intros.

  assert (Γ ⊢ (¬ ¬ φ) → φ).
  apply double_negation_elimination.

  apply mp with (φ' := (¬ ¬ φ)); assumption.
Qed.

Lemma hypotheses_collapse : forall Γ φ φ',
    φ :: φ :: Γ ⊢ φ' ->
    φ :: Γ ⊢ φ'.
Proof.
  intros.

  induction H.
  - simpl in H. destruct H as [H | [H | H]]; subst.
    apply premise. simpl. left. reflexivity.
    apply premise. simpl. left. reflexivity.
    apply premise. simpl. right. assumption.
  - apply mp with (φ' := φ'); assumption.
Qed.

Lemma double_negation_intro : forall Γ φ,
    Γ ⊢ φ → ¬ ¬ φ.
Proof.
  intros.

  assert (φ :: Γ ⊢ (φ → ((¬ ¬ ¬ φ) → φ))).
  apply axiom₁.

  assert (φ :: Γ ⊢ φ).
  apply premise. simpl. left. reflexivity.

  assert (φ :: Γ ⊢ (¬ ¬ ¬ φ) → φ).
  apply mp with (φ' := φ); assumption.

  assert (φ :: Γ ⊢ ¬ (¬ (¬ φ)) → ¬ φ).
  apply double_negation_elimination.

  assert (φ :: Γ ⊢ ((¬ ¬ ¬ φ) → ¬ φ) → (φ → (¬ ¬ φ))).
  apply axiom₃.

  assert (φ :: Γ ⊢ (φ → (¬ ¬ φ))).
  apply mp with (φ' := ¬ (¬ (¬ φ)) → ¬ φ); assumption.

  apply DT. rewrite DT in H4.
  apply hypotheses_collapse.
  assumption.
Qed.

Lemma negation_introduction : forall Γ φ,
    Γ ⊢ φ ->
    Γ ⊢ (¬ ¬ φ).
Proof.
  intros.

  assert (Γ ⊢ φ → ¬ ¬ φ).
  apply double_negation_intro.

  apply mp with (φ' := φ); assumption.
Qed.

Lemma implication_negation : forall Γ φ φ',
    Γ ⊢ (φ → φ') → ((¬ ¬ φ) → ¬ ¬ φ').
Proof.
  intros.

  apply DT.
  assert ((φ → φ') :: Γ ⊢ (¬ ¬ φ) → φ).
  apply double_negation_elimination.

  assert ((φ → φ') :: Γ ⊢ φ → φ').
  apply premise. simpl. left. reflexivity.

  assert ((φ → φ') :: Γ ⊢ ¬ (¬ φ) → φ').
  apply transitivity with (φ' := φ); assumption.

  assert ((φ → φ') :: Γ ⊢ φ' → (¬ ¬ φ')).
  apply double_negation_intro.

  apply transitivity with (φ' := φ'); assumption.
Qed.

Lemma contraposition_helper: forall Γ φ φ',
    Γ ⊢ (φ' → φ) → (¬ φ → ¬ φ').
Proof.
  intros.

  assert (Γ ⊢ ((¬ ¬ φ') → (¬ ¬ φ)) → (¬ φ → ¬ φ')).
  apply axiom₃.

  assert (Γ ⊢ (φ' → φ) → ((¬ ¬ φ') → (¬ ¬ φ))).
  apply implication_negation.
  apply transitivity with (φ' := ((¬ ¬ φ') → (¬ ¬ φ))); assumption.
Qed.

Lemma hypothesis_swap : forall Γ φ φ' ψ,
    φ :: φ' :: Γ ⊢ ψ ->
    φ' :: φ :: Γ ⊢ ψ.
Proof.
  intros.
  induction H.
  - simpl in H. destruct H as [H | [H | H]]; subst.
    apply premise. simpl. right. left. reflexivity.
    apply premise. simpl. left. reflexivity.
    apply premise. simpl. right. right. assumption.
  - apply mp with (φ' := φ'0); assumption.
Qed.

Lemma and_elim_right : forall Γ φ φ',
    Γ ⊢ ¬ (φ → ¬ φ') → φ.
Proof.
  intros.

  assert (Γ ⊢ ¬ φ → (φ → ¬ φ')).
  apply negation_consequence.

  assert (Γ ⊢ (φ → ¬ φ') → ¬ ¬ (φ → ¬ φ')).
  apply double_negation_intro.

  assert (Γ ⊢ ¬ φ → ¬ ¬ (φ → ¬ φ')).
  apply transitivity with (φ' := (φ → ¬ φ')); assumption.

  assert (Γ ⊢ ((¬ φ) → ¬ (¬ (φ → ¬ φ'))) → (¬ (φ → ¬ φ') → φ)).
  apply axiom₃.

  apply mp with (φ' := (¬ φ → ¬ (¬ (φ → ¬ φ')))); assumption.
Qed.

Lemma modus_tollens : forall Γ φ φ',
    Γ ⊢ φ → φ' ->
    Γ ⊢ ¬ φ' ->
    Γ ⊢ ¬ φ.
Proof.
  intros.

  assert (Γ ⊢ (φ → φ') → (¬ φ' → ¬ φ)).
  apply contraposition_helper.

  assert (Γ ⊢ (¬ φ' → ¬ φ)).
  apply mp with (φ' := (φ → φ')); assumption.

  apply mp with (φ' := ¬ φ'); assumption.
Qed.

Lemma and_comm : forall Γ φ φ',
    Γ ⊢ ¬ (φ → ¬ φ') ->
    Γ ⊢ ¬ (φ' → ¬ φ).
Proof.
  intros.

  assert (φ :: (φ' → ¬ φ) :: Γ ⊢ φ).
  apply premise. simpl. left. reflexivity.
  assert (φ :: (φ' → ¬ φ) :: Γ ⊢ (φ' → ¬ φ)).
  apply premise. simpl. right. left. reflexivity.

  assert (Γ ⊢ (φ' → ¬ φ) → (φ → ¬ φ')).
  apply DT. apply DT.
  apply modus_tollens with (φ' := (¬ φ)). assumption.
  apply negation_introduction. assumption.

  assert (Γ ⊢ ((φ' → ¬ φ) → (φ → ¬ φ')) → (¬ (φ → ¬ φ') → ¬ (φ' → ¬ φ))).
  apply contraposition_helper.

  assert (Γ ⊢ ¬ (φ → ¬ φ') → ¬ (φ' → ¬ φ)).
  apply mp with (φ' := ((φ' → ¬ φ) → (φ → ¬ φ'))); assumption.

  apply mp with (φ' := (¬ (φ → ¬ φ'))); assumption.
Qed.

(* paper and_elimination_right: Γ ⊢ (φ ∧ φ') -> Γ ⊢ φ *)
Lemma and_elimination_right : forall Γ φ φ',
    Γ ⊢ φ ∧ φ' ->
    Γ ⊢ φ.
Proof.
  intros.

  apply conjunction_as_implication in H.

  assert (Γ ⊢ ¬ (φ → ¬ φ') → φ).
  apply and_elim_right.

  apply mp with (φ' := ¬ (φ → ¬ φ')); assumption.
Qed.

(* paper and_elimination_left: Γ ⊢ (φ ∧ φ') -> Γ ⊢ φ' *)
Lemma and_elimination_left : forall Γ φ φ',
    Γ ⊢ φ ∧ φ' ->
    Γ ⊢ φ'.
Proof.
  intros.
  rewrite <- conjunction_as_implication in H.
  apply and_comm in H.
  rewrite conjunction_as_implication in H.
  apply and_elimination_right with (φ' := φ).
  assumption.
Qed.

Lemma and_intro : forall Γ φ φ',
    Γ ⊢ φ ->
    Γ ⊢ φ' ->
    Γ ⊢ ¬ (φ → ¬ φ').
Proof.
  intros.

  assert ((φ → ¬ φ') :: φ :: Γ ⊢ φ).
  apply premise. simpl. right. left. reflexivity.

  assert (φ :: Γ ⊢ (φ → ¬ φ') → ¬ φ').
  apply DT.

  assert ((φ → ¬ φ') :: φ :: Γ ⊢ (φ → ¬ φ')).
  apply premise. simpl. left. reflexivity.

  apply mp with (φ' := φ); assumption.

  assert (φ :: Γ ⊢ ((φ → ¬ φ') → ¬ φ') → ((¬ ¬ φ') → ¬ (φ → ¬ φ'))).
  apply contraposition_helper.

  assert (φ :: Γ ⊢ (¬ (¬ φ') → ¬ (φ → ¬ φ'))).
  apply mp with (φ' := ((φ → ¬ φ') → ¬ φ')); assumption.

  assert ( φ :: Γ ⊢ φ' → ¬ (¬ φ')).
  apply double_negation_intro.

  assert (φ :: Γ ⊢ φ' → ¬ (φ → ¬ φ')).
  apply transitivity with (φ' :=  ¬ (¬ φ')); assumption.
  rewrite <- DT in H6.

  assert (Γ ⊢ φ' → ¬ (φ → ¬ φ')).
  apply mp with (φ' := φ); assumption.
  apply mp with (φ' := φ'); assumption.
Qed.

Lemma and_introduction : forall Γ φ φ',
    Γ ⊢ φ ->
    Γ ⊢ φ' ->
    Γ ⊢ φ ∧ φ'.
Proof.
  intros.

  apply conjunction_as_implication.
  apply and_intro; assumption.
Qed.

Lemma and_commutative: forall Γ φ φ',
    Γ ⊢ φ ∧ φ' ->
    Γ ⊢ φ' ∧ φ.
Proof.
  intros.

  assert (Γ ⊢ φ).
  apply and_elimination_right with (φ' := φ'). assumption.

  assert (Γ ⊢ φ').
  apply and_elimination_left with (φ := φ). assumption.

  apply and_introduction; assumption.
Qed.

Lemma double_negation: forall Γ φ,
    Γ ⊢ φ ↔ ¬ ¬ φ.
Proof.
  intros.

  rewrite equivalence. rewrite <- conjunction_as_implication.

  assert (Γ ⊢ (φ → ¬ (¬ φ))).
  apply double_negation_intro.

  assert (Γ ⊢ (¬ (¬ φ) → φ)).
  apply double_negation_elimination.

  apply and_intro; assumption.
Qed.

Lemma equiv_symmetry: forall Γ φ φ',
    Γ ⊢ φ ↔ φ' ->
    Γ ⊢ φ' ↔ φ.
Proof.
  intros.

  rewrite equivalence.
  apply and_commutative.
  rewrite <- equivalence.
  assumption.
Qed.

(* ******************************************************************************* *)
(* End helper lemmas and theorems                                                  *)
(* ******************************************************************************* *)

(* **************************************************** *)
(* Paper proofs                                         *)
(* **************************************************** *)

(* Δ₁ : delete *)
Lemma Δ₁ : forall Γ φ t,
    Γ ⊢ (φ ∧ (t == t)) → φ.
Proof.
  intros.

  apply DT.

  assert ((φ ∧ t == t) :: Γ ⊢ (φ ∧ t == t)).
  apply premise. simpl. left. reflexivity.

  assert ((φ ∧ t == t) :: Γ ⊢ φ).
  apply and_elimination_right with (φ' := t == t); assumption.
  assumption.
Qed.

(* Δ₂ : Decomposition *)
Lemma Δ₂ : forall Γ φ f args args',
    (length args = length args') ->
    exists ψ,
      (Some ψ = (list_conjunction args args')) /\
      (Γ ⊢ (φ ∧ (f args) == (f args')) → (φ ∧ ψ)).
Proof.
  intros.

  apply list_conjunction_helper in H.
  destruct H as (ψ & H).
  exists ψ. split. rewrite H. reflexivity.

  apply DT.
  assert ((φ ∧ f args == f args') :: Γ ⊢ (φ ∧ f args == f args')).
  apply premise. left. simpl. reflexivity.

  assert ((φ ∧ f args == f args') :: Γ ⊢ φ).
  apply and_elimination_right with (φ' :=  f args == f args'). assumption.

  assert ((φ ∧ f args == f args') :: Γ ⊢ (f args == f args')).
  apply and_elimination_left with (φ := φ). assumption.

  assert (E: exists ψ', (Some ψ' = list_conjunction args args') /\ ((φ ∧ f args == f args') :: Γ ⊢ (f args == f args') → ψ')).
  apply injectivity. destruct E as (ψ' & E & E').
  rewrite H in E. inversion E. subst. clear E.

  assert ((φ ∧ f args == f args') :: Γ ⊢ ψ).
  apply mp with (φ' := (f args == f args')); assumption.

  apply conjunction_as_implication.
  apply and_intro; assumption.
Qed.

Lemma Δ₃ : forall Γ φ f (tᵢ : list Pattern) x,
    Γ ⊢ (φ ∧ (f tᵢ) == (var x)) → (φ ∧ (var x) == (f tᵢ)).
Proof.
  intros.
  rewrite equal_symmetry.
  apply refl.
Qed.

Lemma Δ₄: forall Γ φ x t,
    Γ ⊢ (φ ∧ (var x) == t) → ((substitution t x φ) ∧ (var x) == t).
Proof.
  intros.

  assert ((φ ∧ var x == t) :: Γ  ⊢ (φ ∧ var x == t)).
  apply premise. simpl. left. reflexivity.

  assert ((φ ∧ var x == t) :: Γ  ⊢ φ).
  apply and_elimination_right with (φ' := var x == t). assumption.

  assert ((φ ∧ var x == t) :: Γ  ⊢ var x == t).
  apply and_elimination_left with (φ := φ). assumption.

  rewrite <- subst_id with (x := x) in H0.
  assert ((φ ∧ var x == t) :: Γ ⊢ (var x == t) ∧ (substitution (var x) x φ) →  substitution t x φ).
  apply equality_elimination.

  assert ((φ ∧ var x == t) :: Γ ⊢ (var x == t) ∧ (substitution (var x) x φ)).
  apply and_introduction; assumption.

  assert ((φ ∧ var x == t) :: Γ ⊢ substitution t x φ).
  apply mp with (φ' := (var x == t ∧ substitution (var x) x φ)); assumption.

  apply DT. apply and_introduction; assumption.
Qed.

Lemma Prop₃_left: forall Γ ϕ ϕ',
    Γ ⊢ ϕ ∧ (ϕ == ϕ') → (ϕ ∧ ϕ').
Proof.
  intros.

  assert ((ϕ ∧ ϕ == ϕ') :: Γ ⊢ ϕ ∧ (ϕ == ϕ')).
  apply premise. simpl. left. reflexivity.

  assert ((ϕ ∧ ϕ == ϕ') :: Γ ⊢ ϕ).
  apply and_elimination_right with (φ' := (ϕ == ϕ')). assumption.

  assert ((ϕ ∧ ϕ == ϕ') :: Γ ⊢ (ϕ == ϕ')).
  apply and_elimination_left with (φ := ϕ). assumption.
  rewrite <- equal_equiv in H1 at 2.

  assert ((ϕ ∧ ϕ == ϕ') :: Γ ⊢ ϕ → ϕ').
  rewrite equivalence in H1.
  apply and_elimination_right with (φ' := (ϕ' → ϕ)); assumption.

  assert ((ϕ ∧ ϕ == ϕ') :: Γ ⊢ ϕ').
  apply mp with (φ' := ϕ); assumption.

  apply DT.
  apply and_introduction; assumption.
Qed.

Lemma Prop₃_right: forall Γ ϕ ϕ',
    Γ ⊢ (ϕ ∧ ϕ') → (ϕ ∧ (ϕ == ϕ')).
Proof.
  intros.

  apply DT.
  assert ((ϕ ∧ ϕ') :: Γ ⊢ ϕ ∧ ϕ').
  apply premise. simpl. left. reflexivity.

  assert ((ϕ ∧ ϕ') :: Γ ⊢ ⌈ ϕ ∧ ϕ' ⌉).
  apply definedness_axiom. assumption.
  rewrite membership_helper in H0.

  assert ((ϕ ∧ ϕ') :: Γ ⊢ (ϕ ∈ ϕ') == (ϕ == ϕ')).
  apply eq_membership.
  rewrite <- equal_equiv in H1.
  rewrite equivalence in H1.

  assert ((ϕ ∧ ϕ') :: Γ ⊢ (ϕ ∈ ϕ' → ϕ == ϕ')).
  apply and_elimination_right with (φ' := (ϕ == ϕ' → ϕ ∈ ϕ')). assumption.

  assert ((ϕ ∧ ϕ') :: Γ ⊢ ϕ == ϕ').
  apply mp with (φ' := ϕ ∈ ϕ'); assumption.

  assert ((ϕ ∧ ϕ') :: Γ ⊢ ϕ ).
  apply and_elimination_right with (φ' := ϕ'). assumption.

  apply and_introduction; assumption.
Qed.

Corollary Prop₃: forall Γ φ φ',
    Γ ⊢ (φ ∧ φ') ↔ (φ ∧ (φ == φ')).
Proof.
  intros. rewrite equivalence.
  apply and_introduction.
  apply Prop₃_right.
  apply Prop₃_left.
Qed.


Require Export XR_Rplus_0_r.
Require Export XR_Rplus_le_reg_r.
Require Export XR_Rplus_le_compat.

Local Open Scope R_scope.

Lemma Rplus_le_reg_pos_r : forall r1 r2 r3,
  R0 <= r2 ->
  r1 + r2 <= r3 ->
  r1 <= r3.
Proof.
  intros x y z.
  intros hy h.
  apply Rplus_le_reg_r with y.
  apply Rle_trans with z.
  { exact h. }
  {
    pattern z at 1 ; rewrite <- Rplus_0_r.
    apply Rplus_le_compat.
    {
      unfold "<=".
      right.
      reflexivity.
    }
    { exact hy. }
  }
Qed.


(* jeu avec les catégories - 1ere version *)

Require Import Utf8.

Definition compose {A B C} (f : A → B) (g : B → C) := λ x, g (f x).
Notation "g '◦' f" := (compose f g) (at level 40).
Notation "f '==' g" := (∀ x, f x = g x) (at level 70).

(* surjection vs epimorphism *)

Definition is_surjection {A B} (f : A → B) := ∀ y, ∃ x, f x = y.
Definition is_epimorphism {A B} (u : A → B) :=
  ∀ C (v w : B → C), v ◦ u == w ◦ u → v == w.

Definition has_decidable_equality A := ∀ x y : A, {x = y} + {x ≠ y}.
Definition not_not_exist_imp_exist A :=
  ∀ (P : A → Prop), (¬ ¬ ∃ x, P x) → ∃ x, P x.

Theorem is_surjection_is_epimorphism :
  ∀ A B (f : A → B), is_surjection f → is_epimorphism f.
Proof.
intros * Hs.
unfold is_surjection in Hs.
intros C v w He y.
specialize (Hs y) as (x, Hx).
subst y; apply He.
Defined.

Theorem is_epimorphism_is_surjection :
  ∀ A B (f : A → B),
  has_decidable_equality B →
  not_not_exist_imp_exist A →
  is_epimorphism f → is_surjection f.
Proof.
intros A B u EqB NNE He.
unfold is_epimorphism in He.
intros y.
assert (Hn : ¬ (∀ x, u x ≠ y)). {
  set (v (b : B) := if EqB b y then 1 else 0).
  set (w (b : B) := 0).
  specialize (He _ v w) as H1.
  intros H2.
  assert (Hx : v ◦ u == w ◦ u). {
    intros x.
    unfold v, w, "◦"; simpl.
    destruct (EqB (u x) y) as [H3| H3]; [ | easy ].
    now specialize (H2 x).
  }
  specialize (H1 Hx y).
  unfold v, w in H1.
  now destruct (EqB y y).
}
apply NNE.
intros H2.
apply Hn; intros x H3.
apply H2.
now exists x.
Defined.

(* injection vs monomorphism *)

Definition is_injection {A B} (f : A → B) := ∀ x y, f x = f y → x = y.
Definition is_monomorphism {A B} (u : A → B) :=
  ∀ C (v w : C → A), u ◦ v == u ◦ w → v == w.

Theorem is_injection_is_monomorphism :
  ∀ A B (f : A → B), is_injection f → is_monomorphism f.
Proof.
intros A B u Hi C v w Hu c.
unfold is_injection in Hi.
specialize (Hi (v c) (w c)) as H1.
now specialize (H1 (Hu c)).
Defined.

Definition is_injection_is_monomorphism2 :
    ∀ A B (f : A → B), is_injection f → is_monomorphism f :=
  λ A B u Hi C v w Hu c, Hi (v c) (w c) (Hu c).

Theorem is_monomorphism_is_injection :
  ∀ A B (f : A → B), is_monomorphism f → is_injection f.
Proof.
intros A B u Hm x y Hu.
unfold is_monomorphism in Hm.
set (v (_ : True) := x).
set (w (_ : True) := y).
specialize (Hm _ v w) as H1.
assert (H : u ◦ v == u ◦ w) by easy.
specialize (H1 H); clear H.
now unfold v, w in H1; apply H1.
Show Proof.
Defined.

Definition is_monomorphism_is_injection2 :
    ∀ A B (f : A → B), is_monomorphism f → is_injection f :=
  λ A B f Hm x y Hu, Hm _ (λ _, x) (λ _, y) (λ _, Hu) I.

(* sections and retractions *)

Definition has_section {A B} (f : A → B) := ∃ s, f ◦ s == λ y, y.
Definition has_retraction {A B} (f : A → B) := ∃ r, r ◦ f == λ x, x.

Theorem has_section_is_epimorphism : ∀ A B (f : A → B),
  has_section f → is_epimorphism f.
Proof.
intros A B u HS.
destruct HS as (s, HS).
unfold is_epimorphism.
intros C v w Hu y.
specialize (HS y) as H1.
rewrite <- H1.
unfold compose.
apply Hu.
Qed.

Theorem has_retraction_is_monomorphism : ∀ A B (f : A → B),
  has_retraction f → is_monomorphism f.
Proof.
intros A B u HR.
destruct HR as (r, HR).
unfold is_monomorphism.
intros C v w Hu c.
rewrite <- HR; symmetry.
rewrite <- HR; symmetry.
unfold "◦" in Hu.
unfold "◦".
now rewrite Hu.
Qed.

(* digression sur Yoneda *)

Lemma Yoneda : ∀ A : Prop, (∀ C : Prop, (A → C) → C) ↔ A.
Proof.
intros.
split.
-intros HC.
 specialize (HC A).
 now apply HC.
-intros * HC C HA.
 now apply HA.
Qed.

(* tiens, au fait, qu'est-ce que l'univalence en pense ? *)

Definition isequiv {A B : Type} (f : A → B) :=
  {g : B → A & (∀ a, g (f a) = a) & (∀ b, f (g b) = b)}.

Definition equivalence (A B : Type) := { f : A → B & isequiv f}.
Notation "A ≃ B" := (equivalence A B) (at level 70).

Theorem happly : ∀ A B (f g : ∀ (x : A), B x), f = g → ∀ (x : A), f x = g x.
Proof.
intros * p.
now destruct p.
Defined.

Definition extensionality := ∀ A B f g, isequiv (happly A B f g).

Theorem are_equiv_inj_mono : ∀ A B (f : A → B),
  extensionality
  → is_injection f ≃ is_monomorphism f.
Proof.
intros * HF.
exists (is_injection_is_monomorphism2 A B f).
unfold isequiv.
exists (is_monomorphism_is_injection2 A B f); [ easy | ].
intros HM.
unfold is_monomorphism_is_injection2.
unfold is_injection_is_monomorphism2.
unfold is_monomorphism in HM.
apply HF; intros C.
apply HF; intros g.
apply HF; intros h.
apply HF; intros HU.
apply HF; intros c.
specialize (HM _ _ _ HU) as H1.
specialize (HF _ _ g h) as H2.
unfold happly in H2.
unfold isequiv in H2.
simpl in H2.
destruct H2 as (H3, H4, H5).
clear H4 H5.
specialize (H3 H1).
subst g.

(* ouais, chais pas *)

...

Theorem are_equiv_surj_epi : ∀ A B (f : A → B),
  has_decidable_equality B
  → not_not_exist_imp_exist A
  → is_surjection f ≃ is_epimorphism f.
Proof.
intros * EqB NNE.
exists (is_surjection_is_epimorphism A B f).
unfold isequiv.
exists (is_epimorphism_is_surjection A B f EqB NNE).
-intros HS.
 unfold is_epimorphism_is_surjection.
...


(*  Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)
(* An axiomatization of expected polynomial time as a type class.  *)

Require Import FCF.Crypto.
Require Import FCF.Asymptotic.
Require Import FCF.FCF.

Definition procedure_family(A : nat -> Type) := forall n, A n.
Definition efficiency_predicate := forall (A : nat -> Type), procedure_family A -> Prop.

(* We can abstract over arrow.  This would allow us to make sure that there is a model of the axioms below. *)
(* Is there a language with a "function space" and "efficiency" that satisfies these semantics.  Make this language! *)
(* Exercise: write the description of this class in a paper. *)

Class expected_poly_time_predicate(efficient : efficiency_predicate) := {

  expected_poly_time_compose :
  forall (A B C : nat -> Type)(f1 : forall n, A n -> B n)(f2 : forall n, A n -> B n -> C n),
    efficient _ f1 ->
    efficient _ f2 ->
    efficient _ (fun n (a : A n) => f2 n a (f1 n a));

  expected_poly_time_compose_0 :
    forall (A B : nat -> Type)(f1 : forall n, A n)(f2 : forall n, A n -> B n),
      efficient _ f1 ->
      efficient _ f2 ->
      efficient _ (fun n => f2 n (f1 n));

  expected_poly_time_ident :
    forall (A : nat -> Type),
      efficient _ (fun n (a : A n) => a);

  expected_poly_time_const :
    forall (A B : nat -> Type)(b : forall n, B n),
      efficient _ b ->
      efficient _ (fun (n : nat)(_ : A n) => (b n));

  expected_poly_time_closure_const :
    forall (A : Type)(a : A)(B : nat -> Type)(f : forall n, A -> B n),
      efficient _ f ->
      efficient _ (fun (n : nat) => @f n a);

  expected_poly_time_nil :
    forall (A : nat -> Type),
      efficient _ (fun n => @nil (A n));

  expected_poly_time_cons :
  forall (A : nat -> Type),
    efficient _ (fun n (a : A n) ls => cons a ls);

  expected_poly_time_pair :
    forall (A : nat -> Type)(B : nat -> Type),
      efficient _ (fun n => @pair (A n) (B n));

  expected_poly_time_ret :
    forall (A : nat -> Set)(eqd : forall n, eq_dec (A n)),
      efficient _ (fun n (a : A n) => Ret (eqd n) a);

  expected_poly_time_rnd :
  forall f,
    polynomial f ->
    efficient _ (fun n => ({0, 1}^(f n)));

  expected_poly_time_bind :
  forall (A B : nat -> Set),
    efficient _ (fun n => @Bind (A n) (B n));

  expected_poly_time_vec_hd :
    forall (A : nat -> Type) z,
      efficient _ (fun n (v : Vector.t (A n) (S z)) => Vector.hd v);

   expected_poly_time_pair_arg :
    forall (A B C: nat -> Type)(f : forall (n : nat), A n -> B n -> C n),
      efficient _ (fun (n : nat)(p : (A n * B n)) => f n (fst p) (snd p)) ->
      efficient _ f;

  expected_poly_time_unpair_arg :
    forall (A B C: nat -> Type)(f : forall (n : nat), (A n * B n) -> C n),
      efficient _ (fun (n : nat)(a : A n)(b : B n) => f n (a, b)) ->
      efficient _ f;

      (* The let rules are structured differently -- I should see if I can make them consistent *)
  expected_poly_time_let_3_f :
    forall (A B C D E: nat -> Type)(f1 : forall n, (A n) -> (B n * C n * D n))(f2 : forall n, (A n) -> B n -> C n -> D n -> E n),
      efficient _ f1 ->
      efficient _ f2 ->
      efficient _ (fun n (a : A n) => [x1, x2, x3] <-3 (f1 n a); f2 n a x1 x2 x3);

  expected_poly_time_let_2_f :
    forall (A B C E: nat -> Type)(f1 : forall n, (A n) -> (B n * C n))(f2 : forall n, (A n) -> B n -> C n -> E n),
      efficient _ f1 ->
      efficient _ f2 ->
      efficient _ (fun n (a : A n) => [x1, x2] <-2 (f1 n a); f2 n a x1 x2);

  expected_poly_time_let_f :
    forall (A : nat -> Type)(B : nat -> Set)(C : nat -> Type)(f1 : forall n, (A n) -> B n)(f2 : forall n, (A n) -> B n -> C n),
      efficient _ f1 ->
      efficient _ f2 ->
      efficient _ (fun n (a : A n) => x <- (f1 n a); f2 n a x);

  expected_poly_time_fst :
    forall (A B : nat -> Type),
      efficient _ (fun n (a : A n * B n) => fst a);

  expected_poly_time_snd :
    forall (A B : nat -> Type),
      efficient _ (fun n (a : A n * B n) => snd a);

  expected_poly_time_if :
    forall (A : nat -> Type),
      efficient _ (fun n (b : bool)(a1 a2 : A n) => if b then a1 else a2);

  expected_poly_time_bvxor :
    efficient _ BVxor;

  expected_poly_time_eqb_bool :
    efficient _ (fun n (x y : bool) => eqb x y)

}.

Section expected_poly_time_theory.

  Context `{ept : expected_poly_time_predicate}.

  Theorem expected_poly_time_compose_simp :
    forall (A B C : nat -> Type)(f1 : forall n, A n -> B n)(f2 : forall n, B n -> C n),
      efficient _ f1 ->
      efficient _ f2 ->
      efficient _ (fun n (a : A n) => f2 n (f1 n a)).

    intuition.
    eapply (@expected_poly_time_compose _ _ _ _ _ _ (fun n a b => (f2 n b))); eauto.
    eapply expected_poly_time_const; eauto.

  Qed.

  Theorem expected_poly_time_compose_binary :
    forall (A B C D : nat -> Type)(f1 : forall n, A n -> B n)(f2 : forall n, A n -> C n)(f3 : forall n, B n -> C n -> D n) ,
      efficient _ f1 ->
      efficient _ f2 ->
      efficient _ f3 ->
      efficient _ (fun n (a : A n) => f3 n (f1 n a) (f2 n a)).

    intuition.
    eapply (@expected_poly_time_compose _ _ _ _ _ _ (fun n a b => f3 n (f1 n a) b)); eauto.
    eapply (@expected_poly_time_compose _ _ _ _ _ _ (fun n a b => f3 n b)); eauto.
    eapply expected_poly_time_const.
    eauto.

  Qed.

  Theorem expected_poly_time_pair_f :
    forall (A B C : nat -> Type)(f1 : forall n, A n -> B n)(f2 : forall n, A n -> C n),
      efficient _ f1 ->
      efficient _ f2 ->
      efficient _ (fun n (a : A n) => (f1 n a, f2 n a)).

    intuition.
    eapply (@expected_poly_time_compose_binary _ _ _ _ _ _ (fun n b c => pair b c)); eauto.
    eapply expected_poly_time_pair.
  Qed.

  Theorem expected_poly_time_bvxor_f :
    forall (A : nat -> Type)(f1 : forall n, A n -> Bvector n)(f2 : forall n, A n -> Bvector n),
      efficient _ f1 ->
      efficient _ f2 ->
      efficient _ (fun n (a : A n) => BVxor n (f1 n a) (f2 n a)).

    intuition.
    eapply (@expected_poly_time_compose_binary _ _ _ _ _ _ BVxor); eauto.
    eapply expected_poly_time_bvxor.
  Qed.

  Theorem expected_poly_time_eqb_bool_f :
    forall (A : nat -> Type)(f1 : forall n, A n -> bool)(f2 : forall n, A n -> bool),
      efficient _ f1 ->
      efficient _ f2 ->
      efficient _ (fun n (a : A n) => eqb (f1 n a) (f2 n a)).

    intuition.
    eapply (@expected_poly_time_compose_binary _ _ _ _ _ _ (fun n a b => eqb a b)); eauto.
    eapply expected_poly_time_eqb_bool.
  Qed.

  Theorem expected_poly_time_fst_f :
    forall (A B C : nat -> Type)(f : forall n, A n -> (B n * C n)),
      efficient _ f ->
      efficient _ (fun n (a : A n) => fst (f n a)).

    intuition.
    eapply (@expected_poly_time_compose_simp _ _ _ _ (fun n a => fst a)); eauto.
    eapply expected_poly_time_fst.
  Qed.

  Theorem expected_poly_time_snd_f :
    forall (A B C : nat -> Type)(f : forall n, A n -> (B n * C n)),
      efficient _ f ->
      efficient _ (fun n (a : A n) => snd (f n a)).

    intuition.
    eapply (@expected_poly_time_compose_simp _ _ _ _ (fun n a => snd a)); eauto.
    eapply expected_poly_time_snd.
  Qed.

  Theorem expected_poly_time_compose_0_binary :
    forall (A B C : nat -> Type)(f1 : forall n, A n)(f2 : forall n, B n)(f3 : forall n, A n -> B n -> C n) ,
      efficient _ f1 ->
      efficient _ f2 ->
      efficient _ f3 ->
      efficient _ (fun n => f3 n (f1 n) (f2 n)).

    intuition.
    eapply (@expected_poly_time_compose_0 _ _ _ _ _ (fun n b => f3 n (f1 n) b)); eauto.
    eapply (@expected_poly_time_compose_0 _ _ _ _ _ (fun n b => f3 n b)); eauto.

  Qed.

  Theorem expected_poly_time_bind_0_f :
    forall (A B : nat -> Set) (a : forall n, Comp (A n)) (b : forall n, A n -> Comp (B n)),
      efficient _ a ->
      efficient _ b ->
      efficient _ (fun n => (Bind (a n) (b n))).

    intuition.
    eapply (@expected_poly_time_compose_0_binary _ _ _ a b (fun n a b => Bind a b)); eauto.
    eapply expected_poly_time_bind.
  Qed.

  Theorem expected_poly_time_bind_f :
    forall (A : nat -> Type)(B C : nat -> Set) (b : forall n, A n -> Comp (B n)) (c : forall n, A n -> B n -> Comp (C n)),
      efficient _ b ->
      efficient _ c ->
      efficient _ (fun n a => (Bind (b n a) (c n a))).

    intuition.
    eapply (@expected_poly_time_compose_binary _ _ _ _ b c (fun n a b => Bind a b)); eauto.
    eapply expected_poly_time_bind.
  Qed.

  Theorem expected_poly_time_ret_f :
    forall (A : nat -> Type)(B : nat -> Set)(eqd : forall n, eq_dec (B n))(f : forall n, (A n) -> (B n)),
      efficient _ f ->
      efficient _ (fun n (a : A n) => Ret (eqd n) (f n a)).

    intuition.
    eapply (@expected_poly_time_compose_simp _ _ _ _ (fun n b => Ret (eqd n) b)); eauto.
    eapply expected_poly_time_ret.

  Qed.

  Theorem expected_poly_time_rnd_ident :
    efficient _ (fun n => ({0, 1} ^ n)).

    eapply expected_poly_time_rnd.
    exists 1%nat.
    exists 1%nat.
    exists 0%nat.
    intuition.
    simpl.
    lia.
  Qed.

  Theorem expected_poly_time_rndbool :
    efficient _ (fun (n : nat) => {0, 1}).

    eapply expected_poly_time_bind_0_f.

    eapply expected_poly_time_rnd.
    exists 0%nat.
    exists 1%nat.
    exists 0%nat.
    intuition.

    eapply expected_poly_time_ret_f.
    eapply expected_poly_time_vec_hd.

  Qed.

  Theorem expected_poly_time_if_f :
    forall (A B: nat -> Type)(f_b : forall n, (A n) -> bool)(f_so f_not : forall n, A n -> B n),
      efficient _ f_b ->
      efficient _ f_so ->
      efficient _ f_not ->
      efficient _ (fun n (a : A n) => if (f_b n a) then (f_so n a) else (f_not n a)).

    intuition.

    eapply (@expected_poly_time_compose _ _ _ _ _ _ (fun n a (b : bool) => if b then (f_so n a) else (f_not n a))); eauto.

    eapply expected_poly_time_pair_arg.
    eapply (@expected_poly_time_compose _ _ _ _ _ _ (fun n (a : A n * bool) b => if (snd a) then b else (f_not n (fst a)))); eauto.
    apply (@expected_poly_time_compose_simp _ _ _ _ f_so); eauto.
    eapply expected_poly_time_fst.

    eapply expected_poly_time_pair_arg.
    eapply (@expected_poly_time_compose _ _ _ _ _ _ (fun n (a : A n * bool * B n) b => if (snd (fst a)) then (snd a) else b)); eauto.
    apply (@expected_poly_time_compose_simp _ _ _ _ f_not); eauto.
    apply (@expected_poly_time_compose_simp _ _ _ _ (fun n a => fst a)); eauto.
    eapply expected_poly_time_fst.
    eapply expected_poly_time_fst.

    eapply expected_poly_time_unpair_arg.
    eapply expected_poly_time_unpair_arg.
    simpl.
    eapply expected_poly_time_const.
    eapply expected_poly_time_if.

  Qed.

  Theorem expected_poly_time_cons_f :
    forall A B (f1 : forall n, A n -> B n) (f2 : forall n, A n -> list (B n)),
      efficient _ f1 ->
      efficient _ f2 ->
      efficient _ (fun n (a : A n) => (cons (f1 n a) (f2 n a))).

    intuition.
    eapply (@expected_poly_time_compose_binary _ _ _ _ _ _ (fun n a b => cons a b)); intuition.
    eapply expected_poly_time_cons.
  Qed.

End expected_poly_time_theory.

Ltac ept_tac :=
  match goal with
    | [|- ?efficient _ (fun n a => a)] => eapply expected_poly_time_ident
    | [|- ?efficient _ (fun n a => fst a)] => eapply expected_poly_time_fst
    | [|- ?efficient _ (fun n a => snd a)] => eapply expected_poly_time_snd
    | [|- ?efficient _ _ ] => eapply expected_poly_time_rndbool
    | [|- ?efficient _ Rnd ] => eapply expected_poly_time_rnd_ident
    | [|- ?efficient _ (fun n => nil)] => eapply expected_poly_time_nil

    | [|- ?efficient _ _ ] => eapply expected_poly_time_if_f
    | [|- ?efficient _ _ ] => eapply expected_poly_time_eqb_bool_f
    | [|- ?efficient _ _ ] => eapply expected_poly_time_bvxor_f
    | [|- ?efficient _ _ ] => eapply expected_poly_time_cons_f
    | [|- ?efficient _ _ ] => eapply expected_poly_time_pair_f
    | [|- ?efficient _ _ ] => eapply expected_poly_time_fst_f
    | [|- ?efficient _ _ ] => eapply expected_poly_time_snd_f
    | [|- ?efficient _ (fun n a => ?b)] => eapply expected_poly_time_const
    | [|- ?efficient _ _] => eapply expected_poly_time_closure_const
    | [|- ?efficient _ _ ] => eapply expected_poly_time_ret_f
    | [|- ?efficient _ (fun n => Bind _ _) ] => eapply expected_poly_time_bind_0_f
    | [|- ?efficient _ _ ] => eapply expected_poly_time_bind_f
    | [|- ?efficient _ _ ] => eapply expected_poly_time_pair_arg
  end.

Ltac ept := repeat ept_tac.


Set Warnings "-notation-overridden,-parsing".
Require Import Coq.omega.Omega.
Require Import Maps.
Require Import Imp.

Ltac inv H := inversion H; subst; clear H.

Theorem ceval_deterministic: forall c st st1 st2,
  c / st \\ st1 ->
  c / st \\ st2 ->
  st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2.
  - reflexivity.
  - reflexivity.
  - assert (st' = st'0) as Eq1.
    { apply IHE1_1; apply H1. }
    subst st'0.
    apply IHE1_2. assumption.
  - apply IHE1. assumption.
  - rewrite H in H5. inversion H5.
  - rewrite H in H5. inversion H5.
  - apply IHE1. assumption.
  - reflexivity.
  - rewrite H in H2. inversion H2.
  - rewrite H in H4. inversion H4.
  - assert (st' = st'0) as EQ1.
    { apply IHE1_1; assumption. }
    subst st'0.
    apply IHE1_2. assumption. Qed.

Example auto_example_1 : forall (P Q R : Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros P Q R H1 H2 H3.
  apply H2. apply H1. assumption.
Qed.

Example auto_example_1' : forall (P Q R : Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  auto.
Qed.

Example auto_example_2 : forall P Q R S T U : Prop,
  (P -> Q) ->
  (P -> R) ->
  (T -> R) ->
  (S -> T -> U) ->
  ((P -> Q) -> (P -> S)) ->
  T -> P -> U.
Proof. auto. Qed.

Example auto_example_3 : forall (P Q R S T U : Prop),
  (P -> Q) ->
  (Q -> R) ->
  (R -> S) ->
  (S -> T) ->
  (T -> U) ->
  P ->
  U.
Proof.
  auto.
  auto 6.
Qed.

Example auto_example_4 : forall P Q R : Prop,
  Q -> (Q -> R) -> P \/ (Q /\ R).
Proof. auto. Qed.

Lemma le_antisym : forall n m : nat,
  (n <= m /\ m <= n) -> n = m.
Proof.
  intros.
  omega. Qed.

Example auto_example_6 : forall n m p : nat,
  (n <= p -> (n <= m /\ m <= n)) ->
  n <= p -> n = m.
Proof.
  intros.
  auto using le_antisym.
Qed.

Hint Resolve le_antisym.

Example auto_example_6' : forall n m p : nat,
  (n <= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  intros.
  auto.
Qed.

Definition is_fortytwo x := (x = 42).

Example auto_example_7 : forall x,
  (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof.
  auto.
Abort.

Hint Unfold is_fortytwo.

Example auto_example_7' : forall x,
  (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof. auto. Qed.

Theorem ceval_deterministic' : forall c st st1 st2,
  c / st \\ st1 ->
  c / st \\ st2 ->
  st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
    induction E1; intros st2 E2; inv E2; auto.
  - assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - + rewrite H in H5. inversion H5.
  - + rewrite H in H5. inversion H5.
  - + rewrite H in H2. inversion H2.
  - rewrite H in H4. inversion H4.
  - assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
Qed.

Theorem ceval_deterministic'_alt : forall c st st1 st2,
  c / st \\ st1 ->
  c / st \\ st2 ->
  st1 = st2.
Proof with auto.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1;
    intros st2 E2; inv E2...
  - assert (st' = st'0) as EQ1...
    subst st'0...
  - + rewrite H in H5. inversion H5.
  - + rewrite H in H5. inversion H5.
  - + rewrite H in H2. inversion H2.
  - rewrite H in H4. inversion H4.
  - assert (st' = st'0) as EQ1...
    subst st'0...
Qed.

Ltac rwinv H1 H2 := rewrite H1 in H2; inv H2.

Theorem ceval_deterministic'' : forall c st st1 st2,
  c / st \\ st1 ->
  c / st \\ st2 ->
  st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; auto.
  - assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - + rwinv H H5.
  - + rwinv H H5.
  - + rwinv H H2.
  - rwinv H H4.
  - assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto. Qed.

Ltac find_rwinv :=
  match goal with
    H1 : ?E = true,
    H2 : ?E = false
    |- _ => rwinv H1 H2
  end.

Theorem ceval_deterministic''' : forall c st st1 st2,
  c / st \\ st1 ->
  c / st \\ st2 ->
  st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv; auto.
  - assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - + assert (st' = st'0) as EQ1 by auto.
      subst st'0.
      auto. Qed.

Theorem ceval_deterministic'''' : forall c st st1 st2,
  c / st \\ st1 ->
  c / st \\ st2 ->
  st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv; auto.
  - rewrite (IHE1_1 st'0 H1) in *. auto.
  - + rewrite (IHE1_1 st'0 H3) in *. auto. Qed.

Ltac find_eqn :=
  match goal with
    H1: forall x, ?P x -> ?L = ?R,
    H2: ?P ?X
    |- _ => rewrite (H1 X H2) in *
  end.

Theorem ceval_deterministic''''' : forall c st st1 st2,
  c / st \\ st1 ->
  c / st \\ st2 ->
  st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv;
    repeat find_eqn; auto.
Qed.

Module Repeat.
Inductive com : Type :=
  | CSkip : com
  | CAsgn : string -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CRepeat : com -> bexp -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "c1 ; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "X '::=' a" :=
  (CAsgn X a) (at level 60).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'REPEAT' e1 'UNTIL' b2 'END'" :=
  (CRepeat e1 b2) (at level 80, right associativity).
Inductive ceval : state -> com -> state -> Prop :=
  | E_Skip : forall st,
      ceval st SKIP st
  | E_Ass : forall st a1 n X,
      aeval st a1 = n ->
      ceval st (X ::= a1) (t_update st X n)
  | E_Seq : forall c1 c2 st st' st'',
      ceval st c1 st' ->
      ceval st' c2 st'' ->
      ceval st (c1 ; c2) st''
  | E_IfTrue : forall st st' b1 c1 c2,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
  | E_IfFalse : forall st st' b1 c1 c2,
      beval st b1 = false ->
      ceval st c2 st' ->
      ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
  | E_WhileFalse : forall b1 st c1,
      beval st b1 = false ->
      ceval st (WHILE b1 DO c1 END) st
  | E_WhileTrue : forall st st' st'' b1 c1,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st' (WHILE b1 DO c1 END) st'' ->
      ceval st (WHILE b1 DO c1 END) st''
  | E_RepeatEnd : forall st st' b1 c1,
      ceval st c1 st' ->
      beval st' b1 = true ->
      ceval st (CRepeat c1 b1) st'
  | E_RepeatLoop : forall st st' st'' b1 c1,
      ceval st c1 st' ->
      beval st' b1 = false ->
      ceval st' (CRepeat c1 b1) st'' ->
      ceval st (CRepeat c1 b1) st''.
Notation "c1 '/' st '\\' st'" := (ceval st c1 st')
                                 (at level 40, st at level 39).

Theorem ceval_deterministic: forall c st st1 st2,
     c / st \\ st1 ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1;
    intros st2 E2; inv E2; try find_rwinv; repeat find_eqn; auto.
  - (* E_RepeatEnd *)
    + (* b evaluates to false (contradiction) *)
       find_rwinv.
       (* oops: why didn't find_rwinv solve this for us already?
          answer: we did things in the wrong order. *)
  - (* E_RepeatLoop *)
     + (* b evaluates to true (contradiction) *)
        find_rwinv.
Qed.

Theorem ceval_deterministic': forall c st st1 st2,
     c / st \\ st1 ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1;
    intros st2 E2; inv E2; repeat find_eqn; try find_rwinv; auto.
Qed.
End Repeat.

Example ceval'_example1:
    (X ::= 2;;
     IFB X ≤ 1
       THEN Y ::= 3
       ELSE Z ::= 4
     FI)
   / { --> 0 }
   \\ { X --> 2 ; Z --> 4 }.
Proof.
  eapply E_Seq. (* 1 *)
  - apply E_Ass. (* 2 *)
    reflexivity. (* 3 *)
  - (* 4 *) apply E_IfFalse. reflexivity. apply E_Ass. reflexivity.
Qed.

 Hint Constructors ceval.
Hint Transparent state.
Hint Transparent total_map.
Definition st12 := { X --> 1 ; Y --> 2 }.
Definition st21 := { X --> 2 ; Y --> 1 }.
Example eauto_example : exists s',
  (IFB X ≤ Y
    THEN Z ::= Y - X
    ELSE Y ::= X + Z
  FI) / st21 \\ s'.
Proof. eauto. Qed.


(*
abhishek@brixpro:~/parametricity/reflective-paramcoq/test-suite$ ./coqid.sh indFunArg
*)

Require Import SquiggleEq.terms.

Require Import ReflParam.common.
Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
Require Import ReflParam.paramDirect ReflParam.indType.
Require Import SquiggleEq.substitution.
Require Import ReflParam.PiTypeR.
Import ListNotations.
Open Scope string_scope.

Require Import ReflParam.PIWNew.

Require Import Template.Template.

Require Import ReflParam.matchR. (* shadows Coq.Init.Datatypes.list *)
Require Import List.
(* Run TemplateProgram (mkIndEnv "indTransEnv" ["ReflParam.matchR.Vec"]). *)

Inductive Vec (C : Set) : nat -> Set :=
    vnil : Vec C 0 | vcons : forall n : nat, C -> Vec C n -> Vec C (n+1).

Require Import Top.nat.
(*
Run TemplateProgram (genParamInd [] false true true true "ReflParam.matchR.Vec").
*)

Definition one_RR : nat_RR 1 1.
simpl. eexists; eauto; constructor.
Defined.

Definition Vec_RR :=
(fix
 ReflParam_matchR_Vec_RR0 (C C₂ : Set) (C_R : C -> C₂ -> Prop) (H H0 : nat)
                          (H1 : nat_RR H H0) (H2 : Vec C H) (H3 : Vec C₂ H0) {struct H2} :
   Prop :=
   let reT n1 n2 := forall (nr : nat_RR n1 n2), Prop in
   (match H2 in Vec _ n1 return reT n1 H0 with
   | vnil _ => match H3 in Vec _ n2 return reT 0 n2  with
               | vnil _ => fun nr => nr = O_RR
               | vcons _ _ _ _ => fun _ => False
               end
   | vcons _ n x x0 =>
       match H3 with
       | vnil _ => fun _ => False
       | vcons _ n₂ x1 x2 =>
       fun nr =>
           {n_R : nat_RR n n₂ &
           {_ : C_R x x1 & {_ : ReflParam_matchR_Vec_RR0 C C₂ C_R n n₂ n_R x0 x2
           & nr = add_RR _ _ n_R 1 1 one_RR}}}
       end
   end) H1
    ).

 (*success!*)
(*
(fun (C C₂ : Set) (C_R : C -> C₂ -> Prop) (n n₂ : nat) (H : C) (H0 : C₂)
   (H1 : Vec C n) (H2 : Vec C₂ n₂)
   (sigt : {n_R : Coq_Init_Datatypes_nat_RR0 n n₂ &
           {_ : C_R H H0 & {_ : ReflParam_matchR_Vec_RR0 C C₂ C_R n n₂ n_R H1 H2 & True}}})
   (retTyp : Set)
   (rett : forall n_R : Coq_Init_Datatypes_nat_RR0 n n₂,
           C_R H H0 -> ReflParam_matchR_Vec_RR0 C C₂ C_R n n₂ n_R H1 H2 -> retTyp) =>
 let n_R := projT1 sigt in
 let H3 := projT1 (projT2 sigt) in let H4 := projT1 (projT2 (projT2 sigt)) in rett n_R H3 H4)
*)

Print vcons_RR.

(*
Parametricity Recursive Vec_rect.
*)

Definition vnil_RR (C₁ C₂ : Set) (C_R : C₁ -> C₂ -> Prop) :
 Vec_RR C₁ C₂ C_R 0 0 O_RR (vnil C₁) (vnil C₂).
Proof.
  simpl. reflexivity.
Defined.

Definition vcons_RR  (C₁ C₂ : Set) (C_R : C₁ -> C₂ -> Prop) (n₁ n₂ : nat) (n_R : nat_RR n₁ n₂)
  (H : C₁) (H0 : C₂) (c_R : C_R H H0) (H1 : Vec C₁ n₁) (H2 : Vec C₂ n₂)
  (v_R : Vec_RR C₁ C₂ C_R n₁ n₂ n_R H1 H2):
  Vec_RR C₁ C₂ C_R (n₁ + 1) (n₂ + 1) (add_RR _ _ n_R 1 1 one_RR)
         (vcons C₁ n₁ H H1) (vcons C₂ n₂ H0 H2).
Proof.
  simpl.
  exists n_R. exists c_R. exists v_R. reflexivity.
Defined.

Require Import SquiggleEq.tactics.

Fixpoint Vec_rect_RR (C₁ C₂ : Set) (C_R : C₁ -> C₂ -> Prop) (P₁ : forall n : nat, Vec C₁ n -> Set)
         (P₂ : forall n : nat, Vec C₂ n -> Set)
         (P_R : forall (n₁ n₂ : nat) (n_R : nat_RR n₁ n₂)
                  (v₁ : Vec C₁ n₁) (v₂ : Vec C₂ n₂),
                Vec_RR C₁ C₂ C_R n₁ n₂ n_R v₁ v₂ -> P₁ n₁ v₁ -> P₂ n₂ v₂ -> Set)
         (f₁ : P₁ 0 (vnil C₁))
         (f₂ : P₂ 0 (vnil C₂))
       (f_R: P_R 0 0 O_RR (vnil C₁) (vnil C₂) (vnil_RR C₁ C₂ C_R) f₁ f₂)
         (f₁0 : forall (n : nat) (c : C₁) (v : Vec C₁ n),
                P₁ n v -> P₁ (n + 1) (vcons C₁ n c v))
         (f₂0 : forall (n : nat) (c : C₂) (v : Vec C₂ n),
                P₂ n v -> P₂ (n + 1) (vcons C₂ n c v))
       (f0_R: forall (n₁ n₂ : nat) (n_R : nat_RR n₁ n₂) (c₁ : C₁)
          (c₂ : C₂) (c_R : C_R c₁ c₂) (v₁ : Vec C₁ n₁) (v₂ : Vec C₂ n₂)
          (v_R : Vec_RR C₁ C₂ C_R n₁ n₂ n_R v₁ v₂) (H : P₁ n₁ v₁)
          (H0 : P₂ n₂ v₂),
        P_R n₁ n₂ n_R v₁ v₂ v_R H H0 ->
        P_R (n₁ + 1) (n₂ + 1)
          (add_RR n₁ n₂ n_R 1 1 one_RR)
          (vcons C₁ n₁ c₁ v₁) (vcons C₂ n₂ c₂ v₂)
          (vcons_RR C₁ C₂ C_R n₁ n₂ n_R c₁ c₂ c_R v₁ v₂ v_R)
          (f₁0 n₁ c₁ v₁ H) (f₂0 n₂ c₂ v₂ H0))
       (n₁ n₂ : nat) (n_R : nat_RR n₁ n₂) (v₁ : Vec C₁ n₁)
         (v₂ : Vec C₂ n₂) (v_R : Vec_RR C₁ C₂ C_R n₁ n₂ n_R v₁ v₂) {struct v₁} :
       P_R n₁ n₂ n_R v₁ v₂ v_R (Vec_rect C₁ P₁ f₁ f₁0 n₁ v₁) (Vec_rect C₂ P₂ f₂ f₂0 n₂ v₂).
Proof.
  revert v_R.
  revert n_R.
  destruct v₁;
   destruct v₂; intros.
  - simpl. clear f₁0 f₂0 f0_R. simpl in v_R. unfold vnil_RR in f_R. simpl in f_R.
    subst. assumption.
  - simpl in v_R. apply False_rect. assumption.
  - simpl in v_R. apply False_rect. assumption.
  - simpl. simpl in *. exrepnd. simpl.
    Arguments existT {A} {P} x p.
    simpl. rename v_R0 into peq.
    subst. simpl. apply f0_R.
Abort.

       (*
vcons_RR =
fun (C C₂ : Set) (C_R : C -> C₂ -> Prop) (n n₂ : nat)
  (n_R : Coq_Init_Datatypes_nat_RR0 n n₂) (H : C) (H0 : C₂) (H1 : C_R H H0)
  (H2 : Vec C n) (H3 : Vec C₂ n₂) (H4 : ReflParam_matchR_Vec_RR0 C C₂ C_R n n₂ n_R H2 H3) =>
existT n_R (existT H1 (existT H4 I))
*)

(* Notation Vec_RR := ReflParam_matchR_Vec_RR0. *)
(* Notation vcons_RR := ReflParam_matchR_Vec_RR0_paramConstr_1. *)

(*Definition vcons_RR {C₁ C₂ : Set} {C_R : C₁ -> C₂ -> Prop}
(n₁ n₂ : nat) (n_R : nat_RR n₁ n₂)
 (H : C₁) (H0 : C₂) (c_R: C_R H H0)
 (H1 : Vec C₁ n₁) (H2 : Vec C₂ n₂)
 (v_R : Vec_RR C₁ C₂ C_R n₁ n₂ n_R H1 H2):
  Vec_RR C₁ C₂ C_R (S n₁) (S n₂) (S_RR n₁ n₂ n_R)
  (vcons C₁ n₁ H H1) (vcons C₂ n₂ H0 H2) :=
  existT
  (fun n_R0 : nat_RR n₁ n₂ =>
   {_ : C_R H H0 & {_ : Vec_RR C₁ C₂ C_R n₁ n₂ n_R0 H1 H2 & True}}) n_R
  (existT (fun _ : C_R H H0 => {_ : Vec_RR C₁ C₂ C_R n₁ n₂ n_R H1 H2 & True}) c_R
     (existT (fun _ : Vec_RR C₁ C₂ C_R n₁ n₂ n_R H1 H2 => True) v_R I)).
*)
(*
Proof.
simpl. eexists; eexists; eauto.
Defined.
*)

Require Import SquiggleEq.UsefulTypes.
Fixpoint ReflParam_matchR_vAppend_RR (C₁ C₂ : Set) (C_R : C₁ -> C₂ -> Prop) (n₁ n₂ : nat)
   (n_R : nat_RR n₁ n₂) (m₁ m₂ : nat) (m_R : nat_RR m₁ m₂)
   (vl₁ : Vec C₁ n₁) (vl₂ : Vec C₂ n₂)
   (vl_R : Vec_RR C₁ C₂ C_R n₁ n₂ n_R vl₁ vl₂)
   (vr₁ : Vec C₁ m₁) (vr₂ : Vec C₂ m₂)
   (vr_R : Vec_RR C₁ C₂ C_R m₁ m₂ m_R vr₁ vr₂) {struct vl₁ }:
    Vec_RR C₁ C₂ C_R (n₁ + m₁) (n₂ + m₂) (add_RR n₁ n₂ n_R m₁ m₂ m_R)
         (vAppend vl₁ vr₁) (vAppend vl₂ vr₂).
refine (
let reT := fun n₁ vl₁ n₂ vl₂ =>
forall n_R: nat_RR n₁ n₂,
Vec_RR C₁ C₂ C_R n₁ n₂ n_R vl₁ vl₂
->
Vec_RR C₁ C₂ C_R (n₁ + m₁) (n₂ + m₂) (add_RR n₁ n₂ n_R m₁ m₂ m_R)
         (vAppend vl₁ vr₁) (vAppend vl₂ vr₂)  in
(match vl₁ in Vec _ n₁ return reT n₁ vl₁ n₂ vl₂ with
| vnil _ =>
  match vl₂ in (Vec _ n₂) return reT 0 (vnil _) n₂ vl₂ with
  | vnil _ => fun _ _ => vr_R
  | vcons _ _ _ _ => fun _ v_R => False_rect _ v_R
  end

| vcons _ n₁ hl₁ tl₁ =>
  match vl₂ in (Vec _ n₂) return reT (S n₁) (vcons _ n₁ hl₁ tl₁) n₂ vl₂ with
  | vnil _ =>  fun _ v_R => False_rect _ v_R
  | vcons _ _ hl₂ tl₂ => fun _ v_R =>
    let n_R := projT2 v_R in
    let v_R := projT2 v_R in
    let hl_R := projT1 v_R in
    let tl_R := projT1 (projT2 v_R) in
    let peq := projT2 (projT2 v_R) in
    let old := (vcons_RR _ _ C_R _ _ _ _ _ hl_R _ _
     (ReflParam_matchR_vAppend_RR _ _ _ _ _ _ _ _ _ _ _ tl_R  _ _ vr_R))
    in _
  end
end) n_R vl_R).
simpl vAppend. simpl add_RR.
rewrite peq. exact old.
Defined.

Definition Vec_rect_type :=
forall (C : Set) (P : forall n : nat, Vec C n -> Set),
       P 0 (vnil C) ->
       (forall (n : nat) (c : C) (v : Vec C n), P n v -> P (S n) (vcons C n c v)) ->
       forall (n : nat) (v : Vec C n), P n v.

Require Import SquiggleEq.tactics.

Notation vAppend_RR := ReflParam_matchR_vAppend_RR.

Print sigT_rect.

Print ReflParam_matchR_Vec_RR0.

Definition vAppend2_RR3 (C₁ C₂ : Set) (C_R : C₁ -> C₂ -> Prop) (m₁ m₂ : nat)
  (m_R : nat_RR m₁ m₂)
  (cdef₁ : C₁) (cdef₂ : C₂) (cdef_R : C_R cdef₁ cdef₂)
  (vr₁ : Vec C₁ m₁) (vr₂ : Vec C₂ m₂) (vr : Vec_RR C₁ C₂ C_R m₁ m₂ m_R vr₁ vr₂):
  C_R (vAppend2  cdef₁ vr₁) (vAppend2 cdef₂ vr₂) :=
(
let reT n1 n2 v1 v2 (* indices and values. move the _Rs to the body, as Pi args  *) :=
      forall (nr: nat_RR n1 n2)
        (vapr: Vec_RR C₁ C₂ C_R n1 n2 nr v1 v2),
     C_R match v1 with
      | vnil _ => cdef₁
      | vcons _ _ hl _ => hl
      end match v2 with
          | vnil _ => cdef₂
          | vcons _ _ hl _ => hl
          end in

(* the "as vap1" part cannot be inlined.
"vAppend vr₁ vr₁" has type "Vec C₁ (m₁ + m₁)" while vap1 has type "Vec C₁ n1"
*)
match vAppend vr₁ vr₁ as vap1 in Vec _ n1
  return reT n1 (m₂+m₂)(*prime of index of discriminee *)
      vap1 (vAppend vr₂ vr₂) (* prime of discriminee*)
with
| vnil _ =>
    match vAppend vr₂ vr₂ as vap2 in Vec _ n2
      return reT O (*index of this constr:vnil*) n2 (* from in *)
          (vnil _) vap2
      with
      | vnil _ => fun (nr : nat_RR 0 0) (_ : Vec_RR C₁ C₂ C_R 0 0 nr (vnil C₁) (vnil C₂))  => cdef_R
      | vcons _ n2 hl2 v2 =>
        fun (nr : nat_RR 0 (S n2))
          (vr0 : Vec_RR C₁ C₂ C_R 0 (S n2) nr (vnil C₁) (vcons C₂ n2 hl2 v2))
        => False_rect
            (*reT 0 (S n2) (vnil C₁) (vcons C₂ n2 hl2 v2) nr vr0 -- then strip the 2 pis*)
            _ vr0 (* always the last lambda *)
      end
| vcons _ n1 hl tl =>
    match vAppend vr₂ vr₂ as vap2 in Vec _ n2
      return reT (S n1) (*index of this constr*) n2 (* from in *)
          (vcons _ _ hl tl) vap2
      with
      | vnil _ => fun _ vr => False_rect _ vr
      | vcons _ _ hl _ => fun _ v_R =>
    let v_R := projT2 v_R in
    let hl_R := projT1 v_R in
    let tl_R := projT1 (projT2 v_R)
        in hl_R
      end

end (add_RR m₁ m₂ m_R m₁ m₂ m_R)
  (vAppend_RR _ _ _ _ _ _ _ _ vr _ _ vr)
).
Check indTransEnv.
Run TemplateProgram (genParam indTransEnv false true "vAppend2"). (* success!*)
Print vAppend2_RR.

(*
vAppend2_RR =
fun (C C₂ : Set) (C_R : C -> C₂ -> Prop) (m m₂ : nat) (m_R : nat_RR m m₂)
  (cdef : C) (cdef₂ : C₂) (cdef_R : C_R cdef cdef₂) (vr : Vec C m)
  (vr₂ : Vec C₂ m₂) (vr_R : Vec_RR C C₂ C_R m m₂ m_R vr vr₂) =>
match
  vAppend vr vr as vapx in (Vec _ n)
  return
    (forall n_R : nat_RR n (m₂ + m₂),
     Vec_RR C C₂ C_R n (m₂ + m₂) n_R vapx (vAppend vr₂ vr₂) ->
     C_R match vapx with
         | vnil _ => cdef
         | vcons _ _ hl _ => hl
         end match vAppend vr₂ vr₂ with
             | vnil _ => cdef₂
             | vcons _ _ hl₂ _ => hl₂
             end)
with
| vnil _ =>
    match
      vAppend vr₂ vr₂ as vapx₂ in (Vec _ n₂)
      return
        (forall n_R : nat_RR 0 n₂,
         Vec_RR C C₂ C_R 0 n₂ n_R (vnil C) vapx₂ ->
         C_R cdef match vapx₂ with
                  | vnil _ => cdef₂
                  | vcons _ _ hl₂ _ => hl₂
                  end)
    with
    | vnil _ =>
        fun (n_R : nat_RR 0 0) (vapx_R : Vec_RR C C₂ C_R 0 0 n_R (vnil C) (vnil C₂)) =>
        ReflParam_matchR_Vec_RR0_paramConstr_0_paramInv C C₂ C_R vapx_R
          (C_R match vnil C with
               | vnil _ => cdef
               | vcons _ _ hl _ => hl
               end match vnil C₂ with
                   | vnil _ => cdef₂
                   | vcons _ _ hl₂ _ => hl₂
                   end) cdef_R
    | vcons _ n'₂ hl₂ tl₂ =>
        fun (n_R : nat_RR 0 (S n'₂))
          (vapx_R : Vec_RR C C₂ C_R 0 (S n'₂) n_R (vnil C) (vcons C₂ n'₂ hl₂ tl₂)) =>
        False_rectt
          (C_R match vnil C with
               | vnil _ => cdef
               | vcons _ _ hl _ => hl
               end
             match vcons C₂ n'₂ hl₂ tl₂ with
             | vnil _ => cdef₂
             | vcons _ _ hl₂0 _ => hl₂0
             end) vapx_R
    end
| vcons _ n' hl tl =>
    match
      vAppend vr₂ vr₂ as vapx₂ in (Vec _ n₂)
      return
        (forall n_R : nat_RR (S n') n₂,
         Vec_RR C C₂ C_R (S n') n₂ n_R (vcons C n' hl tl) vapx₂ ->
         C_R hl match vapx₂ with
                | vnil _ => cdef₂
                | vcons _ _ hl₂ _ => hl₂
                end)
    with
    | vnil _ =>
        fun (n_R : nat_RR (S n') 0)
          (vapx_R : Vec_RR C C₂ C_R (S n') 0 n_R (vcons C n' hl tl) (vnil C₂)) =>
        False_rectt
          (C_R match vcons C n' hl tl with
               | vnil _ => cdef
               | vcons _ _ hl0 _ => hl0
               end match vnil C₂ with
                   | vnil _ => cdef₂
                   | vcons _ _ hl₂ _ => hl₂
                   end) vapx_R
    | vcons _ n'₂ hl₂ tl₂ =>
        fun (n_R : nat_RR (S n') (S n'₂))
          (vapx_R : Vec_RR C C₂ C_R (S n') (S n'₂) n_R (vcons C n' hl tl)
                      (vcons C₂ n'₂ hl₂ tl₂)) =>
        ReflParam_matchR_Vec_RR0_paramConstr_1_paramInv C C₂ C_R n' n'₂ hl hl₂ tl tl₂ vapx_R
          (C_R match vcons C n' hl tl with
               | vnil _ => cdef
               | vcons _ _ hl0 _ => hl0
               end
             match vcons C₂ n'₂ hl₂ tl₂ with
             | vnil _ => cdef₂
             | vcons _ _ hl₂0 _ => hl₂0
             end)
          (fun (n'_R : nat_RR n' n'₂) (hl_R : C_R hl hl₂)
             (_ : Vec_RR C C₂ C_R n' n'₂ n'_R tl tl₂) => hl_R)
    end
end (add_RR m m₂ m_R m m₂ m_R) (vAppend_RR m m₂ m_R m m₂ m_R vr vr₂ vr_R vr vr₂ vr_R)
     : forall (C C₂ : Set) (C_R : C -> C₂ -> Prop) (m m₂ : nat)
         (m_R : nat_RR m m₂) (cdef : C) (cdef₂ : C₂),
       C_R cdef cdef₂ ->
       forall (vr : Vec C m) (vr₂ : Vec C₂ m₂),
       Vec_RR C C₂ C_R m m₂ m_R vr vr₂ ->
       C_R match vAppend vr vr with
           | vnil _ => cdef
           | vcons _ _ hl _ => hl
           end match vAppend vr₂ vr₂ with
               | vnil _ => cdef₂
               | vcons _ _ hl₂ _ => hl₂
               end
*)


From Hammer Require Import Hammer.

Require Import Nnat ZArith_base ROmega ZArithRing Zdiv Morphisms.

Local Open Scope Z_scope.

Notation Ndiv_Zquot := N2Z.inj_quot (compat "8.3").
Notation Nmod_Zrem := N2Z.inj_rem (compat "8.3").
Notation Z_quot_rem_eq := Z.quot_rem' (compat "8.3").
Notation Zrem_lt := Z.rem_bound_abs (compat "8.3").
Notation Zquot_unique := Z.quot_unique (compat "8.3").
Notation Zrem_unique := Z.rem_unique (compat "8.3").
Notation Zrem_1_r := Z.rem_1_r (compat "8.3").
Notation Zquot_1_r := Z.quot_1_r (compat "8.3").
Notation Zrem_1_l := Z.rem_1_l (compat "8.3").
Notation Zquot_1_l := Z.quot_1_l (compat "8.3").
Notation Z_quot_same := Z.quot_same (compat "8.3").
Notation Z_quot_mult := Z.quot_mul (compat "8.3").
Notation Zquot_small := Z.quot_small (compat "8.3").
Notation Zrem_small := Z.rem_small (compat "8.3").
Notation Zquot2_quot := Zquot2_quot (compat "8.3").

Lemma Zquot_0_r a : a ÷ 0 = 0.
Proof. hammer_hook "Zquot" "Zquot.Zquot_0_r".   now destruct a. Qed.

Lemma Zrem_0_r a : Z.rem a 0 = a.
Proof. hammer_hook "Zquot" "Zquot.Zrem_0_r".   now destruct a. Qed.

Lemma Zrem_0_l a : Z.rem 0 a = 0.
Proof. hammer_hook "Zquot" "Zquot.Zrem_0_l".   now destruct a. Qed.

Lemma Zquot_0_l a : 0÷a = 0.
Proof. hammer_hook "Zquot" "Zquot.Zquot_0_l".   now destruct a. Qed.

Hint Resolve Zrem_0_l Zrem_0_r Zquot_0_l Zquot_0_r Z.quot_1_r Z.rem_1_r
: zarith.

Ltac zero_or_not a :=
destruct (Z.eq_decidable a 0) as [->|?];
[rewrite ?Zquot_0_l, ?Zrem_0_l, ?Zquot_0_r, ?Zrem_0_r;
auto with zarith|].

Lemma Z_rem_same a : Z.rem a a = 0.
Proof. hammer_hook "Zquot" "Zquot.Z_rem_same".   zero_or_not a. now apply Z.rem_same. Qed.

Lemma Z_rem_mult a b : Z.rem (a*b) b = 0.
Proof. hammer_hook "Zquot" "Zquot.Z_rem_mult".   zero_or_not b. now apply Z.rem_mul. Qed.

Theorem Zquot_opp_l a b : (-a)÷b = -(a÷b).
Proof. hammer_hook "Zquot" "Zquot.Zquot_opp_l".   zero_or_not b. now apply Z.quot_opp_l. Qed.

Theorem Zquot_opp_r a b : a÷(-b) = -(a÷b).
Proof. hammer_hook "Zquot" "Zquot.Zquot_opp_r".   zero_or_not b. now apply Z.quot_opp_r. Qed.

Theorem Zrem_opp_l a b : Z.rem (-a) b = -(Z.rem a b).
Proof. hammer_hook "Zquot" "Zquot.Zrem_opp_l".   zero_or_not b. now apply Z.rem_opp_l. Qed.

Theorem Zrem_opp_r a b : Z.rem a (-b) = Z.rem a b.
Proof. hammer_hook "Zquot" "Zquot.Zrem_opp_r".   zero_or_not b. now apply Z.rem_opp_r. Qed.

Theorem Zquot_opp_opp a b : (-a)÷(-b) = a÷b.
Proof. hammer_hook "Zquot" "Zquot.Zquot_opp_opp".   zero_or_not b. now apply Z.quot_opp_opp. Qed.

Theorem Zrem_opp_opp a b : Z.rem (-a) (-b) = -(Z.rem a b).
Proof. hammer_hook "Zquot" "Zquot.Zrem_opp_opp".   zero_or_not b. now apply Z.rem_opp_opp. Qed.

Theorem Zrem_sgn a b : 0 <= Z.sgn (Z.rem a b) * Z.sgn a.
Proof. hammer_hook "Zquot" "Zquot.Zrem_sgn".
zero_or_not b.
- apply Z.square_nonneg.
- zero_or_not (Z.rem a b).
rewrite Z.rem_sign_nz; trivial. apply Z.square_nonneg.
Qed.

Theorem Zrem_sgn2 a b : 0 <= (Z.rem a b) * a.
Proof. hammer_hook "Zquot" "Zquot.Zrem_sgn2".
zero_or_not b.
- apply Z.square_nonneg.
- now apply Z.rem_sign_mul.
Qed.

Theorem Zrem_lt_pos a b : 0<=a -> b<>0 -> 0 <= Z.rem a b < Z.abs b.
Proof. hammer_hook "Zquot" "Zquot.Zrem_lt_pos".
intros; generalize (Z.rem_nonneg a b) (Z.rem_bound_abs a b);
romega with *.
Qed.

Theorem Zrem_lt_neg a b : a<=0 -> b<>0 -> -Z.abs b < Z.rem a b <= 0.
Proof. hammer_hook "Zquot" "Zquot.Zrem_lt_neg".
intros; generalize (Z.rem_nonpos a b) (Z.rem_bound_abs a b);
romega with *.
Qed.

Theorem Zrem_lt_pos_pos a b : 0<=a -> 0<b -> 0 <= Z.rem a b < b.
Proof. hammer_hook "Zquot" "Zquot.Zrem_lt_pos_pos".
intros; generalize (Zrem_lt_pos a b); romega with *.
Qed.

Theorem Zrem_lt_pos_neg a b : 0<=a -> b<0 -> 0 <= Z.rem a b < -b.
Proof. hammer_hook "Zquot" "Zquot.Zrem_lt_pos_neg".
intros; generalize (Zrem_lt_pos a b); romega with *.
Qed.

Theorem Zrem_lt_neg_pos a b : a<=0 -> 0<b -> -b < Z.rem a b <= 0.
Proof. hammer_hook "Zquot" "Zquot.Zrem_lt_neg_pos".
intros; generalize (Zrem_lt_neg a b); romega with *.
Qed.

Theorem Zrem_lt_neg_neg a b : a<=0 -> b<0 -> b < Z.rem a b <= 0.
Proof. hammer_hook "Zquot" "Zquot.Zrem_lt_neg_neg".
intros; generalize (Zrem_lt_neg a b); romega with *.
Qed.

Definition Remainder a b r :=
(0 <= a /\ 0 <= r < Z.abs b) \/ (a <= 0 /\ -Z.abs b < r <= 0).

Definition Remainder_alt a b r :=
Z.abs r < Z.abs b /\ 0 <= r * a.

Lemma Remainder_equiv : forall a b r,
Remainder a b r <-> Remainder_alt a b r.
Proof. hammer_hook "Zquot" "Zquot.Remainder_equiv".
unfold Remainder, Remainder_alt; intuition.
- romega with *.
- romega with *.
- rewrite <-(Z.mul_opp_opp). apply Z.mul_nonneg_nonneg; romega.
- assert (0 <= Z.sgn r * Z.sgn a).
{ rewrite <-Z.sgn_mul, Z.sgn_nonneg; auto. }
destruct r; simpl Z.sgn in *; romega with *.
Qed.

Theorem Zquot_mod_unique_full a b q r :
Remainder a b r -> a = b*q + r -> q = a÷b /\ r = Z.rem a b.
Proof. hammer_hook "Zquot" "Zquot.Zquot_mod_unique_full".
destruct 1 as [(H,H0)|(H,H0)]; intros.
apply Zdiv_mod_unique with b; auto.
apply Zrem_lt_pos; auto.
romega with *.
rewrite <- H1; apply Z.quot_rem'.

rewrite <- (Z.opp_involutive a).
rewrite Zquot_opp_l, Zrem_opp_l.
generalize (Zdiv_mod_unique b (-q) (-a÷b) (-r) (Z.rem (-a) b)).
generalize (Zrem_lt_pos (-a) b).
rewrite <-Z.quot_rem', Z.mul_opp_r, <-Z.opp_add_distr, <-H1.
romega with *.
Qed.

Theorem Zquot_unique_full a b q r :
Remainder a b r -> a = b*q + r -> q = a÷b.
Proof. hammer_hook "Zquot" "Zquot.Zquot_unique_full".
intros; destruct (Zquot_mod_unique_full a b q r); auto.
Qed.

Theorem Zrem_unique_full a b q r :
Remainder a b r -> a = b*q + r -> r = Z.rem a b.
Proof. hammer_hook "Zquot" "Zquot.Zrem_unique_full".
intros; destruct (Zquot_mod_unique_full a b q r); auto.
Qed.

Lemma Z_quot_pos a b : 0 <= a -> 0 <= b -> 0 <= a÷b.
Proof. hammer_hook "Zquot" "Zquot.Z_quot_pos".   intros. zero_or_not b. apply Z.quot_pos; auto with zarith. Qed.

Lemma Z_quot_lt a b : 0 < a -> 2 <= b -> a÷b < a.
Proof. hammer_hook "Zquot" "Zquot.Z_quot_lt".   intros. apply Z.quot_lt; auto with zarith. Qed.

Lemma Z_quot_monotone a b c : 0<=c -> a<=b -> a÷c <= b÷c.
Proof. hammer_hook "Zquot" "Zquot.Z_quot_monotone".   intros. zero_or_not c. apply Z.quot_le_mono; auto with zarith. Qed.

Lemma Z_mult_quot_le a b : 0 <= a -> 0 <= b*(a÷b) <= a.
Proof. hammer_hook "Zquot" "Zquot.Z_mult_quot_le".   intros. zero_or_not b. apply Z.mul_quot_le; auto with zarith. Qed.

Lemma Z_mult_quot_ge a b : a <= 0 -> a <= b*(a÷b) <= 0.
Proof. hammer_hook "Zquot" "Zquot.Z_mult_quot_ge".   intros. zero_or_not b. apply Z.mul_quot_ge; auto with zarith. Qed.

Lemma Z_quot_exact_full a b : a = b*(a÷b) <-> Z.rem a b = 0.
Proof. hammer_hook "Zquot" "Zquot.Z_quot_exact_full".   intros. zero_or_not b. intuition. apply Z.quot_exact; auto. Qed.

Theorem Zrem_le a b : 0 <= a -> 0 <= b -> Z.rem a b <= a.
Proof. hammer_hook "Zquot" "Zquot.Zrem_le".   intros. zero_or_not b. apply Z.rem_le; auto with zarith. Qed.

Theorem Zquot_le_upper_bound:
forall a b q, 0 < b -> a <= q*b -> a÷b <= q.
Proof. hammer_hook "Zquot" "Zquot.Zquot_le_upper_bound".   intros a b q; rewrite Z.mul_comm; apply Z.quot_le_upper_bound. Qed.

Theorem Zquot_lt_upper_bound:
forall a b q, 0 <= a -> 0 < b -> a < q*b -> a÷b < q.
Proof. hammer_hook "Zquot" "Zquot.Zquot_lt_upper_bound".   intros a b q; rewrite Z.mul_comm; apply Z.quot_lt_upper_bound. Qed.

Theorem Zquot_le_lower_bound:
forall a b q, 0 < b -> q*b <= a -> q <= a÷b.
Proof. hammer_hook "Zquot" "Zquot.Zquot_le_lower_bound".   intros a b q; rewrite Z.mul_comm; apply Z.quot_le_lower_bound. Qed.

Theorem Zquot_sgn: forall a b,
0 <= Z.sgn (a÷b) * Z.sgn a * Z.sgn b.
Proof. hammer_hook "Zquot" "Zquot.Zquot_sgn".
destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith;
unfold Z.quot; simpl; destruct N.pos_div_eucl; simpl; destruct n; simpl; auto with zarith.
Qed.

Lemma Z_rem_plus : forall a b c:Z,
0 <= (a+b*c) * a ->
Z.rem (a + b * c) c = Z.rem a c.
Proof. hammer_hook "Zquot" "Zquot.Z_rem_plus".   intros. zero_or_not c. apply Z.rem_add; auto with zarith. Qed.

Lemma Z_quot_plus : forall a b c:Z,
0 <= (a+b*c) * a -> c<>0 ->
(a + b * c) ÷ c = a ÷ c + b.
Proof. hammer_hook "Zquot" "Zquot.Z_quot_plus".   intros. apply Z.quot_add; auto with zarith. Qed.

Theorem Z_quot_plus_l: forall a b c : Z,
0 <= (a*b+c)*c -> b<>0 ->
b<>0 -> (a * b + c) ÷ b = a + c ÷ b.
Proof. hammer_hook "Zquot" "Zquot.Z_quot_plus_l".   intros. apply Z.quot_add_l; auto with zarith. Qed.

Lemma Zquot_mult_cancel_r : forall a b c:Z,
c<>0 -> (a*c)÷(b*c) = a÷b.
Proof. hammer_hook "Zquot" "Zquot.Zquot_mult_cancel_r".   intros. zero_or_not b. apply Z.quot_mul_cancel_r; auto. Qed.

Lemma Zquot_mult_cancel_l : forall a b c:Z,
c<>0 -> (c*a)÷(c*b) = a÷b.
Proof. hammer_hook "Zquot" "Zquot.Zquot_mult_cancel_l".
intros. rewrite (Z.mul_comm c b). zero_or_not b.
rewrite (Z.mul_comm b c). apply Z.quot_mul_cancel_l; auto.
Qed.

Lemma Zmult_rem_distr_l: forall a b c,
Z.rem (c*a) (c*b) = c * (Z.rem a b).
Proof. hammer_hook "Zquot" "Zquot.Zmult_rem_distr_l".
intros. zero_or_not c. rewrite (Z.mul_comm c b). zero_or_not b.
rewrite (Z.mul_comm b c). apply Z.mul_rem_distr_l; auto.
Qed.

Lemma Zmult_rem_distr_r: forall a b c,
Z.rem (a*c) (b*c) = (Z.rem a b) * c.
Proof. hammer_hook "Zquot" "Zquot.Zmult_rem_distr_r".
intros. zero_or_not b. rewrite (Z.mul_comm b c). zero_or_not c.
rewrite (Z.mul_comm c b). apply Z.mul_rem_distr_r; auto.
Qed.

Theorem Zrem_rem: forall a n, Z.rem (Z.rem a n) n = Z.rem a n.
Proof. hammer_hook "Zquot" "Zquot.Zrem_rem".   intros. zero_or_not n. apply Z.rem_rem; auto. Qed.

Theorem Zmult_rem: forall a b n,
Z.rem (a * b) n = Z.rem (Z.rem a n * Z.rem b n) n.
Proof. hammer_hook "Zquot" "Zquot.Zmult_rem".   intros. zero_or_not n. apply Z.mul_rem; auto. Qed.

Theorem Zplus_rem: forall a b n,
0 <= a * b ->
Z.rem (a + b) n = Z.rem (Z.rem a n + Z.rem b n) n.
Proof. hammer_hook "Zquot" "Zquot.Zplus_rem".   intros. zero_or_not n. apply Z.add_rem; auto. Qed.

Lemma Zplus_rem_idemp_l: forall a b n,
0 <= a * b ->
Z.rem (Z.rem a n + b) n = Z.rem (a + b) n.
Proof. hammer_hook "Zquot" "Zquot.Zplus_rem_idemp_l".   intros. zero_or_not n. apply Z.add_rem_idemp_l; auto. Qed.

Lemma Zplus_rem_idemp_r: forall a b n,
0 <= a*b ->
Z.rem (b + Z.rem a n) n = Z.rem (b + a) n.
Proof. hammer_hook "Zquot" "Zquot.Zplus_rem_idemp_r".
intros. zero_or_not n. apply Z.add_rem_idemp_r; auto.
rewrite Z.mul_comm; auto.
Qed.

Lemma Zmult_rem_idemp_l: forall a b n, Z.rem (Z.rem a n * b) n = Z.rem (a * b) n.
Proof. hammer_hook "Zquot" "Zquot.Zmult_rem_idemp_l".   intros. zero_or_not n. apply Z.mul_rem_idemp_l; auto. Qed.

Lemma Zmult_rem_idemp_r: forall a b n, Z.rem (b * Z.rem a n) n = Z.rem (b * a) n.
Proof. hammer_hook "Zquot" "Zquot.Zmult_rem_idemp_r".   intros. zero_or_not n. apply Z.mul_rem_idemp_r; auto. Qed.

Lemma Zquot_Zquot : forall a b c, (a÷b)÷c = a÷(b*c).
Proof. hammer_hook "Zquot" "Zquot.Zquot_Zquot".
intros. zero_or_not b. rewrite Z.mul_comm. zero_or_not c.
rewrite Z.mul_comm. apply Z.quot_quot; auto.
Qed.

Theorem Zquot_mult_le:
forall a b c, 0<=a -> 0<=b -> 0<=c -> c*(a÷b) <= (c*a)÷b.
Proof. hammer_hook "Zquot" "Zquot.Zquot_mult_le".   intros. zero_or_not b. apply Z.quot_mul_le; auto with zarith. Qed.

Lemma Zrem_divides : forall a b,
Z.rem a b = 0 <-> exists c, a = b*c.
Proof. hammer_hook "Zquot" "Zquot.Zrem_divides".
intros. zero_or_not b. firstorder.
rewrite Z.rem_divide; trivial.
split; intros (c,Hc); exists c; subst; auto with zarith.
Qed.

Lemma Zquot2_odd_remainder : forall a,
Remainder a 2 (if Z.odd a then Z.sgn a else 0).
Proof. hammer_hook "Zquot" "Zquot.Zquot2_odd_remainder".
intros [ |p|p]. simpl.
left. simpl. auto with zarith.
left. destruct p; simpl; auto with zarith.
right. destruct p; simpl; split; now auto with zarith.
Qed.

Lemma Zrem_odd : forall a, Z.rem a 2 = if Z.odd a then Z.sgn a else 0.
Proof. hammer_hook "Zquot" "Zquot.Zrem_odd".
intros. symmetry.
apply Zrem_unique_full with (Z.quot2 a).
apply Zquot2_odd_remainder.
apply Zquot2_odd_eqn.
Qed.

Lemma Zrem_even : forall a, Z.rem a 2 = if Z.even a then 0 else Z.sgn a.
Proof. hammer_hook "Zquot" "Zquot.Zrem_even".
intros a. rewrite Zrem_odd, Zodd_even_bool. now destruct Z.even.
Qed.

Lemma Zeven_rem : forall a, Z.even a = Z.eqb (Z.rem a 2) 0.
Proof. hammer_hook "Zquot" "Zquot.Zeven_rem".
intros a. rewrite Zrem_even.
destruct a as [ |p|p]; trivial; now destruct p.
Qed.

Lemma Zodd_rem : forall a, Z.odd a = negb (Z.eqb (Z.rem a 2) 0).
Proof. hammer_hook "Zquot" "Zquot.Zodd_rem".
intros a. rewrite Zrem_odd.
destruct a as [ |p|p]; trivial; now destruct p.
Qed.

Theorem Zquotrem_Zdiv_eucl_pos : forall a b:Z, 0 <= a -> 0 < b ->
a÷b = a/b /\ Z.rem a b = a mod b.
Proof. hammer_hook "Zquot" "Zquot.Zquotrem_Zdiv_eucl_pos".
intros.
apply Zdiv_mod_unique with b.
apply Zrem_lt_pos; auto with zarith.
rewrite Z.abs_eq; auto with *; apply Z_mod_lt; auto with *.
rewrite <- Z_div_mod_eq; auto with *.
symmetry; apply Z.quot_rem; auto with *.
Qed.

Theorem Zquot_Zdiv_pos : forall a b, 0 <= a -> 0 <= b ->
a÷b = a/b.
Proof. hammer_hook "Zquot" "Zquot.Zquot_Zdiv_pos".
intros a b Ha Hb. Z.le_elim Hb.
- generalize (Zquotrem_Zdiv_eucl_pos a b Ha Hb); intuition.
- subst; now rewrite Zquot_0_r, Zdiv_0_r.
Qed.

Theorem Zrem_Zmod_pos : forall a b, 0 <= a -> 0 < b ->
Z.rem a b = a mod b.
Proof. hammer_hook "Zquot" "Zquot.Zrem_Zmod_pos".
intros a b Ha Hb; generalize (Zquotrem_Zdiv_eucl_pos a b Ha Hb);
intuition.
Qed.

Theorem Zrem_Zmod_zero : forall a b, b<>0 ->
(Z.rem a b = 0 <-> a mod b = 0).
Proof. hammer_hook "Zquot" "Zquot.Zrem_Zmod_zero".
intros.
rewrite Zrem_divides, Zmod_divides; intuition.
Qed.