Require Export PredMonad.Reflection.OrderedType.
Require Export PredMonad.Reflection.OrderedContext.
Require Import Coq.Logic.ProofIrrelevance.

Import EqNotations.
Import ListNotations.
Import ProofIrrelevanceTheory.

(***
 *** Ordered Expressions
 ***)

Inductive OVar A {RA:OTRelation A} : Ctx -> Type :=
| OVar_0 {ctx:Ctx} : OVar A (CtxCons A ctx)
| OVar_S {ctx:Ctx} {B} {RB:OTRelation B} :
    OVar A ctx -> OVar A (CtxCons B ctx)
.

Arguments OVar_0 {A RA ctx}.
Arguments OVar_S {A RA ctx B RB} v.

(* Expressions to represent proper functions *)
Inductive OExpr (ctx:Ctx) : forall A {RA:OTRelation A}, Type :=
| Var {A} {RA:OTRelation A} (v:OVar A ctx) : OExpr ctx A
| Embed {A} {RA:OTRelation A} (a:A) : OExpr ctx A
| App {A B:Type} {RA:OTRelation A} {RB:OTRelation B}
      (e1 : OExpr ctx (A -o> B)) (e2 : OExpr ctx A) : OExpr ctx B
| Lam {A B:Type} {RA:OTRelation A} {RB:OTRelation B}
      (e: OExpr (CtxCons A ctx) B) : OExpr ctx (A -o> B)
.

Arguments Var {ctx} {A RA} v.
Arguments Embed {ctx} {A RA} a.
Arguments App {ctx} {A B RA RB} e1 e2.
Arguments Lam {ctx} {A B RA RB} e.

(* An OExpr is valid iff all the types it contains are valid *)
Fixpoint ValidOExprProp {ctx A RA} (e:@OExpr ctx A RA) : Prop :=
  match e with
  | @Var _ A RA v =>
    OType A
  | @Embed _ A RA a =>
    OType A
  | @App _ A B RA RB e1 e2 =>
    (OType A /\ OType B) /\ (ValidOExprProp e1 /\ ValidOExprProp e2)
  | @Lam _ A B RA RB e =>
    OType A /\ ValidOExprProp e
  end.

(* Typeclass version of ValidOExprProp *)
Class ValidOExpr {ctx A RA} (e:@OExpr ctx A RA) : Prop :=
  validOExpr : ValidOExprProp e.

(* Type type of a ValidOExpr is an OType *)
Lemma OType_ValidOExpr {ctx A RA e} (valid:@ValidOExpr ctx A RA e) : OType A.
Proof.
  revert valid; induction e; simpl; intros; try assumption.
  - exact (proj2 (proj1 valid)).
  - destruct valid; apply OTarrow; [ | apply IHe ]; assumption.
Qed.

(* Only use OType_ValidOExpr if the ValidOExpr can be discharged trivially *)
Hint Immediate OType_ValidOExpr : typeclass_instances.

Instance ValidOExpr_Var ctx A RA (OA:OType A) v : ValidOExpr (@Var ctx A RA v).
Proof.
  assumption.
Qed.

Instance ValidOExpr_Embed ctx A RA (OA:OType A) a :
  ValidOExpr (@Embed ctx A RA a).
Proof.
  assumption.
Qed.

Instance ValidOExpr_App ctx A RA B RB (OB:OType B) e1 e2 :
  ValidOExpr e1 -> ValidOExpr e2 -> ValidOExpr (@App ctx A B RA RB e1 e2).
Proof.
  intros; split; split; eauto with typeclass_instances.
Qed.

Instance ValidOExpr_Lam ctx A RA (OA:OType A) B RB e :
  ValidOExpr e -> ValidOExpr (@Lam ctx A B RA RB e).
Proof.
  intros; split; eauto with typeclass_instances.
Qed.

(***
 *** Semantics of Ordered Expressions
 ***)

(* We need versions of proj1 and proj2 that actually compute *)
Definition proj1c {P Q:Prop} (pf:P /\ Q) : P :=
  match pf with conj pf1 _ => pf1 end.
Arguments proj1c {P Q} !pf.
Definition proj2c {P Q:Prop} (pf:P /\ Q) : Q :=
  match pf with conj _ pf2 => pf2 end.
Arguments proj2c {P Q} !pf.

(* The semantics of a variable *)
Fixpoint varSemantics {A} {RA:OTRelation A} {ctx} (v:OVar A ctx) :
  CtxElem ctx -o> A :=
  match v in OVar _ ctx return CtxElem ctx -o> A with
  | OVar_0 => snd_pfun (A:=CtxElem _)
  | OVar_S v' => compose_pfun fst_pfun (varSemantics v')
  end.
Arguments varSemantics {A RA ctx} !v.

(* The semantics of an ordered expression *)
Fixpoint exprSemantics {ctx A RA} {validC:ValidCtx ctx}
        (e:@OExpr ctx A RA) :
  forall {validE:ValidOExpr e}, CtxElem ctx -o> A :=
  match e in OExpr _ A return ValidOExpr e -> CtxElem ctx -o> A with
  | Var v => fun _ => varSemantics v
  | @Embed _ A _ a => fun (_:OType A) => const_pfun a
  | App e1 e2 =>
    fun validE =>
      pfun_apply (exprSemantics e1 (validE:=proj1c (proj2c validE)))
                 (exprSemantics e2 (validE:=proj2c (proj2c validE)))
  | Lam e =>
    fun validE =>
      pfun_curry
        (exprSemantics (ctx:=CtxCons _ _) (validC:=conj (proj1c validE) validC)
                       e (validE:=proj2c validE))
  end.
Arguments exprSemantics {ctx A RA validC} !e {validE}.

(* Lemma: the validC and validE arguments to exprSemantics are irrelevant *)
Lemma exprSemantics_irrel {ctx A RA} e validC1 validC2 validE1 validE2 :
  @exprSemantics ctx A RA validC1 e validE1
  =o= @exprSemantics ctx A RA validC2 e validE2.
Proof.
  revert validC1 validC2 validE1 validE2; induction e; intros;
    try reflexivity; simpl.
  - split; repeat intro; simpl; reflexivity.
  - f_equiv; [ apply IHe1 | apply IHe2 ].
  - f_equiv. apply IHe.
Qed.

(* FIXME: we could remove some uses of proof irrelevance below by proving that
exprSemantics does not care about its validE argument... *)

(***
 *** Relating Ordered Expressions
 ***)

(* Captures that validity of e1 implies validity of e2 *)
Definition implValid {ctx A RA} (e1 e2:@OExpr ctx A RA) : Prop :=
  ValidOExpr e1 -> ValidOExpr e2.

Instance PreOrder_implValid {ctx A RA} : PreOrder (@implValid ctx A RA).
Proof.
  split; unfold implValid.
  - intro e; intros; assumption.
  - intros e1 e2 e3 equi12 equi23 v.
    apply equi23; apply equi12; assumption.
Qed.

(* Two expressions are equi-valid iff one being valid implies the other is *)
Definition equiValid {ctx A RA} (e1 e2:@OExpr ctx A RA) : Prop :=
  ValidOExpr e1 <-> ValidOExpr e2.

Instance Equivalence_equiValid {ctx A RA} : Equivalence (@equiValid ctx A RA).
Proof.
  split; unfold equiValid.
  - intros e; reflexivity.
  - intros e1 e2 equi; symmetry; apply equi.
  - intros e1 e2 e3 equi12 equi23.
    etransitivity; [ apply equi12 | apply equi23 ].
Qed.

(* Two expressions are related iff their semantics are *)
Definition oexpr_R {ctx A RA} (e1 e2:@OExpr ctx A RA) : Prop :=
  equiValid e1 e2 /\
  forall `{ValidCtx ctx} {v1:ValidOExpr e1} {v2:ValidOExpr e2},
    exprSemantics e1 <o= exprSemantics e2.
Arguments oexpr_R {ctx A RA} e1 e2 : simpl never.

(* oexpr_R is a PreOrder *)
Instance PreOrder_oexpr_R ctx A {RA} : PreOrder (@oexpr_R ctx A RA).
Proof.
  unfold oexpr_R; split; split; intros.
  - reflexivity.
  - assert (OType A); [ typeclasses eauto | ].
    erewrite exprSemantics_irrel; reflexivity.
  - destruct H; destruct H0; transitivity y; assumption.
  - destruct H; destruct H0.
    assert (ValidOExpr y); [ apply H; assumption | ].
    transitivity (exprSemantics y); [ apply H2 | apply H3 ].
Qed.

(* Two expressions are equivalent iff their semantics are *)
Definition oexpr_eq {ctx A RA} (e1 e2:@OExpr ctx A RA) : Prop :=
  equiValid e1 e2 /\
  forall `{ValidCtx ctx} {v1:ValidOExpr e1} {v2:ValidOExpr e2},
    exprSemantics e1 =o= exprSemantics e2.
Arguments oexpr_eq {ctx A RA} e1 e2 : simpl never.

(* oexpr_eq is an Equivalence *)
Instance Equivalence_oexpr_eq ctx A {RA} : Equivalence (@oexpr_eq ctx A RA).
Proof.
  unfold oexpr_eq; split; split; intros.
  - reflexivity.
  - erewrite exprSemantics_irrel; reflexivity.
  - destruct H; symmetry; assumption.
  - destruct H; symmetry. apply H1.
  - destruct H; destruct H0; transitivity y; assumption.
  - destruct H; destruct H0.
    assert (ValidOExpr y); [ apply H; assumption | ].
    transitivity (exprSemantics y); [ apply H2 | apply H3 ].
Qed.

Notation "x <e= y" :=
  (oexpr_R x y) (no associativity, at level 70).
Notation "x =e= y" :=
  (oexpr_eq x y) (no associativity, at level 70).

(* oexpr_eq is the symmetric closure of oexpr_R *)
Lemma oexpr_R_oexpr_eq ctx A {RA} (e1 e2: @OExpr ctx A RA) :
  (e1 <e= e2 /\ e2 <e= e1) <-> e1 =e= e2.
Proof.
  split; intros; [ split | split; split ]; intros;
    destruct_ands; destruct H; try assumption.
  - destruct H1. split; [ apply H2 | apply H3 ].
  - destruct (H1 H0 v1 v2); assumption.
  - symmetry; assumption.
  - destruct (H1 H0 v2 v1); assumption.
Qed.

(* Tactic to destruct an e1 =e= e2 into an e1 <e= e2 and e2 <e= e1 *)
Ltac destruct_oexpr_eq H :=
  destruct (proj2 (oexpr_R_oexpr_eq _ _ _ _) H).

(* The Embed constructor is Proper w.r.t. ot_R and oexpr_R *)
Instance Proper_Embed ctx A RA :
  Proper (ot_R ==> oexpr_R) (@Embed ctx A RA).
Proof.
  intros a1 a2 Ra; split.
  - unfold equiValid; simpl; reflexivity.
  - intros; simpl.
    rewrite (proof_irrelevance _ v1 v2).
    apply Proper_const_pfun. assumption.
Qed.

(* The Embed constructor is Proper w.r.t. ot_equiv and oexpr_eq *)
Instance Proper_Embed_eq ctx A RA :
  Proper (ot_equiv ==> oexpr_eq) (@Embed ctx A RA).
Proof.
  intros a1 a2 Ra; split.
  - unfold equiValid; simpl; reflexivity.
  - intros; simpl.
    rewrite (proof_irrelevance _ v1 v2).
    apply Proper_const_pfun_equiv. assumption.
Qed.

(* The App constructor is Proper *)
Instance Proper_App ctx A B RA RB :
  Proper (oexpr_R ==> oexpr_R ==> oexpr_R) (@App ctx A B RA RB).
Proof.
  intros f1 f2 Rf a1 a2 Ra. destruct Rf; destruct Ra. split.
  - unfold equiValid in * |- *; simpl. rewrite H. rewrite H1. reflexivity.
  - simpl; intros. apply Proper_pfun_apply; [ apply H0 | apply H2 ].
Qed.

(* The App constructor is Proper for equivalence *)
Instance Proper_App_eq ctx {A B RA RB} :
  Proper (oexpr_eq ==> oexpr_eq ==> oexpr_eq) (@App ctx A B RA RB).
Proof.
  intros f1 f2 Rf a1 a2 Ra. destruct Rf; destruct Ra. split.
  - unfold equiValid in * |- *; simpl. rewrite H. rewrite H1. reflexivity.
  - simpl; intros. apply Proper_pfun_apply_equiv; [ apply H0 | apply H2 ].
Qed.

(* The Lam constructor is Proper *)
Instance Proper_Lam ctx {A B RA RB} :
  Proper (oexpr_R ==> oexpr_R) (@Lam ctx A B RA RB).
Proof.
  intros e1 e2 Re. destruct Re. split.
  - unfold equiValid in * |- *; simpl. rewrite H. reflexivity.
  - simpl; intros. apply Proper_pfun_curry.
    destruct v1. destruct v2. unfold proj1c. unfold proj2c.
    erewrite exprSemantics_irrel; apply H0.
    Unshelve. assumption.
Qed.

(* The Lam constructor is Proper for equivalence *)
Instance Proper_Lam_eq ctx {A B RA RB} :
  Proper (oexpr_eq ==> oexpr_eq) (@Lam ctx A B RA RB).
Proof.
  intros e1 e2 Re. destruct Re. split.
  - unfold equiValid in * |- *; simpl. rewrite H. reflexivity.
  - simpl; intros. apply Proper_pfun_curry_equiv.
    destruct v1. destruct v2. unfold proj1c. unfold proj2c.
    erewrite exprSemantics_irrel; apply H0.
    Unshelve. assumption.
Qed.

(***
 *** Weakening for Ordered Expressions
 ***)

(* Weakening / lifting of ordered expression variables *)
Fixpoint weakenOVar w W {RW:OTRelation W} :
  forall {ctx A} {RA:OTRelation A}, OVar A ctx -> OVar A (ctxInsert w W ctx) :=
  match w return
        forall ctx A {RA:OTRelation A}, OVar A ctx -> OVar A (ctxInsert w W ctx)
  with
  | 0 =>
    fun _ _ {_} v => OVar_S v
  | S w' =>
    fun ctx A {RA} v =>
      match v in OVar _ ctx return OVar A (ctxInsert (S w') W ctx) with
      | OVar_0 => OVar_0
      | OVar_S v' => OVar_S (weakenOVar w' W v')
      end
  end.

(* Correctness of weakenOVar: it is equivalent to weaken_pfun *)
Lemma weakenOVar_correct w W {RW} {OW:OType W} {ctx A RA}
      {OA:OType A} {valid:ValidCtx ctx} v :
  varSemantics (@weakenOVar w W RW ctx A RA v) =o=
  compose_pfun (weaken_pfun w W ctx) (varSemantics v).
Proof.
  revert ctx valid v; induction w; intros; [ | destruct v; destruct valid ]; simpl.
  - reflexivity.
  - rewrite compose_pair_snd. reflexivity.
  - rewrite compose_compose_pfun. rewrite compose_pair_fst.
    rewrite <- compose_compose_pfun. f_equiv. apply IHw. assumption.
Qed.

(* Weakening / lifting of ordered expressions *)
Fixpoint weakenOExpr w W {RW:OTRelation W} {ctx} {A} {RA:OTRelation A}
         (e:OExpr ctx A) : OExpr (ctxInsert w W ctx) A :=
  match e in OExpr _ A return OExpr (ctxInsert w W ctx) A with
  | Var v => Var (weakenOVar w W v)
  | Embed a => Embed a
  | App e1 e2 => App (weakenOExpr w W e1) (weakenOExpr w W e2)
  | Lam e => Lam (weakenOExpr (S w) W e)
  end.

(* A weakening is valid iff the original expr is *)
Lemma weakenOExpr_equiValid w W {RW:OTRelation W} {ctx} {A} {RA:OTRelation A}
      (e:OExpr ctx A) :
  ValidOExpr e <-> ValidOExpr (weakenOExpr w W e).
Proof.
  revert w; induction e; intros; simpl; try reflexivity.
  - rewrite IHe1. rewrite IHe2. reflexivity.
  - rewrite <- (IHe (S w)). reflexivity.
Qed.

(* Weakening preserves validity of OExprs *)
Instance ValidOExpr_weakenOExpr w W {RW:OTRelation W}
         {ctx A RA} (e:@OExpr ctx A RA) {validE:ValidOExpr e} :
  ValidOExpr (@weakenOExpr w W RW ctx A RA e).
Proof.
  apply weakenOExpr_equiValid. assumption.
Qed.

(* The above instance generally will not fire, because the implicit ctx argument
to ValidOExpr is of the form (ctxInsert w W ctx), but this will generally be
already simplified away in the goal, making it hard for Coq to match. The
following instructs Coq how to do the match by supplying the w argument. *)
Hint Extern 1 (@ValidOExpr _ _ _ (weakenOExpr _ _ _)) =>
(lazymatch goal with
 | |- ValidOExpr (weakenOExpr ?w _ _) =>
   apply (ValidOExpr_weakenOExpr w)
 end) : typeclass_instances.

(* Correctness of weakenOExpr: it is equivalent to weaken_pfun *)
Lemma weakenOExpr_correct w W {RW} {ctx A RA} (e:OExpr ctx A)
      {validC:ValidCtx ctx} {validE:ValidOExpr e}
      {validC':ValidCtx (ctxInsert w W ctx)}
      {validE':ValidOExpr (weakenOExpr w W e)} :
  exprSemantics (@weakenOExpr w W RW ctx A RA e) =o=
  compose_pfun (weaken_pfun w W ctx) (exprSemantics e).
  assert (OType W); [ apply (OType_ctxInsert w W ctx); assumption | ].
  revert w validC' validE'; induction e; intros; simpl.
  - apply weakenOVar_correct; assumption.
  - rewrite compose_f_const_pfun; try typeclasses eauto.
    split; repeat intro; rewrite H0; reflexivity.
  - destruct validE as [ [OA OB] [validE1 validE2]].
    rewrite compose_pfun_apply; try typeclasses eauto.
    f_equiv.
    + erewrite exprSemantics_irrel. apply IHe1.
    + erewrite exprSemantics_irrel. apply IHe2.
  - destruct validE as [OA validE].
    rewrite compose_pfun_curry; try typeclasses eauto. f_equiv.
    erewrite exprSemantics_irrel. apply (IHe _ _ (S w)).
    Unshelve.
    + assumption.
    + destruct validE'; destruct_ands; assumption.
    + assumption.
    + destruct validE'; destruct_ands; assumption.
    + typeclasses eauto.
    + split; assumption.
    + destruct validE'; destruct_ands; assumption.
Qed.

(* Proper-ness of weakenOExpr *)
Instance Proper_weakenOExpr w W {RW} {ctx A RA} :
  Proper (oexpr_R ==> oexpr_R) (@weakenOExpr w W RW ctx A RA).
Proof.
  intros e1 e2 Re. destruct Re; split; intros.
  - unfold equiValid. repeat rewrite <- weakenOExpr_equiValid. apply H.
  - destruct ((proj2 (ValidCtx_ctxInsert_iff w W ctx)) H1).
    assert (ValidOExpr e1); [ rewrite weakenOExpr_equiValid; apply v1 | ].
    assert (ValidOExpr e2); [ rewrite weakenOExpr_equiValid; apply v2 | ].
    rewrite weakenOExpr_correct. rewrite weakenOExpr_correct.
    rewrite H0. reflexivity.
    Unshelve.
    + assumption.
    + assumption.
    + assumption.
Qed.

(* Proper-ness of weakenOExpr *)
Instance Proper_weakenOExpr_equiv w W {RW} {ctx A RA} :
  Proper (oexpr_eq ==> oexpr_eq) (@weakenOExpr w W RW ctx A RA).
Proof.
  intros e1 e2 Re. destruct_oexpr_eq Re.
  apply oexpr_R_oexpr_eq; split; apply Proper_weakenOExpr; assumption.
Qed.

(***
 *** Substitution for Ordered Variables
 ***)

(* Substitution for ordered expression variables *)
Fixpoint substOVar n {ctx} {A} {RA:OTRelation A} :
  OVar A ctx -> OExpr (ctxSuffix n ctx) (ctxNth n ctx) ->
  OExpr (ctxDelete n ctx) A :=
  match n return
        OVar A ctx -> OExpr (ctxSuffix n ctx) (ctxNth n ctx) ->
        OExpr (ctxDelete n ctx) A
  with
  | 0 =>
    fun v =>
      match v in OVar _ ctx return
            OExpr (ctxSuffix 0 ctx) (ctxNth 0 ctx) -> OExpr (ctxDelete 0 ctx) A
      with
      | OVar_0 => fun s => s
      | OVar_S v' => fun _ => Var v'
    end
  | S n' =>
    fun v =>
      match v in OVar _ ctx return
            OExpr (ctxSuffix (S n') ctx) (ctxNth (S n') ctx) ->
            OExpr (ctxDelete (S n') ctx) A
      with
      | OVar_0 =>
        fun _ => Var OVar_0
      | @OVar_S _ _ ctx' B RB v' =>
        fun s =>
          weakenOExpr 0 B (A:=A) (substOVar n' v' s)
      end
  end.
Arguments substOVar !n {ctx A RA} !v s.

(* Correctness of substOVar: it is equivalent to subst_pfun *)
Lemma substOVar_correct n {ctx A RA} (v:OVar A ctx) s
      {validC: ValidCtx ctx} {validC': ValidCtx (ctxDelete n ctx)}
      {validE: ValidOExpr s} {validE': ValidOExpr (substOVar n v s)} :
  exprSemantics (@substOVar n ctx A RA v s) =o=
  compose_pfun (subst_pfun ctx n (exprSemantics s)) (varSemantics v).
Proof.
  revert n s validC validC' validE validE'; induction v; simpl; intros;
    destruct n; destruct_ands.
  - rewrite compose_pair_snd. apply exprSemantics_irrel.
  - rewrite compose_pair_snd. reflexivity.
  - assert (OType A) as OA; [ eauto with typeclass_instances | ].
    rewrite compose_compose_pfun. rewrite compose_pair_fst.
    rewrite id_compose_pfun. reflexivity.
  - assert (OType A) as OA; [ eauto with typeclass_instances | ].
    simpl. rewrite (weakenOExpr_correct 0). unfold weaken_pfun.
    rewrite compose_compose_pfun. rewrite compose_pair_fst.
    rewrite <- compose_compose_pfun. f_equiv. apply IHv.
    Unshelve.
    + destruct validC'. assumption.
    + simpl in validE'.
      apply (proj2 (weakenOExpr_equiValid _ _ _) validE').
Qed.

Lemma equiValid_substOVar_equiValid n {ctx A RA} (v:@OVar A RA ctx) s1 s2 :
  equiValid s1 s2 -> equiValid (substOVar n v s1) (substOVar n v s2).
  unfold equiValid.
  revert ctx v s1 s2; induction n; destruct v; intros; simpl; try reflexivity.
  + assumption.
  + repeat rewrite <- (weakenOExpr_equiValid 0 B _).
    apply (IHn ctx v s1 s2 H).
Qed.

(* If s and the type of v are valid then so is substOVar n v s *)
Instance ValidOExpr_substOVar n ctx A RA (v:@OVar A RA ctx) {OA:OType A}
         (s: OExpr _ (ctxNth n ctx)) {validS: ValidOExpr s} :
  ValidOExpr (substOVar n v s).
Proof.
  revert ctx v s validS; induction n; destruct v; intros; simpl;
    eauto with typeclass_instances.
Qed.

(* substOVar is Proper in its s argument *)
Instance Proper_substOVar n {ctx A RA} v :
  Proper (oexpr_R ==> oexpr_R) (@substOVar n ctx A RA v).
Proof.
  intros s1 s2; simpl; intro Rs. destruct Rs. split; intros.
  - apply equiValid_substOVar_equiValid. assumption.
  - revert ctx v s1 s2 H H0 H1 v1 v2; induction n; destruct v; intros;
      try reflexivity.
    + apply H0.
    + simpl. eapply (proj2 (Proper_weakenOExpr 0 B _ _ _)). Unshelve.
      split; [ apply equiValid_substOVar_equiValid; assumption | ].
      intros. apply IHn; [ assumption | ].
      intros. apply H0.
Qed.

(* substOVar is Proper w.r.t. equivalence in its s argument *)
Instance Proper_substOVar_equiv n {ctx A RA} v :
  Proper (oexpr_eq ==> oexpr_eq) (@substOVar n ctx A RA v).
Proof.
  intros s1 s2 Rs; destruct_oexpr_eq Rs; split.
  - destruct Rs; apply equiValid_substOVar_equiValid; assumption.
  - intros. split; apply Proper_substOVar; assumption.
Qed.

(***
 *** Substitution for Ordered Expressions
 ***)

(* Substitution for ordered expressions *)
Fixpoint substOExpr n {ctx} {A} {RA:OTRelation A} (e:OExpr ctx A) :
  OExpr (ctxSuffix n ctx) (ctxNth n ctx) -> OExpr (ctxDelete n ctx) A :=
  match e with
  | Var v => fun s => substOVar n v s
  | Embed a => fun _ => Embed a
  | App e1 e2 => fun s => App (substOExpr n e1 s) (substOExpr n e2 s)
  | Lam e => fun s => Lam (substOExpr (S n) e s)
  end.
Arguments substOExpr n {ctx A RA} !e.

(* Correctness of substOExpr: it is equivalent to subst_pfun *)
Lemma substOExpr_correct n {ctx A RA} (e:OExpr ctx A) s
      {validC: ValidCtx ctx} {validC': ValidCtx (ctxDelete n ctx)}
      {validE: ValidOExpr e} {validS: ValidOExpr s}
      {validE': ValidOExpr (substOExpr n e s)} :
  exprSemantics (@substOExpr n ctx A RA e s) =o=
  compose_pfun (subst_pfun ctx n (exprSemantics s)) (exprSemantics e).
Proof.
  revert n s validC validC' validE validS validE'; induction e; simpl;
    intros; destruct_ands.
  - apply substOVar_correct.
  - symmetry. rewrite compose_f_const_pfun.
    (* FIXME: prove const_pfun is proof irrelevant somewhere else! *)
    + split; intro; intros; simpl; reflexivity.
    + eauto with typeclass_instances.
  - rewrite compose_pfun_apply; eauto with typeclass_instances.
    rewrite IHe1. rewrite IHe2. reflexivity.
  - rewrite compose_pfun_curry; eauto with typeclass_instances.
    rewrite (IHe (S n)). simpl.
    repeat f_equiv. Unshelve. eauto with typeclass_instances.
Qed.

(* If both e and s are valid, then so is substOExpr e s *)
Instance ValidOExpr_substOExpr n {ctx A RA}
         (e:@OExpr ctx A RA) (s:OExpr _ (ctxNth n ctx))
         (validE:ValidOExpr e) (validS:ValidOExpr s) :
  ValidOExpr (substOExpr n e s).
Proof.
  revert n s validE validS; induction e; intros; simpl; split_ands;
    eauto with typeclass_instances.
  - destruct validE; destruct_ands; assumption.
  - apply IHe1; destruct validE; destruct_ands; assumption.
  - apply IHe2; destruct validE; destruct_ands; assumption.
  - destruct validE; destruct_ands; assumption.
  - apply (IHe (S n)); destruct validE; destruct_ands; assumption.
Qed.

(* If substOExpr e s is valid then e is, but s need not be valid if e does not
contain a free variable that s gets substituted for *)
Lemma substOExpr_ValidOExpr n {ctx A RA} (e:@OExpr ctx A RA) s
      (validE:ValidOExpr (substOExpr n e s)) : ValidOExpr e.
  revert n s validE; induction e; intros; simpl; split_ands;
    eauto with typeclass_instances.
  - destruct validE; destruct_ands.
    refine (OType_ValidOExpr (IHe2 n s _)).
  - apply (IHe1 n s). destruct validE; destruct_ands. assumption.
  - apply (IHe2 n s). destruct validE; destruct_ands. assumption.
  - destruct validE; destruct_ands. assumption.
  - destruct validE; destruct_ands. apply (IHe _ _ H0).
Qed.

(* FIXME: cannot prove this because the equiValid condition only holds when we
already know that the s arguments are valid *)
(*
Instance Proper_substOExpr n {ctx A RA} :
  Proper (oexpr_R ==> oexpr_R ==> oexpr_R) (@substOExpr n ctx A RA).
Proof.
  intros e1 e2 Re s1 s2 Rs. destruct Re. destruct Rs.
 *)

(* The Beta rule for ordered expressions *)
Lemma OExpr_Beta ctx A `{OTRelation A} B `{OTRelation B}
      (e1: OExpr (CtxCons A ctx) B) (e2: OExpr ctx A)
      {validE: ValidOExpr e2} :
  App (Lam e1) e2 =e= substOExpr 0 e1 e2.
Proof.
  split.
  - unfold equiValid. simpl.
    split; intro; split_ands; destruct_ands; eauto with typeclass_instances.
    + apply (@ValidOExpr_substOExpr 0 (@CtxCons A _ ctx)); assumption.
    + apply (substOExpr_ValidOExpr _ _ _ H1).
  - intros. simpl.
    rewrite pfun_apply_pfun_curry; eauto with typeclass_instances.
    rewrite (substOExpr_correct 0 (ctx:=CtxCons A ctx)). simpl.
    f_equiv. reflexivity.
Qed.

(***
 *** Other OExpr Rewrite Rules
 ***)

Lemma OExpr_fst_pair ctx A `{OType A} B `{OType B}
      (e1: OExpr ctx A) (e2: OExpr ctx B) {validE: ValidOExpr e2} :
  App (Embed (ofst (A:=A) (B:=B))) (App (App (Embed opair) e1) e2) =e= e1.
Proof.
  split.
  - split; simpl; intros; destruct_ands; split_ands; typeclasses eauto.
  - split; intros a1 a2 Ra; simpl; f_equiv;
      try apply exprSemantics_irrel; assumption.
Qed.

Lemma OExpr_snd_pair ctx A `{OType A} B `{OType B}
      (e1: OExpr ctx A) (e2: OExpr ctx B) {validE: ValidOExpr e1} :
  App (Embed (osnd (A:=A) (B:=B))) (App (App (Embed opair) e1) e2) =e= e2.
Proof.
  split.
  - split; simpl; intros; destruct_ands; split_ands; typeclasses eauto.
  - split; intros a1 a2 Ra; simpl; f_equiv;
      try apply exprSemantics_irrel; assumption.
Qed.

Lemma OExpr_pair_eta ctx A `{OType A} B `{OType B} (e: OExpr ctx (A*B)) :
  (App (App (Embed opair) (App (Embed ofst) e)) (App (Embed osnd) e))
  =e= e.
Proof.
  split.
  - split; simpl; intros; destruct_ands; split_ands; typeclasses eauto.
  - split; intros c1 c2 Rc; split; simpl; rewrite Rc; f_equiv; f_equiv;
      apply exprSemantics_irrel.
Qed.

Hint Rewrite OExpr_fst_pair OExpr_snd_pair OExpr_pair_eta : osimpl.
Opaque ofst osnd opair.

(***
 *** Quoting Tactic for Ordered Expressions
 ***)

(* Specially-marked versions of fst and snd just used for quoting OExprs *)
Definition celem_head {ctx A RA} (celem: CtxElem (@CtxCons A RA ctx)) : A :=
  let (_,head) := celem in head.
Definition celem_rest {ctx A RA} (celem: CtxElem (@CtxCons A RA ctx)) :
  CtxElem ctx :=
  let (rest,_) := celem in rest.

(* Typeclass for incrementally quoting functions into OExpr variables, by
peeling off the celem_rest projections one at a time and adding them as OVar_S
constructors to the input variable to build the output variable *)
Class QuotesToVar {ctx1 ctx2 A} {RA:OTRelation A}
      (f: CtxElem ctx1 -> CtxElem ctx2) (vin: OVar A ctx2)
      (vout: OVar A ctx1) : Prop :=
  quotesToVar :
    forall c, varSemantics vin @o@ (f c) = varSemantics vout @o@ c.

Instance QuotesToVar_Base {ctx A} {RA:OTRelation A} v :
  QuotesToVar (ctx1:=ctx) (fun c => c) v v.
Proof.
  intro; reflexivity.
Qed.

Instance QuotesToVar_Step {ctx1 ctx2 A B} {RA:OTRelation A} {RB:OTRelation B}
         (f: CtxElem ctx1 -> CtxElem (CtxCons B ctx2)) vin vout
         (q: QuotesToVar f (OVar_S vin) vout) :
  QuotesToVar (fun c => celem_rest (f c)) vin vout.
Proof.
  intro. apply q.
Qed.

(* Class for quoting functions to OExprs *)
Class QuotesTo {ctx A} {RA:OTRelation A}
      (f: CtxElem ctx -> A) (e: OExpr ctx A) : Prop :=
  {
    quotesToValid : ValidOExpr e;
    quotesTo : forall vc ve c,
        f c =o= exprSemantics (validC:=vc) e (validE:=ve) @o@ c
  }.

(* Logically the same as QuotesTo, but we never build lambdas in this one, i.e.,
this only builds "atomic" OExprs *)
Class QuotesToAtomic {ctx A} {RA:OTRelation A}
      (f: CtxElem ctx -> A) (e: OExpr ctx A) : Prop :=
  quotesToAtomic : QuotesTo f e.

(* Quote any term of functional type to a lambda *)
Instance QuotesTo_Lam {ctx A B} `{OType A} `{OTRelation B}
      (f: CtxElem ctx -> A -o> B) e
      (q: QuotesTo (fun c => f (celem_rest c) @o@ (celem_head c)) e) :
  QuotesTo f (Lam e) | 2.
Proof.
  split.
  - apply ValidOExpr_Lam; try assumption. apply quotesToValid.
  - assert (OType B);
      [ apply (OType_ValidOExpr (quotesToValid (QuotesTo:=q))) | ].
    intros; split; intro; intros; simpl;
      rewrite <- H2; rewrite <- (quotesTo (QuotesTo:=q)); reflexivity.
Qed.

(* Special case: quote ofuns as lambdas, destructuring the ofun *)
Instance QuotesTo_Lam_ofun {ctx A B} `{OType A} `{OTRelation B}
         (f: CtxElem ctx -> A -> B) prp e
         (q: QuotesTo (fun c => f (celem_rest c) (celem_head c)) e) :
  QuotesTo (fun c => ofun (f c) (prp:=prp c)) (Lam e) | 1.
Proof.
  apply QuotesTo_Lam. assumption.
Qed.

(* Quote any non-function term as an atomic OExpr *)
Instance QuotesTo_Atomic {ctx A} {RA:OTRelation A} (f: CtxElem ctx -> A) e
         (q: QuotesToAtomic f e) :
  QuotesTo f e | 3 := q.

(*
Ltac solve_QuotesTo :=
  first [ apply QuotesTo_Lam_ofun | apply QuotesTo_Lam | apply QuotesTo_Atomic ].

Hint Extern 1 (QuotesTo _ _) => solve_QuotesTo : typeclass_instances.
 *)

(* Quote any use of celem_head as a var *)
Instance QuotesTo_Var {ctx1 ctx2 A} `{OType A} {valid:ValidCtx ctx1}
         (f: CtxElem ctx1 -> CtxElem (CtxCons A ctx2)) v
         (q: QuotesToVar f OVar_0 v) :
  QuotesToAtomic (fun c => celem_head (f c)) (Var v) | 1.
Proof.
  split; try assumption.
  intros; rewrite <- (quotesToVar (QuotesToVar:=q)). simpl.
  destruct (f c). reflexivity.
Qed.

(* Special case for an eta-reduced celem_head application *)
Instance QuotesTo_Var0 {ctx A} `{OType A} {valid:ValidCtx ctx} :
  QuotesToAtomic (@celem_head ctx A _) (Var OVar_0) | 1.
Proof.
  split; try typeclasses eauto.
  intros. reflexivity.
Qed.

(* Quote applications as OExpr applications, where the function must still be
atomic but the argument need not  be *)
Instance QuotesTo_App {ctx A B} `{OTRelation A} `{OType B}
         (f1: CtxElem ctx -> A -o> B) (f2: CtxElem ctx -> A) e1 e2
         (q1: QuotesToAtomic f1 e1) (q2: QuotesTo f2 e2) :
  QuotesToAtomic (fun c => (f1 c) @o@ (f2 c)) (App e1 e2) | 1.
Proof.
  split.
  - simpl; split_ands; [ | assumption | apply q1 | apply q2 ].
    apply (OType_ValidOExpr (e:=e2)). apply q2.
  - intros. simpl. f_equiv.
    + apply (quotesTo (QuotesTo:=q1)).
    + apply (quotesTo (QuotesTo:=q2)).
Qed.

(* Quote ofuns in atomic position as lambdas *)
Instance QuotesToAtomic_ofun {ctx A B} `{OType A} `{OTRelation B}
         (f: CtxElem ctx -> A -> B) prp e
         (q: QuotesTo (fun c => f (celem_rest c) (celem_head c)) e) :
  QuotesToAtomic (fun c => ofun (f c) (prp:=prp c)) (Lam e) | 1.
Proof.
  apply QuotesTo_Lam. assumption.
Qed.

(* Quote objects that are independent of the context as embedded objects, but at
low priority *)
Instance QuotesTo_Embed {ctx A} `{OType A} {valid:ValidCtx ctx} (a:A) :
  QuotesToAtomic (ctx:=ctx) (fun _ => a) (Embed a) | 2.
Proof.
  split; [ assumption | ].
  intros. reflexivity.
Qed.

(* Quote pairs as applications of opair *)
Instance QuotesTo_pair {ctx A B} `{OType A} `{OType B}
         (a: CtxElem ctx -> A) (b: CtxElem ctx -> B) e1 e2
         (q1: QuotesTo a e1) (q2: QuotesTo b e2) :
  QuotesToAtomic (fun c => (a c, b c)) (App (App (Embed opair) e1) e2) | 1.
Proof.
  destruct q1. destruct q2.
  split; [ simpl; split_ands; typeclasses eauto | ].
  intros. simpl. rewrite <- quotesTo0. rewrite <- quotesTo1. reflexivity.
Qed.

(* Quote applications of fst as applications of ofst *)
Instance QuotesTo_fst {ctx A B} `{OType A} `{OType B}
         (f: CtxElem ctx -> A * B) e (q: QuotesTo f e) :
  QuotesToAtomic (fun c => fst (f c)) (App (Embed ofst) e) | 1.
Proof.
  destruct q.
  split; [ simpl; split_ands; typeclasses eauto | ].
  intros. simpl. rewrite <- quotesTo0. reflexivity.
Qed.

(* Quote applications of fst as applications of ofst *)
Instance QuotesTo_snd {ctx A B} `{OType A} `{OType B}
         (f: CtxElem ctx -> A * B) e (q: QuotesTo f e) :
  QuotesToAtomic (fun c => snd (f c)) (App (Embed osnd) e) | 1.
Proof.
  destruct q.
  split; [ simpl; split_ands; typeclasses eauto | ].
  intros. simpl. rewrite <- quotesTo0. reflexivity.
Qed.

(*
Instance QuotesTo_Lam1 {ctx A B} `{OType A} `{OType B} `{ValidCtx ctx}
         (f: CtxElem ctx -> A -> B) prp e
         (q: QuotesTo (fun c => f (celem_rest c) (celem_head c)) e) :
  QuotesTo (fun c => {| pfun_app := f c; pfun_Proper := prp c |}) (Lam e) | 1.
Proof.
  intros c; split; intros a1 a2 Ra; simpl.
  - rewrite <- (q (c, a2)). rewrite Ra. reflexivity.
  - rewrite <- (q (c, a1)). rewrite <- Ra. reflexivity.
Qed.

Instance QuotesTo_Lam2 {ctx A B} `{OType A} `{OType B} `{ValidCtx ctx}
         (f: CtxElem ctx -> A -> B) prp e
         (q: QuotesTo (fun c => f (celem_rest c) (celem_head c)) e) :
  QuotesTo (fun c => ofun (f c) (prp:=prp c)) (Lam e)| 1.
Proof.
  unfold ofun. apply QuotesTo_Lam1. assumption.
Qed.
*)

Lemma oquote_R {A} {RA:OTRelation A} {f1 f2 : A} {e1 e2: OExpr CtxNil A}
      {q1: QuotesTo (fun _ => f1) e1} {q2: QuotesTo (fun _ => f2) e2} :
  e1 <e= e2 -> f1 <o= f2.
Proof.
  intro R12.
  assert (ValidOExpr e1); [ apply q1 | ].
  assert (ValidOExpr e2); [ apply q2 | ].
  transitivity (exprSemantics e1 @o@ tt);
    [ | transitivity (exprSemantics e2 @o@ tt) ].
  - apply (quotesTo (QuotesTo:=q1)).
  - apply R12. reflexivity.
  - apply (quotesTo (QuotesTo:=q2)).
Qed.

Lemma oquote_eq {A} {RA:OTRelation A} {f1 f2 : A} {e1 e2: OExpr CtxNil A}
      {q1: QuotesTo (fun _ => f1) e1} {q2: QuotesTo (fun _ => f2) e2} :
  e1 =e= e2 -> f1 =o= f2.
Proof.
  intros eq12. rewrite <- oexpr_R_oexpr_eq in eq12. destruct eq12.
  split; apply oquote_R; assumption.
Qed.

(* Translate a problem about proper functions into one about OExprs, by
"quoting" both sides *)
Ltac oquote :=
  lazymatch goal with
  | |- ?e1 =o= ?e2 =>
    apply oquote_eq
  | |- ?e1 <o= ?e2 =>
    apply oquote_R
  end.

Ltac oexpr_simpl :=
  rewrite_strat (bottomup (choice (OExpr_Beta ; eval simpl) (hints osimpl))).

(* Translate a problem about proper functions into one about OExprs by calling
oquote, simplify both sides using the osimpl rewrite database, and then try to
use reflexivity, going back to proper functions if that does not work *)
Ltac osimpl :=
  simpl; oquote; try oexpr_simpl; try reflexivity; try typeclasses eauto; simpl.

(***
 *** Unquoting
 ***)

(* Class for unquoting OVars to functions *)
Class UnQuotesToVar {ctx A} {RA:OTRelation A}
      (v: OVar A ctx) (f: CtxElem ctx -> A) : Prop :=
  { unQuotesToVarProper : Proper (ot_R ==> ot_R) f;
    unQuotesToVar : forall c, f c = varSemantics v @o@ c }.

Instance UnQuotesToVar_Base A RA ctx :
  UnQuotesToVar (@OVar_0 A RA ctx) snd.
Proof.
  split.
  - typeclasses eauto.
  - intros; reflexivity.
Qed.

Instance UnQuotesToVar_Step A RA ctx B RB (v:OVar A ctx) f
         (q: UnQuotesToVar v f) :
  UnQuotesToVar (@OVar_S A RA ctx B RB v) (fun c => f (fst c)).
Proof.
  split.
  - intros c1 c2 Rc. apply (unQuotesToVarProper (UnQuotesToVar:=q)).
    f_equiv. assumption.
  - intros; apply q.
Qed.

(* Class for unquoting OExprs to functions *)
Class UnQuotesTo {ctx A} {RA:OTRelation A}
      (e: OExpr ctx A) (f: CtxElem ctx -> A) : Prop :=
  {
    unQuotesToValidC : ValidCtx ctx;
    unQuotesToValidE : ValidOExpr e;
    unQuotesTo : forall vc ve c,
        f c =o= exprSemantics (validC:=vc) e (validE:=ve) @o@ c
  }.

Instance UnQuotesTo_Var ctx `{ValidCtx ctx} A `{OType A} (v:OVar A ctx) f
         (q: UnQuotesToVar v f) :
  UnQuotesTo (Var v) f | 1.
Proof.
  split; [ assumption | apply H0 | ].
  intros. rewrite (unQuotesToVar (UnQuotesToVar:=q) c). reflexivity.
Qed.

Instance UnQuotesTo_Embed ctx `{ValidCtx ctx} A `{OType A} (a:A) :
  UnQuotesTo (@Embed ctx A _ a) (fun _ => a) | 1.
Proof.
  split; try assumption.
  intros. reflexivity.
Qed.

Instance UnQuotesTo_App {ctx A B} `{OTRelation A} `{OType B}
         e1 e2 (f1: CtxElem ctx -> A -o> B) (f2: CtxElem ctx -> A)
         (q1: UnQuotesTo e1 f1) (q2: UnQuotesTo e2 f2) :
  UnQuotesTo (App e1 e2) (fun c => (f1 c) @o@ (f2 c)) | 1.
Proof.
  split.
  - apply q1.
  - simpl; split_ands; [ | assumption | apply q1 | apply q2 ].
    apply (OType_ValidOExpr (e:=e2)). apply q2.
  - intros. simpl. f_equiv.
    + apply (unQuotesTo (UnQuotesTo:=q1)).
    + apply (unQuotesTo (UnQuotesTo:=q2)).
Qed.

Lemma Proper_unQuotesTo {ctx A B} `{OTRelation A} `{OTRelation B}
      {e: OExpr (CtxCons A ctx) B} {f} (q: UnQuotesTo e f) c :
  Proper (ot_R ==> ot_R) (fun a => f (c, a)).
Proof.
  intros a1 a2 Ra.
  assert (ValidOExpr e); [ apply q | ].
  destruct (unQuotesToValidC (UnQuotesTo:=q)).
  etransitivity; [ apply (unQuotesTo (UnQuotesTo:=q)) | ].
  etransitivity; [ | apply (unQuotesTo (UnQuotesTo:=q)) ].
  f_equiv. split; [ reflexivity | assumption ].
Qed.

Instance UnQuotesTo_Lam {ctx A B} `{OTRelation A} `{OTRelation B}
      (e: OExpr (CtxCons A ctx) B) f (q: UnQuotesTo e f) :
  UnQuotesTo (Lam e) (fun c =>
                        ofun (fun a => f (c, a))
                             (prp:=Proper_unQuotesTo q c)) | 1.
Proof.
  destruct (unQuotesToValidC (UnQuotesTo:=q)).
  split.
  - assumption.
  - apply ValidOExpr_Lam; apply q.
  - assert (OType B);
      [ apply (OType_ValidOExpr (unQuotesToValidE (UnQuotesTo:=q))) | ].
    intros; split; intros a1 a2 Ra; simpl.
    + etransitivity.
      -- apply (Proper_unQuotesTo q); apply Ra.
      -- apply (unQuotesTo (UnQuotesTo:=q)).
    + etransitivity.
      -- apply (unQuotesTo (UnQuotesTo:=q)).
      -- apply (Proper_unQuotesTo q); apply Ra.
Qed.

(* The above instance generally will not fire, because the implicit ctx argument
to UnQuotesTo is of the form (ctxInsert w W ctx), but this will generally be
already simplified away in the goal, making it hard for Coq to match. The
following instructs Coq how to do the match by supplying the w argument. *)
Instance UnQuotesTo_weakenOExpr {ctx A} {RA:OTRelation A} w W `{OType W}
         (e: OExpr ctx A) f (q: UnQuotesTo e f) :
  UnQuotesTo (weakenOExpr w W e) (fun c => f (weaken_pfun w W _ @o@ c)) | 1.
Proof.
  split.
  - apply ValidCtx_ctxInsert; [ assumption | apply q ].
  - apply ValidOExpr_weakenOExpr. apply q.
  - intros. rewrite weakenOExpr_correct. simpl.
    rewrite (unQuotesTo (UnQuotesTo:=q)). reflexivity.
    Unshelve.
    apply q. apply q.
Qed.

(* The above instance will generally not fire because the ctxInsert implicit
argument to UnQuotesTo will already be simplified, and so Coq will not be able
to match it; this, we make an explicit extern tactic to do the matching *)
Hint Extern 1 (@UnQuotesTo _ _ _ (weakenOExpr _ _ _) _) =>
(lazymatch goal with
 | |- UnQuotesTo (weakenOExpr ?w ?W _) _ =>
   apply (UnQuotesTo_weakenOExpr w W)
 end) : typeclass_instances.

(* This instance is meant to only apply to Coq-level variables of OExpr type *)
Instance UnQuotesTo_MetaVar {ctx A} {RA:OTRelation A} `{ValidCtx ctx}
         (e:OExpr ctx A) {validE:ValidOExpr e} :
  UnQuotesTo e (fun c => exprSemantics e @o@ c) | 2.
Proof.
  split; try assumption.
  intros. f_equiv. apply exprSemantics_irrel.
Qed.

Lemma unquote_R {ctx A} {RA:OTRelation A} {e1 e2: OExpr ctx A}
      {f1 f2 : CtxElem ctx -> A} {q1: UnQuotesTo e1 f1} {q2: UnQuotesTo e2 f2} :
  (forall c, f1 c <o= f2 c) -> e1 <e= e2.
Proof.
  intro R12.
  split; [ split; intros; try apply q1; apply q2 | ].
  intros. intros c1 c2 Rc. rewrite Rc.
  transitivity (f1 c2); [ apply (unQuotesTo (UnQuotesTo:=q1)) | ].
  transitivity (f2 c2); [ | apply (unQuotesTo (UnQuotesTo:=q2)) ].
  apply R12.
Qed.

Lemma unquote_eq {ctx A} {RA:OTRelation A} {e1 e2: OExpr ctx A}
      {f1 f2 : CtxElem ctx -> A} {q1: UnQuotesTo e1 f1} {q2: UnQuotesTo e2 f2} :
  (forall c, f1 c =o= f2 c) -> e1 =e= e2.
Proof.
  intro R12. apply oexpr_R_oexpr_eq.
  split; apply unquote_R; apply R12.
Qed.

(***
 *** Old Version of Quoting Tactic, using Ltac Directly
 ***)

(*
Tactic Notation "unify'" open_constr(t) open_constr(u) :=
  assert(t = u); [refine eq_refl|].
*)

(*
Lemma ltac_oquote_R {A RA} (e1 e2 : @OExpr CtxNil A RA) :
  e1 <e= e2 -> (exprSemantics e1) @o@ tt <o= (exprSemantics e2) @o@ tt.
Proof.
  intro R12. apply R12. reflexivity.
Qed.

Lemma ltac_oquote_eq {A RA} (e1 e2 : @OExpr CtxNil A RA) :
  e1 =e= e2 -> (exprSemantics e1) @o@ tt =o= (exprSemantics e2) @o@ tt.
Proof.
  intro equiv.
  destruct equiv; split; apply ltac_oquote_R; assumption.
Qed.

(* Quote an expression that we think corresponds to a variable *)
Ltac ltac_quote_ovar f :=
  lazymatch f with
  | (fun (celem:_) => @celem_head ?ctx ?A ?RA _) =>
    uconstr:(@OVar_0 A RA ctx)
  | (fun (celem:?ctype) => @celem_rest ?ctx ?B ?RB ?f') =>
    let qv := ltac_quote_ovar (fun (celem:ctype) => f') in
    uconstr:(@OVar_S _ _ B RB ctx qv)
  end.

(* Quote an expression-in-context, returning an OExpr that corresponds to it *)
Ltac ltac_quote_oexpr f :=
  lazymatch f with
  | (fun (celem:?ctype) => ?e1 @o@ ?e2) =>
    let q1 := ltac_quote_oexpr (fun (celem:ctype) => e1) in
    let q2 := ltac_quote_oexpr (fun (celem:ctype) => e2) in
    uconstr:(App q1 q2)
  | (fun (celem:CtxElem ?ctx) => ofun (fun (x:?A) =>?g)) =>
    let e_rec :=
        (eval simpl in
            (fun (celem':CtxElem (CtxCons A ctx)) =>
               (fun (celem:CtxElem ctx) (x:A) => g)
                 (celem_rest ctx A celem') (celem_head ctx A celem')))
    in
    let q := ltac_quote_oexpr e_rec in
    uconstr:(Lam q)
  | (fun (celem:?ctype) => celem_head _ _ _) =>
    let qv := ltac_quote_ovar f in
    uconstr:(Var qv)
  | (fun (celem:?ctype) => celem_rest _ _ _) =>
    let qv := ltac_quote_ovar f in
    uconstr:(Var qv)
  | (fun (celem:?ctype) => ?body) =>
    (* For constants, just make a fresh evar, and let the unification of the
    change tactic used later fill it in *)
    uconstr:(Embed _)
    (*
    lazymatch type of (fun (celem:ctype) => body) with
    | _ -> ?A =>
      let ename := fresh "e" in
      let res1 := evar (ename:_) in
      let e := constr:(?ename) in
      let res := unify' (fun celem => body) (fun _ => e) in
      uconstr:(Embed (ctx:=CtxNil) e)
    end
     *)
  end.

(* Quote an expression at the top level by quoting it in the empty context *)
Ltac ltac_quote_oexpr_top e :=
  ltac_quote_oexpr (fun (celem:CtxElem CtxNil) => e).

(* Translate a problem about proper functions into one about OExprs, by
"quoting" both sides *)
Ltac ltac_oquote :=
  lazymatch goal with
  | |- ?e1 =o= ?e2 =>
    let q1 := ltac_quote_oexpr_top e1 in
    let q2 := ltac_quote_oexpr_top e2 in
    (* idtac q1 "=e=" q2; *)
    apply (ltac_oquote_eq q1 q2)
  | |- ?e1 <o= ?e2 =>
    let q1 := ltac_quote_oexpr_top e1 in
    let q2 := ltac_quote_oexpr_top e2 in
    apply (ltac_oquote_R q1 q2)
  end.

(* Translate a problem about proper functions into one about OExprs by calling
oquote, simplify both sides using the osimpl rewrite database, and then try to
use reflexivity, going back to proper functions if that does not work *)
Ltac ltac_osimpl := ltac_oquote; try oexpr_simpl; try reflexivity; simpl.
*)

(***
 *** Testing the Quote Mechanism
 ***)

Module OQuoteTest.

(* A simple test case for constant terms *)
Lemma simple_quote_test A `{OType A} a : a =o= a.
  osimpl.
Qed.

(* A simple test case with all 4 OExpr constructs, that does beta-reduction *)
Lemma beta_test A `{OType A} a : (ofun (A:=A) (fun x => x)) @o@ a =o= a.
  osimpl.
Qed.

(* A test case with the first projection of a product *)
Lemma product_proj1_test A `{OType A} B `{OType B} (a:A) (b:B) :
  ofst @o@ (a ,o, b) =o= a.
  osimpl.
Qed.

(* A test case with with beta-reduction and projections + eta for products *)
Lemma beta_product_test A `{OType A} B `{OType B} (p:A*B) :
  ofun (fun p => (osnd @o@ p ,o, ofst @o@ p)) @o@ (osnd @o@ p ,o, ofst @o@ p)
  =o= p.
  (* osimpl *)
  (* NOTE: we write this out to see how long each step takes... *)
  oquote. oexpr_simpl. reflexivity. typeclasses eauto.
Qed.

Lemma double_lambda_test A `{OType A} :
  (ofun (fun (f : A -o> A) => ofun (fun x => f @o@ x))) @o@ (ofun (fun y => y))
  =o= ofun (fun x => x).
  osimpl.
Qed.

(* A test case with with beta-reduction and projections for products *)
Lemma beta_product_test2 A `{OType A} B `{OType B} :
  ofun (fun a =>
          ofun (fun b =>
                  ofun (fun p => (osnd @o@ p ,o, ofst @o@ p)) @o@ (b ,o, a)))
  =o= opair.
  (* osimpl *)
  (* NOTE: we write this out to see how long each step takes... *)
  oquote. oexpr_simpl.
  reflexivity. typeclasses eauto. typeclasses eauto.
Qed.

End OQuoteTest.


(* Author: Devendra
 *)
Require Import Coq.Lists.List.
Require Import Coq.Classes.EquivDec.
Require Import Coq.Init.Nat.
Require Import Coq.Arith.EqNat.
Require Import Coq.Arith.PeanoNat.

Require Import Coq.Program.Wf.

Notation "x :: l" := (cons x l)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Inductive term : Set :=
| var : nat -> term.
(* | fn  : nat -> term -> term. *)

(* Check fn 1 (fn 1 (var 2)). *)

Inductive form : Set :=
| eq : term -> term -> form.

(* The correctness condition *)
Inductive prf (l : list (term * term)) : term -> term -> Prop  :=
  | paxm : forall s t, In (s, t) l -> prf l s t
  | pref : forall t, prf l t t
  | psym : forall s t, prf l s t -> prf l t s
  | ptrs : forall s t u, prf l s t -> prf l t u -> prf l s u.

Check paxm [(var 2, var 3)] (var 2) (var 3).

Check psym [] (var 2) ( var 2) (pref [] (var 2) ).

Check prf.

(* computes all the subterms of a given term. *)
(* Fixpoint subterms (t : term) : list term :=
  match t with
  | var n => [var n]
  | fn n t1 => (fn n t1) :: subterms t1
  end. *)
Definition subterms (t:term) :=
  match t with
    | var n => [var n]
  end.

Print Nat.eq_dec.

(* give list of tuples of term and its parent *)
Check beq_nat. (* Importes from EqNat *)

(* Scheme Equality for term. (* screw these defs. *) *)
(* Check term_beq. *)
(* Check term_eq_dec. *)
(* Print term_eq_dec. *)

(* Define own term equality and nodup boolean version. *)
(* Reset term_beq. (* Use IDE navigation?? *) *)
Definition term_beq (a b : term) :=
  match a, b with
  | var n1, var n2 => beq_nat n1 n2
  end.

Check term_beq.
Compute term_beq (var 3) (var 4).
Check nodup.
Check in_dec.

(* Define own nodup which works with (term->term->bool) *)
Fixpoint skip {A:Type}  (f : A -> A -> bool) (e : A) (l : list A) : list A :=
  match l with
  | [] => []
  | x::xs => if f e x then skip f e xs else x :: skip f e xs
  end.

Compute length [].
Lemma skip_nonincr : forall (A:Type) (f:A->A->bool) (e:A) (l:list A) , length (skip f e l) <= length l.
Proof.
  intros. induction l as [ | h l' IHl].
  + reflexivity.
  + simpl. case (f e h) eqn:val.
    2:{
      simpl. Search (_ <= _ -> S _ <= S _).
      apply le_n_S, IHl.
      }
    1:{
      simpl. Print le. apply le_S. trivial.
      }
Qed.
(* Program Fixpoint nodupb {A:Type} (f: A -> A -> bool) (l :list A) {wf show skip is nonincreasing} : list A :=
  match l with
  | [] => []
  | x::xs => x :: nodupb f (skip f x xs)
  end. *)
Print In.

(* Fixpoint rem_el (f: A -> A -> bool) (a : A) (l : list A) := *)

Fixpoint check {A:Type} (f : A -> A -> bool) (x : A)  (acc : list A) :=
  match acc with
  | [] => false
  | y::ys => if (f x y) then true else check f x ys
  end.

Fixpoint nodup_new {A:Type} (f: A -> A -> bool) (l : list A) (acc : list A) : list A :=
 match l with
 |  [] => acc
 |  x::xs => if (check f x acc) then nodup_new f xs acc else nodup_new f xs (x::acc)
 end.

Search "nodup".

Theorem nodup_nodup: forall (l tail: list term) (a x: term),
    nodup_new (term_beq) l [] = a :: tail -> ~ In  a tail.
Proof.
  intros.
  induction l.
  + simpl in H. inversion H.
  + simpl in H.

(* Example check : term_eq_dec (var 3) (var 3). ??? *)
(* Proof.
Admitted. *)

(* Eval compute in term_eq_dec (var 2) (fn 1 (var 3)). *)
(* Eval compute in term_beq (var 2) (var 3). *)
(* Eval compute in if (term_beq (var 2) (var 2)) then 1 else 0. *)

Notation "x -=- y" := (term_beq x y)
                        (at level 60).

(* Scheme Equality for term*term. *)
Definition term_pairs_eqb (u v : term * term) :=
  match (u, v) with
  | ((a, b), (c, d)) => andb  (term_beq a c) (term_beq b d)
  end.

Compute skip term_pairs_eqb (var 3, var 4) [(var 3, var 5); (var 3, var 4); (var 1, var 3)].

(* Compute nodupb term_pairs_eqb [(var 3, var 5); (var 3, var 4); (var 1, var 3); (var 3, var 4)]. *)

Search "nodup".

Fixpoint uf_find (l : list (term*term)) (t : term) :=
  match l with
  | [] => t (*  *)
  | (x, y) :: ls => if term_beq x t then y
                    else
                      uf_find ls t
  end.

(* Fixpoint uf_find1 (l : list (term*term)) (t : term) := *)
(*   match l with *)
(*   | [] => var (1000) *)
(*   | (t, y) :: ls => y *)
(*   | _ :: ls            =>  uf_find ls t *)
(*   end. *)

Fixpoint change_rep (l : list (term * term)) (a b : term) :=
  if term_beq a b then l else
    match l with
    | [] => []
    | (x, n) :: xs => if term_beq n a then (x, b) :: change_rep xs a b
                      else
                        (x, n) :: change_rep xs a b
    end.

Definition uf_merge (l : list (term*term)) (u v : term) :=
  let a := uf_find l u in
  let b := uf_find l v in
  change_rep l a b.

Fixpoint do_cc (work ufl : list (term*term)) (bound : nat) :=
  match bound with
  | 0 => ufl
  | _ => match work with
         | [] => ufl
         | (t1, t2) :: ws => ufl end
  end.

Fixpoint do_cc1 (work ufl : list (term*term)) :=
  match work with
  | [] => ufl
  | (t1, t2) :: ws => do_cc1 ws (uf_merge ufl t1 t2)
  end.

Definition wfl' l ufl := forall c d, term_beq (uf_find ufl c) (uf_find ufl
                                                                       d) =
                                     true -> prf l c d.

Theorem main_one' : forall l ufl, (wfl' l ufl) -> wfl' l (do_cc1 l ufl).
Proof.
  intros.
  induction l.
  simpl.
  assumption.

  destruct a.
  simpl.

  unfold wfl' in H, IHl. unfold wfl'. intros.
  case (uf_find ufl c -=- uf_find ufl d) eqn: lets_try.
  apply H in lets_try. assumption.
  Admitted.

Definition wfl l ufl := forall c d, uf_find ufl c = d -> prf l c d.

Theorem main_one : forall l ufl, (wfl l ufl) -> wfl l (do_cc1 l ufl).
Proof.
  intros.
  (* unfold wfl. *)
  (* unfold wfl in H. *)
  (* intros. *)
  (* inversion in H0. *)
  (* inversion. *)

  (* induction l. *)
  unfold wfl in *.
  simpl.
 Admitted.

(*   (* unfold wfl. *) *)
(*   (* unfold wfl in H, IHl. *) *)
(*   destruct a. *)
(*   simpl. *)
(*   unfold wfl. unfold wfl in H, IHl. *)
(*   intros. *)
(*   pose (new1 := ((H t) (uf_find ufl t))). *)
(*   assert (uf_find ufl t = uf_find ufl t). *)
(*   reflexivity. *)
(*   pose (shit := (new1 H1)). *)

(*   pose (new2 := ((H t0) (uf_find ufl t0))). *)
(*   assert (uf_find ufl t0 = uf_find ufl t0). *)
(*   reflexivity. *)
(*   pose (shit1 := (new2 H2)). *)

(*   (* unfold do_cc1 in H0. *) *)
(*   (* case (uf_find ufl c) eqn: bagbose. *) *)
(*   (* case (d) eqn: mad. *) *)
(*   (* (* unfold wfl in H. *) *) *)
(*   (* unfold wfl. *) *)
(*   (* intros. *) *)
(*   (* unfold wfl in IHl. *) *)
(*   (* unfold uf_merge in H0. *) *)
(*   (* case (uf_find ufl c = d) eqn: something. *) *)
(*   (* unfold wfl. *) *)

(*   (* pose (nt := uf_find ufl t1). *) *)
(*   (* Variable xy : uf_find ufl t1. *) *)
(*   (* unfold change_rep. *) *)

(*   (* unfold uf_merge. *) *)
(*   (* unfold do_cc1. *) *)
(* admit.   *)

Fixpoint create_uf' (l : list (term*term)) :=
  match l with
  | [] => []
  | (t1, t2)::ls => (subterms t1 ++ subterms t2) ++ create_uf' ls
  end.

Print nodup_new.

Definition create_uf l := let res := nodup_new term_beq (create_uf' l) []
                          in map (fun x => (x, x)) res.

Fixpoint cc1_algo (work : list (term*term)) (t1 t2 : term) : bool :=
  (* let ufl := create_uf ((t1, t2)::work) in *)
  let ufl := create_uf (work) in
  let res := do_cc1 work ufl in
  let a  := uf_find res t1 in
  let b  := uf_find res t2 in
  term_beq a b.

Eval compute in cc1_algo [(var 1, var 2); (var 1, var 3); (var 3,var 4)] (var 2) (var 4).

Eval compute in cc1_algo [(var 1, var 2); (var 1, var 3); (var 3,var 4); (var 5, var 6)] (var 3) (var 6).

Search "nat_beq".
Check nodup.

Compute uf_find [(var 3, var 3)] (var 3).

(* Theorem cc1_sound l a b: cc1_algo l a b = true -> prf l a b. *)
(* Proof. *)
(*   intros correct. induction l as [ | hl l' Hl]. *)
(*   + simpl in correct. remember (create_uf [(a, b)]) as ufl. *)

(*     unfold create_uf in Hequfl. simpl in Hequfl. rewrite app_nil_r in Hequfl. *)
(*     destruct a as [ na ]; destruct b as [ nb ]. simpl subterms in Hequfl. *)
(*     simpl app in Hequfl. simpl nodup_new in Hequfl. case (nb =? na) eqn:mast. *)
(*     - simpl in Hequfl. Search (_=?_). *)
(*       apply beq_nat_true in mast. rewrite mast. *)
(*       apply pref. *)
(*     - simpl in Hequfl. Search (_=?_).  *)
(* (*     apply beq_nat_false in mast. Locate "<>". *) *)
(*      rewrite Hequfl in correct. simpl in correct. *)
(* (*      pose (T := beq_nat_false nb na mast). unfold not in T. *) *)
(*      pose ( Q := Nat.eqb_sym na nb). *)
(*      rewrite Q in correct. rewrite <- (beq_nat_refl nb) in correct.  *)
(*      rewrite <- (beq_nat_refl na) in correct. rewrite mast in correct. *)
(*      simpl term_beq in correct. rewrite Q in correct. rewrite mast in correct. *)
(*      discriminate. *)
(*       + case (cc1_algo l' a b) eqn: bose. *)
(*         admit. *)

(* Admitted. *)

Theorem term_beq_refl: forall a, term_beq a a  = true.
Proof.
  intros.
  case (a) eqn: fuck.
  unfold "-=-".
  Locate "=?". Search eqb _ _.
  simpl. apply Nat.eqb_refl.
Qed.

Theorem uf_find_refl: forall l a,  uf_find l a -=- uf_find l a = true.
Proof.
  intros.
  apply term_beq_refl.
Qed.

Theorem term_beq_sym: forall  a b,  term_beq a b = true ->
                                    term_beq b a = true.
Proof.
  intros.
  case a eqn: fuck.
  case b eqn: fuck1.
  simpl in H.
  simpl. Search (eqb _ _ = eqb _ _).

  rewrite Nat.eqb_sym. assumption.
Qed.

Theorem uf_find_sym: forall l a b, uf_find l a -=- uf_find l b = true
                                   ->  uf_find l b -=- uf_find l a = true.
Proof.
  intros.
  case a eqn: fuck.
  case b eqn: fuck1.
  case l eqn: fuck2.
  apply term_beq_sym. assumption.

  apply term_beq_sym. assumption.
Qed.

Theorem term_beq_trans: forall a b c,  term_beq a b = true ->
                                       term_beq b c = true ->
                                       term_beq a c = true.
Proof.
  intros.
  case a eqn: H1.
  case b eqn: H2.
  case c eqn: H3.
  simpl in *. apply beq_nat_true in H. rewrite H.
  assumption.
 (* Search Nat.eqb. *)
 (*
 apply Nat.beq_nat_eq *)
Qed.

Theorem uf_find_trans: forall l a b c, uf_find l a -=- uf_find l b
                                       = true ->
                                       uf_find l b -=- uf_find l c
                                       = true ->
                                       uf_find l a -=- uf_find l c
                                       = true.
Proof.
  intros.
  case (a) eqn: fuck.
  case (b) eqn: fuck1.
  case (c) eqn: fuck2.
  case (l) eqn: fuck3.
  apply (term_beq_trans (var n) (var n0) (var n1)).
  simpl in *. assumption.
  simpl in *. assumption.
  apply (term_beq_trans (uf_find (p :: l0) (var n))
                        (uf_find (p :: l0) (var n0))
                        (uf_find (p :: l0) (var n1))). assumption.
  assumption.
Qed.

Theorem term_eqb_eq: forall a b, a -=- b = true ->
                                 a = b.
Proof.
  intros.
  case a eqn: fuck.
  case b eqn: fuck1.
  simpl in H. apply Nat.eqb_eq in H. rewrite H. reflexivity.
Qed.

Theorem uf_implies_in_list: forall l x a, uf_find l x -=- a = true
                                          -> x -=- a = false                                                   -> In (x, a) l.
Proof.
  intros.
  induction l.
  - simpl in H. rewrite H in H0. discriminate.
  - case a0 eqn: fuck.
    simpl in H.
    case (t -=- x) eqn: fuck1.
    simpl. apply term_eqb_eq in fuck1. apply term_eqb_eq in H.
    + rewrite fuck1, H in *. left. reflexivity.
    + right. apply IHl. assumption.
Qed.

Theorem change_rep_eq: forall l x a b, In (x, a) l ->
                                       uf_find l x -=- a = true ->
                                       uf_find (change_rep l a b) x
                                               -=-  b = true.
Proof.
  intros.
  induction l. simpl in H. contradiction. simpl in H.
  (*inversion H. admit.*) destruct H.
  rewrite H. simpl. case (a -=- b) eqn: a_not_b.
  simpl. rewrite (term_beq_refl x). assumption.
  rewrite (term_beq_refl a). simpl. rewrite (term_beq_refl x).
  apply term_beq_refl.

  case a0 eqn: Anaught. simpl. case (a -=- b) eqn: ANB.
  simpl. case (t -=- x) eqn: fuck. simpl in H0.
  rewrite fuck in H0. apply (term_beq_trans t0 a b).
  assumption. assumption.

  simpl in H0. rewrite fuck in H0. apply (term_beq_trans (uf_find l x) a b). assumption. assumption.

  case (t0 -=- a) eqn: fuck. case (t -=- x) eqn: fuck1.
  simpl. rewrite fuck1. apply term_beq_refl.

  simpl. rewrite fuck1. simpl in H0. rewrite fuck1 in H0.
  apply (IHl H H0).

  simpl. case (t -=- x) eqn: fuck1. simpl in H0. rewrite fuck1 in H0.
  rewrite H0 in fuck. discriminate.

  simpl in H0. rewrite fuck1 in H0. apply (IHl H H0).
Qed.

(* Theorem uf_merge_eq': forall l x y a b, In (x, a) l -> *)
(*                                         In (y, a) l -> *)
(*                                         uf_find l x -=- a = true -> *)
(*                                         uf_find (uf_merge l a b) y *)
(*                                                 -=- b = true. *)
(* Proof. *)
(*   intros. *)
(*   induction l. *)
(*   + simpl in H. contradiction. *)
(*   + simpl in H, H0. *)
(*     inversion H. *)
(*     inversion H0. admit.  *)

Definition ufl_wf (l : list (term*term)) := forall x y, In (x, y) l ->
                                                        In (y, y) l.

Definition ufl_wf' (l : list (term*term)) := forall x y, uf_find l x -=- y = true ->
                                                        uf_find l y -=- y = true.

Theorem in_monotonic : forall (l: list (term*term))
                              (x: term) (a: term)
                              (a0: term*term),
    In (x, a) l -> In (x, a) (a0 :: l).
Proof.
  intros.
  simpl.
  right. assumption.
Qed.

Theorem uf_merge_eq': forall l x a b, ufl_wf' l ->
                                      In (x, a) l ->
                                      uf_find l x -=- a = true ->
                                      uf_find (uf_merge l a b) x -=-
                                            uf_find l b
                                      = true.
Proof.
  intros.
  induction l.
  + simpl in H0. contradiction.
  + simpl in H0. destruct H0. unfold uf_merge.
  - rewrite H0. simpl. case (x -=- a) eqn: fuck.
    case (x -=- b) eqn: fuck1. pose (fuck2 := term_beq_refl a).
    rewrite fuck2. simpl. pose (fuck3 := term_beq_refl x).
    rewrite fuck3. assumption.

    case (a -=- uf_find l b) eqn: fuck2.
    simpl. pose (fuck3 := term_beq_refl x). rewrite fuck3.
    assumption.
    *  pose (fuck3 := term_beq_refl a).
       rewrite fuck3. simpl.

    pose (fuck4 := term_beq_refl x). rewrite fuck4.
    apply term_beq_refl.

    * admit.

  - unfold uf_merge. apply change_rep_eq.
    pose (fuck5 := (in_monotonic l x a a0 H0)).
    unfold ufl_wf' in H. pose (fuck6 := (H x a H1)).
    apply term_eqb_eq in fuck6. rewrite fuck6.
    assumption.

     unfold ufl_wf' in H. pose (fuck6 := (H x a H1)).
     apply term_eqb_eq in fuck6. rewrite fuck6.
     assumption.
Admitted.

(* Theorem uf_merge_eq: forall l x a b, In (x, a) l -> *)
(*                                      In (y, b) l -> *)
(*                                      uf_find l x -=- a = true -> *)
(*                                      uf_find (uf_merge l a b) x -=- *)
(*                                              b *)
(*                                      = true. *)
(* Proof. *)
(*   intros. *)
(*   induction l. *)
(*   + simpl in H. contradiction. *)
(*   + simpl in H. destruct H. unfold uf_merge. *)
(*   case l eqn: H1. *)
(*   case x eqn: H2. *)
(*   case a eqn: H3. *)
(*   case b eqn: H4. *)
(*   simpl in H. rewrite H in *. (*simpl.*) *)
(*   - admit. *)
(*   - admit. *)
(*   - unfold uf_merge. *)
(*     apply change_rep_eq with (l := (a0 :: l) *)
(*                                    (x := x) *)
(*                                    (a := (uf_find (a0 :: l) a)) *)
(*                                    (b := (uf_find (a0 :: l) b))). *)

(*     Abort. *)
  (* unfold uf_merge. *)
  (* simpl. simpl in H. apply beq_nat_true in H. *)
  (* rewrite H. case (n0 =? n1) eqn: doit. admit. simpl in H. simpl. admit. Admitted. *)

Theorem cc1_mon: forall work x y a b, cc1_algo work a b = true ->
                                      cc1_algo ((x, y) :: work) a b = true.
Proof.
  intros.

  induction work.

  {simpl. simpl in H. apply term_eqb_eq in H.
   rewrite H.
   unfold cc1_algo. apply uf_find_refl. }

  { destruct a0. simpl. case x eqn: fuck1.
    case y eqn: fuck2. unfold create_uf. simpl.
    case (n0 =? n) eqn: fuck3. simpl. admit. admit.}

Admitted.

Theorem cc1_head: forall work a b, cc1_algo ((a, b) :: work) a b = true.
Proof.
  intros.
  simpl.
  case (a) eqn: fuck1.
  case (b) eqn: fuck2. simpl.

Admitted.

Theorem do_cc1_mon: forall work l x y,
    uf_find l x -=- uf_find l y = true ->
    uf_find (do_cc1 work l) x -=-
         uf_find (do_cc1 work l) y
    = true.
Proof.
  intros.
  induction work.
  - simpl. assumption.

  - destruct a. simpl.
Abort.

Theorem do_cc1_inv: forall work l x y,
    uf_find l x -=- uf_find l y = true ->
    uf_find (do_cc1 work l) x -=- uf_find (do_cc1 work l) y = true.
Proof.
  intros.
  induction work.
  { simpl. assumption. }
  { destruct a. simpl. induction l.
    + simpl. destruct t, t0. unfold uf_merge.
      simpl. case (n =? n0). assumption. assumption.

    +
  simpl in H. admit.
Abort.

Theorem do_cc1_rewrite: forall work a l,
    do_cc1 (a :: work) l = do_cc1 [a] (do_cc1 work l).
Proof.
  intros. destruct a.
  induction l.
  simpl. unfold uf_merge. simpl. case (t -=- t0).

Theorem do_cc1_mon_aux: forall work l x y
  t t0,
    uf_find (do_cc1 work l) x -=-
            uf_find (do_cc1 work l) y
    = true ->

    uf_find (do_cc1 work (uf_merge l t t0))
            x -=- uf_find (do_cc1 work (uf_merge l t t0)) y = true.
Proof.
  intros.
  induction l as [ | a l'].
  { unfold uf_merge. simpl.
    case (t -=- t0). assumption.
    assumption. }

  { destruct a. unfold uf_merge.
    simpl.  unfold uf_merge. simpl.

Theorem cc1_In: forall work a b, In (a, b) work ->
                                 cc1_algo work a b = true.
Proof.
  intros.
  (* unfold cc1_algo. *)
  case (a) eqn: fuck.
  case (b) eqn: fuck1.
  induction work as [ | a0 work']. simpl in H. contradiction.
  case (a0) eqn: fuck3.

  simpl in H. destruct H.
  { rewrite H. apply cc1_head. }
  { apply cc1_mon. apply IHwork'. assumption. }
Qed.

Theorem cc1_refl: forall work a, cc1_algo work a a = true.
Proof.
  intros.
  case a eqn: fuck.
  case work eqn: fuck2.
  simpl.
  apply Nat.eqb_refl.
  (* apply uf_find_refl. *)

  simpl. apply uf_find_refl.
Qed.

Theorem cc1_sym: forall work a b, cc1_algo work a b = true ->
                                  cc1_algo work b a = true.
Proof.
  intros.
  unfold cc1_algo in *.
  case (a) eqn: fuck.
  case (b) eqn: fuck1.
  case (work) eqn: fuck2.
  apply uf_find_sym. assumption.
  apply uf_find_sym. assumption.
Qed.

Theorem cc1_trans: forall work a b c, cc1_algo work a b = true ->
                                      cc1_algo work b c = true ->
                                      cc1_algo work a c = true.
Proof.
  intros.
  unfold cc1_algo in *.
  case (a) eqn: fuck.
  case (b) eqn: fuck1.
  case (c) eqn: fuck2.
  case (work) eqn: fuck3.

  apply (uf_find_trans
           (do_cc1 [] (create_uf [])) (var n)
           (var n0) (var n1)). assumption. assumption.

  apply (uf_find_trans
           (do_cc1 (p :: l) (create_uf (p :: l))) (var n)
           (var n0) (var n1)).
  assumption. assumption.
Qed.

Theorem cc1_complete work a b: prf work a b -> cc1_algo work a b = true.
Proof.
(*   intros proof. inversion proof. *)
(*   + admit. (* In the list case*) *)
(*   + admit. (* case of reflexivity *) *)
(*   +  *)
(*   + *)
  (* Admitted. *)

  intros. induction H.
  + apply cc1_In. assumption. (* case: in the list *)
  + apply cc1_refl. (* case: refl *)
  + apply cc1_sym. assumption. (* case: sym of cc algo *)
  + apply (cc1_trans work s t u). (* case: trans of cc algo *)
    assumption.
    assumption.
Qed.

Fixpoint create_uf' (l : list (term*term)) :=
  match l with
  | [] => []
  | (t1, t2)::ls => (subterms t1 ++ subterms t2) ++ create_uf' ls
  end.

Check nodup_new.

Definition create_uf l := let res := nodup_new term_eq_dec  (create_uf' l)
                          in map (fun x => (x, x)) res.

Check fold_left.

Definition create_parents l :=
  let lis := fold_left (fun x y => x ++ y) (map parent_list1 l) []
  in map (fun x => (x, get_parents1 x lis)) l.

Definition cc_algo (l : list (term*term)) (a b : term) :=
  (* do the merging *)
  let res := 1 in
  let t1  := uf_find l a in
  let t2  := uf_find l b in
  term_beq t1 t2.


Require Import Axiom_ProofIrrelevance.
Require Import Category.
Require Import Category2.

(* given a Category we define the data necessary to create a Category2 *)

Inductive Obj (A:Type) (c: Category A) : Type :=
    obj : forall a:A, source c a = a -> Obj A c.

Arguments Obj {A} _.
Arguments obj {A} {c} _ _.

Definition mor (A:Type) (c: Category A) (x: Obj c) : A :=
    match x with
    | obj a _     => a
    end.

Arguments mor {A} {c} _.

Lemma Obj_inversion : forall (A:Type) (c: Category A) (x y:A)
(px : source c x = x) (py: source c y= y),
    obj x px = obj y py -> x = y.
Proof.
    intros A c x y px py H.
    assert (x = mor (obj x px)) as Hx. { reflexivity. }
    assert (y = mor (obj y py)) as Hy. { reflexivity. }
    rewrite Hx, Hy, H. reflexivity.
Qed.

Lemma eq_Obj : forall (A:Type) (c:Category A) (x y: Obj c),
    mor x = mor y -> x = y.
Proof.
    intros A c x y H. destruct x as [x' px], y as [y' py]. simpl in H.
    revert px. rewrite H. intros px. rewrite (proof_irrelevance _ px py).
    reflexivity.
Qed.

Definition toObject (A:Type) (c:Category A) (a:A) : source c a = a -> Obj c :=
    obj a.

Arguments toObject {A} {c} {a} _.

(* by providing the proof that source (source f) = source f
   we are able to cast 'source f' as an object              *)
Definition dom_ (A:Type) (c:Category A) (f:A) : Obj c :=
    toObject (proof_ss c f).

(* by providing the proof that source (target f) = target f
   we are able to cast 'target f' as an object              *)
Definition cod_ (A:Type) (c:Category A) (f:A) : Obj c :=
    toObject (proof_st c f).

Definition compose2_ (A:Type) (c:Category A) (f g:A) : option A := compose c f g.

(* An element of Obj c is effectively a triplet consisting of
   a predicate, a value, and a proof that the value satisfies
   the predicate. We simply return the value                  *)
Definition id_ (A:Type) (c:Category A) (a : Obj c) : A :=
    match a with
    | obj f _   => f
    end.

Arguments dom_ {A} _ _.
Arguments cod_ {A} _ _.
Arguments compose2_ {A} _ _ _.
Arguments id_ {A} _ _.

Definition proof_sid_ (A:Type) (c:Category A) : forall a:Obj c,
    dom_ c (id_ c a) = a.
Proof. intros a. destruct a. apply eq_Obj. simpl. exact e. Qed.

Definition proof_tid_ (A:Type) (c:Category A) : forall a:Obj c,
    cod_ c (id_ c a) = a.
Proof.
    intros a. destruct a as [a p].
    apply eq_Obj. simpl.
    assert (target c (source c a) = target c a) as H . { rewrite p. reflexivity. }
    rewrite (proof_ts c a) in H. rewrite <- H. exact p.
Qed.

Definition proof_dom2_ (A:Type) (c:Category A) : forall f g: A,
    cod_ c f = dom_ c g <-> compose2_ c f g <> None.
Proof.
    intros f g. split.
    - intros H. apply (proof_dom c). apply Obj_inversion in H. exact H.
    - intros H. apply eq_Obj. simpl. apply (proof_dom c). exact H.
Qed.

Definition proof_src2_ (A:Type) (c:Category A) : forall f g h: A,
    compose2_ c f g = Some h -> dom_ c h = dom_ c f.
Proof.
    intros f g h H.
    apply eq_Obj. apply (proof_src c) with (g:=g). exact H.
Qed.

Definition proof_tgt2_ (A:Type) (c:Category A) : forall f g h: A,
    compose2_ c f g = Some h -> cod_ c h = cod_ c g.
Proof.
    intros f g h H.
    apply eq_Obj. apply (proof_tgt c) with (f:=f). exact H.
Qed.

Definition proof_idl2_ (A:Type) (c:Category A) : forall (a:Obj c) (f:A),
    a = dom_ c f -> compose2_ c (id_ c a) f = Some f.
Proof.
    intros a f H. apply (proof_idl c).
    destruct a as [a p]. apply Obj_inversion in H. exact H.
Qed.

Definition proof_idr2_ (A:Type) (c:Category A) : forall (a:Obj c) (f:A),
    a = cod_ c f -> compose2_ c f (id_ c a) = Some f.
Proof.
    intros a f H. apply (proof_idr c).
    destruct a as [a p]. apply Obj_inversion in H. exact H.
Qed.

Definition proof_asc2_ (A:Type) (c:Category A) : forall f g h fg gh:A,
    compose2_ c f g = Some fg ->
    compose2_ c g h = Some gh ->
    compose2_ c f gh = compose2_ c fg h.
Proof.
    intros f g h fg gh H1 H2. apply (proof_asc c) with (g:=g).
    exact H1. exact H2.
Qed.

Definition toCategory2 (A:Type) (c:Category A) : Category2 (Obj c) A := category2
    (dom_               c)
    (cod_               c)
    (compose2_          c)
    (id_                c)
    (proof_sid_     A   c)
    (proof_tid_     A   c)
    (proof_dom2_    A   c)
    (proof_src2_    A   c)
    (proof_tgt2_    A   c)
    (proof_idl2_    A   c)
    (proof_idr2_    A   c)
    (proof_asc2_    A   c).

Arguments toCategory2 {A} _.


Module Type Nums.
 Parameter NumType : Set.
 Parameter mult : NumType -> NumType -> NumType.
 Parameter div : NumType -> NumType -> NumType.
 Parameter add : NumType -> NumType -> NumType.
 Parameter minus : NumType -> NumType -> NumType.

 Parameter PI : NumType.
 Parameter natToNum : (nat -> NumType).
End Nums.

(*
The nat implementation of everything we need.
*)
Module Nats <: Nums.
  Import Nat.
  Definition NumType := nat.
  Definition add := Nat.add.
  Fixpoint minus (x y : nat) :=
  match (x,y) with
    | (_,0) => x
    | (0,_) => 0
    | (S x', S y') => minus x' y'
  end.
  Eval compute in (minus 5 2).
  Definition mult := Nat.mul.
  Definition div := Nat.div.
  Definition PI := 3.

Definition natToNum := fun x : nat => x.
End Nats.


(**

   Some handy facts and definitions for lists.

*)

Require Import Lists.List.

Set Implicit Arguments.

Fixpoint take (A : Type) (n : nat) (xs : list A) : list A :=
  match n with
  | O => nil
  | S k =>
    match xs with
    | nil => nil
    | cons x xs' => cons x (take k xs')
    end
  end.

Lemma take_nil (A : Type) n
  : take n (nil (A := A)) = nil.
Proof.
  induction n; auto.
Qed.

Lemma in_take (A : Type) n x (xs : list A)
  : In x (take n xs) -> In x xs.
Proof.
  revert xs; induction n as [ | n IH ]; [ contradiction | ]; intro xs.
  destruct xs as [ | a xs ]; auto.
  simpl. destruct 1; auto.
Qed.

Lemma map_take (A B : Type) (f : A -> B) n xs
  : map f (take n xs) = take n (map f xs).
Proof.
  revert n; induction xs as [ | x xs IH ];
    intro n; [ rewrite !take_nil; auto | ].
  destruct n; auto.
  simpl; apply f_equal; auto.
Qed.

Lemma take_take (A : Type) n m (xs : list A)
  : take n (take m xs) = take (min n m) xs.
Proof.
  revert xs m; induction n as [ | n IH ]; auto; intros xs m.
  destruct m; auto.
  destruct xs; auto.
  simpl; apply f_equal; auto.
Qed.

Lemma take_length (A : Type) (xs : list A)
  : take (length xs) xs = xs.
Proof.
  induction xs; simpl; auto using f_equal.
Qed.

Lemma map_fst_combine (A B : Type) (xs : list A) (ys : list B)
  : map fst (combine xs ys) = take (min (length xs) (length ys)) xs.
Proof.
  revert ys; induction xs as [ | x xs IH ]; auto; intro ys.
  destruct ys as [ | y ys ]; auto.
  simpl; apply f_equal; auto.
Qed.

Lemma map_snd_combine (A B : Type) (xs : list A) (ys : list B)
  : map snd (combine xs ys) = take (min (length xs) (length ys)) ys.
Proof.
  revert ys; induction xs as [ | x xs IH ]; auto; intro ys.
  destruct ys as [ | y ys ]; auto.
  simpl; apply f_equal; auto.
Qed.


Section EnClase.

Inductive Arbol_bin(A:Set):Set :=
    arbol_nil
  | node: Arbol_bin A -> A -> Arbol_bin A -> Arbol_bin A.

Inductive isomorfismo(A:Set):Arbol_bin A -> Arbol_bin A -> Prop :=
    isomorfismo0 : isomorfismo A (arbol_nil A) (arbol_nil A)
  | isomorfismoS : forall (t1 t2 t1' t2':Arbol_bin A) (a b : A), isomorfismo A t1 t1' -> isomorfismo A t2 t2' -> isomorfismo A (node A t1 a t2) (node A t1' b t2').

Lemma unlema:forall (A:Set) (t1 t2 t3:Arbol_bin A), isomorfismo A t1 t2 -> isomorfismo A t2 t3 -> isomorfismo A t1 t3.
Proof.
  induction t1; intros.
    inversion_clear H in H0.
    assumption.

    inversion_clear H in H0.
    inversion_clear  H0.
    constructor.
      exact((IHt1_1 t1' t1'0) H1 H). (* el "->" NO tiene un constructor? *)

      exact((IHt1_2 t2' t2'0) H2 H3).
Qed.

(*forall (x: nat)(H : Even x), e0 <> ess x H.*)

Inductive Even : nat -> Prop :=
  | e0 : Even 0
  | eSS : forall n:nat, Even n -> Even (S (S n)).

Check Even 1 = Even 0.

Theorem t: forall x:nat, Even (x) <-> x=0 \/ exists y:nat, (x = (S (S y)) /\ Even (y)).
Proof.
  unfold iff; intros; split.
    intro.
    induction H.
      left; reflexivity.
      elim IHEven; intro; clear IHEven.
        right.
        rewrite H0.
        exists 0.
        split; [reflexivity | constructor].

        elim H0; intros.
        elim H1; intros; clear H1.
        right.
        exists (S (S x)).
        rewrite H2.
        split; [reflexivity | constructor; assumption].

    intro.
    elim H; intro; clear H.
    rewrite H0; constructor.
    elim H0; intros; clear H0.
    elim H; intros; clear H.
    rewrite H0; constructor; assumption.
Qed.

End EnClase.

Print and.

Theorem tt : forall (A B:Prop), and A B -> A.
Proof.
  intros.
  induction H.
  assumption.
Qed.


Require Import Morphisms Setoid RelationClasses.
Require Import Utf8.
Add LoadPath "../../theories" as CatQ.
From CatQ.Structures Require Import Setoids Category Morphism.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Set Universe Polymorphism.

Class Is_Functor
      (fdom fcod : Category)
      (fobj : fdom → fcod)
      (fmorphism : forall {a b}, @morphism fdom a b -⇒ @morphism fcod (fobj a) (fobj b)) :=
  {
    fmorphism_identity : forall {a}, fmorphism (@identity fdom a) == @identity fcod (fobj a);
    fmorphism_compose : forall {a b c} {f : a ⟶ b} {g : b ⟶ c}, fmorphism (compose (g,f)) == compose (fmorphism g, fmorphism f);
  }.

Structure Functor (fdom fcod : Category) :=
  {
    fobj :> fdom → fcod;
    fmorphism : forall {a b}, @morphism fdom a b -⇒ @morphism fcod (fobj a) (fobj b);
    is_functor :> Is_Functor (@fmorphism);
  }.
Existing Instance is_functor.

Notation "[fmorphism: fa 'with' fo 'as' C 'to' D 'by' prf ]" := (@Build_Functor C D fo fa prf).
Notation "[fmorphism: fa 'with' fo 'as' C 'to' D ]" := [fmorphism: fa with fo as C to D by _].
Notation "[fmorphism: fa 'with' fo ]" := [fmorphism: fa with fo as _ to _ ].
Notation "[fmorphism: fa ]" := [fmorphism: fa with _ as _ to _ ].

Definition fmap {C D : Category} (F : Functor C D) :
  forall {a b}, hom a b → hom (fobj F a) (fobj F b) := fun _ _ => fmorphism F.

Lemma fmap_identity {C D : Category} (F : Functor C D) :
  forall {a}, fmap F (@identity C a) == @identity D (F a).
Proof.
  unfold fmap. intro.
  apply fmorphism_identity.
Defined.

Lemma fmap_compose {C D : Category} (F : Functor C D) :
  forall {a b c} {g : b ⟶ c} {f : a ⟶ b}, fmap F (g ∘ f) == fmap F g ∘ fmap F f.
Proof.
  unfold fmap. intros.
  apply fmorphism_compose.
Defined.

Lemma fmap_proper {C D : Category} (F : Functor C D) {a b : C} :
  Proper (@equality _ ==> @equality _) (fmap F (a:=a) (b:=b)).
Proof.
  solve_proper.
Defined.

Section Section_Functor_Type.
  Structure Functor_Type (fdom fcod : Category) :=
    {
      funct_obj : fdom → fcod;
      funct_map : forall {a b}, hom a b → hom (funct_obj a) (funct_obj b);
      funct_map_proper : forall {a b}, Proper ((@equality _) ==> (@equality _)) (@funct_map a b);
      funct_identity : forall {a}, funct_map (@identity fdom a) == @identity fcod (funct_obj a);
      funct_compose : forall {a b c} {f : hom a b} {g : hom b c}, funct_map (g ∘ f) == funct_map g ∘ funct_map f;
    }.

  Program Definition to_Functor : forall {C D}, Functor_Type C D → Functor C D :=
    fun C D ftype =>
      [fmorphism: fun _ _ => [mapoid: funct_map ftype by funct_map_proper ftype] with funct_obj ftype].
  Next Obligation.
    apply Build_Is_Functor.
    - simpl. intro.
      apply funct_identity.
    - simpl. intros.
      apply funct_compose.
  Defined.

  Program Definition to_Functor_Type : forall {C D}, Functor C D → Functor_Type C D :=
    fun C D functor =>
      {|
        funct_obj := fobj functor;
        funct_map := fun _ _ => fmap functor;
        funct_map_proper := fun _ _ => is_mapoid (fmorphism functor);
      |}.
  Next Obligation.
    apply fmorphism_identity.
  Defined.
  Next Obligation.
    apply fmorphism_compose.
  Defined.
End Section_Functor_Type.

Notation "[fmap: fa 'with' fo 'by' prf1 , prf2 , prf3 ]" := (to_Functor (@Build_Functor_Type _ _ fo fa prf1 prf2 prf3)).
Notation "[fmap: fa 'with' fo 'as' C 'to' D ]" := (to_Functor (@Build_Functor_Type C D fo fa _ _ _)).
Notation "[fmap: fa 'with' fo ]" := [fmap: fa with fo as _ to _ ].

Lemma fmap_of_fmap {C D} {fo : object C → object D} {fa : forall a b, hom a b → hom (fo a) (fo b)} {prf1 prf2 prf3} : forall {a b} (f : a ⟶ b), fmap [fmap: fa with fo by prf1,prf2,prf3] f = fa _ _ f.
Proof.
  auto.
Qed.

Program Definition idFunctor {C : Category} : Functor C C :=
  [fmap: fun _ _ f => f with fun a => a as C to C].
Next Obligation.
  solve_proper.
Defined.
Next Obligation.
  reflexivity.
Defined.
Next Obligation.
  reflexivity.
Defined.

Program Definition compFunctor {C D E : Category} (G : Functor D E) (F : Functor C D) : Functor C E :=
  [fmap: fun _ _ f => fmap G (fmap F f) with fun a => fobj G (fobj F a)].
Next Obligation.
  solve_proper.
Defined.
Next Obligation.
  setoid_rewrite fmorphism_identity.
  setoid_rewrite fmorphism_identity.
  reflexivity.
Defined.
Next Obligation.
  setoid_rewrite fmorphism_compose.
  setoid_rewrite fmorphism_compose.
  reflexivity.
Defined.

Notation "F ∘f G" := (compFunctor F G) (at level 40).

Lemma compFunctor_compose {C D E} (G : Functor D E) (F : Functor C D) {a b} (f : a ⟶ b) :
  fmap (G ∘f F) f == fmap G (fmap F f).
Proof.
  reflexivity.
Qed.

Definition full {C D : Category} (F : Functor C D) : Prop := forall {a b}, surj (@fmorphism C D F a b).
Definition faithful {C D : Category} (F : Functor C D) : Prop := forall {a b}, inj (@fmorphism C D F a b).

(* ff = iso on hom *)
Definition ff {C D : Category} (F : Functor C D) : Type
  := forall {a b}, (morphism a b) ≃ (morphism (F a) (F b)) in Setoids.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id$ i*)

(** * Normalisation functions for rational numbers. *)

Require Export Znumtheory.
Require Export Zgcd_old.
Require Export QArith_base.

(** First, a function that (tries to) build a positive back from a Z. *)

Definition Z2P (z : Z) :=
  match z with
  | Z0 => 1%positive
  | Zpos p => p
  | Zneg p => p
  end.

Lemma Z2P_correct : forall z : Z, (0 < z)%Z -> Zpos (Z2P z) = z.
Proof.
 simple destruct z; simpl in |- *; auto; intros; discriminate.
Qed.

Lemma Z2P_correct2 : forall z : Z, 0%Z <> z -> Zpos (Z2P z) = Zabs z.
Proof.
 simple destruct z; simpl in |- *; auto; intros; elim H; auto.
Qed.

(** A simple cancelation by powers of two *)

Fixpoint Pfactor_twos (p p':positive) {struct p} : (positive*positive) :=
 match p, p' with
  | xO p, xO p' => Pfactor_twos p p'
  | _, _ => (p,p')
 end.

Definition Qfactor_twos (q:Q) :=
 let (p,q) := q in
 match p with
   | Z0 => 0
   | Zpos p => let (p,q) := Pfactor_twos p q in (Zpos p)#q
   | Zneg p => let (p,q) := Pfactor_twos p q in (Zneg p)#q
 end.

Lemma Pfactor_twos_correct : forall p p',
   (p*(snd (Pfactor_twos p p')))%positive =
   (p'*(fst (Pfactor_twos p p')))%positive.
Proof.
induction p; intros.
simpl snd; simpl fst; rewrite Pmult_comm; auto.
destruct p'.
simpl snd; simpl fst; rewrite Pmult_comm; auto.
simpl; f_equal; auto.
simpl snd; simpl fst; rewrite Pmult_comm; auto.
simpl snd; simpl fst; rewrite Pmult_comm; auto.
Qed.

Lemma Qfactor_twos_correct : forall q, Qfactor_twos q == q.
Proof.
intros (p,q).
destruct p.
red; simpl; auto.
simpl.
generalize (Pfactor_twos_correct p q); destruct (Pfactor_twos p q).
red; simpl.
intros; f_equal.
rewrite H; apply Pmult_comm.
simpl.
generalize (Pfactor_twos_correct p q); destruct (Pfactor_twos p q).
red; simpl.
intros; f_equal.
rewrite H; apply Pmult_comm.
Qed.
Hint Resolve Qfactor_twos_correct.

(** Simplification of fractions using [Zgcd].
  This version can compute within Coq. *)

Definition Qred (q:Q) :=
  let (q1,q2) := Qfactor_twos q in
  let (r1,r2) := snd (Zggcd q1 (Zpos q2)) in r1#(Z2P r2).

Lemma Qred_correct : forall q, (Qred q) == q.
Proof.
intros; apply Qeq_trans with (Qfactor_twos q); auto.
unfold Qred.
destruct (Qfactor_twos q) as (n,d); red; simpl.
generalize (Zggcd_gcd n ('d)) (Zgcd_is_pos n ('d))
  (Zgcd_is_gcd n ('d)) (Zggcd_correct_divisors n ('d)).
destruct (Zggcd n (Zpos d)) as (g,(nn,dd)); simpl.
Open Scope Z_scope.
intuition.
rewrite <- H in H0,H1; clear H.
rewrite H3; rewrite H4.
assert (0 <> g).
  intro; subst g; discriminate.

assert (0 < dd).
  apply Zmult_gt_0_lt_0_reg_r with g.
  omega.
  rewrite Zmult_comm.
  rewrite <- H4; compute; auto.
rewrite Z2P_correct; auto.
ring.
Qed.

Lemma Qred_complete : forall p q,  p==q -> Qred p = Qred q.
Proof.
intros.
assert (Qfactor_twos p == Qfactor_twos q).
 apply Qeq_trans with p; auto.
 apply Qeq_trans with q; auto.
 symmetry; auto.
clear H.
unfold Qred.
destruct (Qfactor_twos p) as (a,b);
destruct (Qfactor_twos q) as (c,d); clear p q.
unfold Qeq in *; simpl in *.
Open Scope Z_scope.
generalize (Zggcd_gcd a ('b)) (Zgcd_is_gcd a ('b))
 (Zgcd_is_pos a ('b)) (Zggcd_correct_divisors a ('b)).
destruct (Zggcd a (Zpos b)) as (g,(aa,bb)).
generalize (Zggcd_gcd c ('d)) (Zgcd_is_gcd c ('d))
 (Zgcd_is_pos c ('d)) (Zggcd_correct_divisors c ('d)).
destruct (Zggcd c (Zpos d)) as (g',(cc,dd)).
simpl.
intro H; rewrite <- H; clear H.
intros Hg'1 Hg'2 (Hg'3,Hg'4).
intro H; rewrite <- H; clear H.
intros Hg1 Hg2 (Hg3,Hg4).
intros.
assert (g <> 0).
  intro; subst g; discriminate.
assert (g' <> 0).
  intro; subst g'; discriminate.
elim (rel_prime_cross_prod aa bb cc dd).
congruence.
unfold rel_prime in |- *.
(*rel_prime*)
constructor.
exists aa; auto with zarith.
exists bb; auto with zarith.
intros.
inversion Hg1.
destruct (H6 (g*x)).
rewrite Hg3.
destruct H2 as (xa,Hxa); exists xa; rewrite Hxa; ring.
rewrite Hg4.
destruct H3 as (xb,Hxb); exists xb; rewrite Hxb; ring.
exists q.
apply Zmult_reg_l with g; auto.
pattern g at 1; rewrite H7; ring.
(* /rel_prime *)
unfold rel_prime in |- *.
(* rel_prime *)
constructor.
exists cc; auto with zarith.
exists dd; auto with zarith.
intros.
inversion Hg'1.
destruct (H6 (g'*x)).
rewrite Hg'3.
destruct H2 as (xc,Hxc); exists xc; rewrite Hxc; ring.
rewrite Hg'4.
destruct H3 as (xd,Hxd); exists xd; rewrite Hxd; ring.
exists q.
apply Zmult_reg_l with g'; auto.
pattern g' at 1; rewrite H7; ring.
(* /rel_prime *)
assert (0<bb); [|auto with zarith].
  apply Zmult_gt_0_lt_0_reg_r with g.
  omega.
  rewrite Zmult_comm.
  rewrite <- Hg4; compute; auto.
assert (0<dd); [|auto with zarith].
  apply Zmult_gt_0_lt_0_reg_r with g'.
  omega.
  rewrite Zmult_comm.
  rewrite <- Hg'4; compute; auto.
apply Zmult_reg_l with (g'*g).
intro H2; elim (Zmult_integral _ _ H2); auto.
replace (g'*g*(aa*dd)) with ((g*aa)*(g'*dd)); [|ring].
replace (g'*g*(bb*cc)) with ((g'*cc)*(g*bb)); [|ring].
rewrite <- Hg3; rewrite <- Hg4; rewrite <- Hg'3; rewrite <- Hg'4; auto.
Open Scope Q_scope.
Qed.

Add Morphism Qred : Qred_comp.
Proof.
intros q q' H.
rewrite (Qred_correct q); auto.
rewrite (Qred_correct q'); auto.
Qed.

(** Another version, dedicated to extraction *)

Definition Qred_extr (q : Q) :=
  let (q1, q2) := Qfactor_twos q in
  let (p,_) := Zggcd_spec_pos (Zpos q2) (Zle_0_pos q2) q1 in
  let (r2,r1) := snd p in r1#(Z2P r2).

Lemma Qred_extr_Qred : forall q, Qred_extr q = Qred q.
Proof.
unfold Qred, Qred_extr.
intro q; destruct (Qfactor_twos q) as (n,p); clear q.
Open Scope Z_scope.
destruct (Zggcd_spec_pos (' p) (Zle_0_pos p) n) as ((g,(pp,nn)),H).
generalize (H (Zle_0_pos p)); clear H; intros (Hg1,(Hg2,(Hg4,Hg3))).
simpl.
generalize (Zggcd_gcd n ('p)) (Zgcd_is_gcd n ('p))
 (Zgcd_is_pos n ('p)) (Zggcd_correct_divisors n ('p)).
destruct (Zggcd n (Zpos p)) as (g',(nn',pp')); simpl.
intro H; rewrite <- H; clear H.
intros Hg'1 Hg'2 (Hg'3,Hg'4).
assert (g<>0).
 intro; subst g; discriminate.
destruct (Zis_gcd_uniqueness_apart_sign n ('p) g g'); auto.
apply Zis_gcd_sym; auto.
subst g'.
f_equal.
apply Zmult_reg_l with g; auto; congruence.
f_equal.
apply Zmult_reg_l with g; auto; congruence.
elimtype False; omega.
Open Scope Q_scope.
Qed.

Add Morphism Qred_extr : Qred_extr_comp.
Proof.
intros q q' H.
do 2 rewrite Qred_extr_Qred.
rewrite (Qred_correct q); auto.
rewrite (Qred_correct q'); auto.
Qed.

Definition Qplus' (p q : Q) := Qred (Qplus p q).
Definition Qmult' (p q : Q) := Qred (Qmult p q).

Lemma Qplus'_correct : forall p q : Q, (Qplus' p q)==(Qplus p q).
Proof.
intros; unfold Qplus' in |- *; apply Qred_correct; auto.
Qed.

Lemma Qmult'_correct : forall p q : Q, (Qmult' p q)==(Qmult p q).
Proof.
intros; unfold Qmult' in |- *; apply Qred_correct; auto.
Qed.

Add Morphism Qplus' : Qplus'_comp.
Proof.
intros; unfold Qplus' in |- *.
rewrite H; rewrite H0; auto with qarith.
Qed.

Add Morphism Qmult' : Qmult'_comp.
intros; unfold Qmult' in |- *.
rewrite H; rewrite H0; auto with qarith.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Local Open Scope Z_scope.

Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Arithmetic.Saturated.Core.
Require Import Crypto.Arithmetic.Saturated.UniformWeight.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.CPS.
Require Import Crypto.Util.ZUtil.AddGetCarry.
Require Import Crypto.Util.Tuple Crypto.Util.LetIn.
Require Import Crypto.Util.Tactics.BreakMatch.
Local Notation "A ^ n" := (tuple A n) : type_scope.

Module B.
  Module Positional.
    Section Positional.
      Context {s:Z} {s_pos : 0 < s}. (* s is bitwidth *)
      Let small {n} := @small s n.
      Section GenericOp.
        Context {op : Z -> Z -> Z}
                {op_get_carry_cps : forall {T}, Z -> Z -> (Z * Z -> T) -> T} (* no carry in, carry out *)
                {op_with_carry_cps : forall {T}, Z -> Z -> Z -> (Z * Z -> T) -> T}. (* carry in, carry out  *)
        Let op_get_carry x y := op_get_carry_cps _ x y id.
        Let op_with_carry x y z := op_with_carry_cps _ x y z id.
        Context {op_get_carry_id : forall {T} x y f,
                    @op_get_carry_cps T x y f = f (op_get_carry x y)}
                {op_with_carry_id : forall {T} x y z f,
                    @op_with_carry_cps T x y z f = f (op_with_carry x y z)}.
        Hint Rewrite @op_get_carry_id @op_with_carry_id : uncps.

        Section chain_op'_cps.
          Context (T : Type).

          Fixpoint chain_op'_cps {n} (c:option Z) (p q:Z^n)
            : (Z*Z^n->T)->T :=
            match n return option Z -> Z^n -> Z^n -> (Z*Z^n -> T) -> T with
            | O => fun c p _ f =>
                     let carry := match c with | None => 0 | Some x => x end in
                     f (carry,p)
            | S n' =>
              fun c p q f =>
                (* for the first call, use op_get_carry, then op_with_carry *)
                let op'_cps := match c with
                           | None => op_get_carry_cps _
                           | Some x => op_with_carry_cps _ x end in
                op'_cps (hd p) (hd q) (fun carry_result =>
                dlet carry_result := carry_result in
                  chain_op'_cps (Some (snd carry_result)) (tl p) (tl q)
                                (fun carry_pq =>
                                   f (fst carry_pq,
                                      append (fst carry_result) (snd carry_pq))))
            end c p q.
        End chain_op'_cps.
        Definition chain_op' {n} c p q := @chain_op'_cps _ n c p q id.
        Definition chain_op_cps {n} p q {T} f := @chain_op'_cps T n None p q f.
        Definition chain_op {n} p q : Z * Z^n := chain_op_cps p q id.

        Lemma chain_op'_id {n} : forall c p q T f,
          @chain_op'_cps T n c p q f = f (chain_op' c p q).
        Proof.
          cbv [chain_op']; induction n; intros; destruct c;
            simpl chain_op'_cps; cbv [Let_In]; try reflexivity;
              autorewrite with uncps.
          { etransitivity; rewrite IHn; reflexivity. }
          { etransitivity; rewrite IHn; reflexivity. }
        Qed.

        Lemma chain_op_id {n} p q T f :
          @chain_op_cps n p q T f = f (chain_op p q).
        Proof. apply (@chain_op'_id n None). Qed.
      End GenericOp.
      Hint Opaque chain_op chain_op' : uncps.
      Hint Rewrite @chain_op_id @chain_op'_id using (assumption || (intros; autorewrite with uncps; reflexivity)) : uncps.

      Section AddSub.
        Create HintDb divmod discriminated.
        Hint Rewrite
             Z.add_get_carry_full_mod
             Z.add_get_carry_full_div
             Z.add_with_get_carry_full_mod
             Z.add_with_get_carry_full_div
             Z.sub_get_borrow_full_mod
             Z.sub_get_borrow_full_div
             Z.sub_with_get_borrow_full_mod
             Z.sub_with_get_borrow_full_div
          : divmod.
        Let eval {n} := B.Positional.eval (n:=n) (uweight s).

        Definition sat_add_cps {n} p q T (f:Z*Z^n->T) :=
          chain_op_cps (op_get_carry_cps := fun T => Z.add_get_carry_full_cps s)
                       (op_with_carry_cps := fun T => Z.add_with_get_carry_full_cps s)
                       p q f.
        Definition sat_add {n} p q := @sat_add_cps n p q _ id.

        Lemma sat_add_id n p q T f :
          @sat_add_cps n p q T f = f (sat_add p q).
        Proof. cbv [sat_add sat_add_cps]. autorewrite with uncps. reflexivity. Qed.

        Lemma sat_add_mod_step n c d :
          c mod s + s * ((d + c / s) mod (uweight s n))
          = (s * d + c) mod (s * uweight s n).
        Proof.
          assert (0 < uweight s n) as wt_pos
              by auto using Z.lt_gt, Z.gt_lt, uweight_positive.
          rewrite <-(Columns.compact_mod_step s (uweight s n) c d s_pos wt_pos).
          repeat (ring_simplify; f_equal; ring_simplify; try omega).
        Qed.

        Lemma sat_add_div_step n c d :
          (d + c / s) / uweight s n =  (s * d + c) / (s * uweight s n).
        Proof.
          assert (0 < uweight s n) as wt_pos
              by auto using Z.lt_gt, Z.gt_lt, uweight_positive.
          rewrite <-(Columns.compact_div_step s (uweight s n) c d s_pos wt_pos).
          repeat (ring_simplify; f_equal; ring_simplify; try omega).
        Qed.

        Lemma sat_add_divmod n p q :
          eval (snd (@sat_add n p q)) = (eval p + eval q) mod (uweight s n)
          /\ fst (@sat_add n p q) = (eval p + eval q) / (uweight s n).
        Proof.
          cbv [sat_add sat_add_cps chain_op_cps].
          remember None as c.
          replace (eval p + eval q) with
          (eval p + eval q + match c with | None => 0 | Some x => x end)
            by (subst; ring).
          destruct Heqc. revert c.
          induction n; [|destruct c]; intros; simpl chain_op'_cps;
          repeat match goal with
                 | _ => progress cbv [eval Let_In] in *
                 | _ => progress autorewrite with uncps divmod push_id cancel_pair push_basesystem_eval
                 | _ => rewrite uweight_0, ?Z.mod_1_r, ?Z.div_1_r
                 | _ => rewrite uweight_succ
                 | _ => rewrite Z.sub_opp_r
                 | _ => rewrite sat_add_mod_step
                 | _ => rewrite sat_add_div_step
                 | p : Z ^ 0 |- _ => destruct p
                 | _ => rewrite uweight_eval_step, ?hd_append, ?tl_append
                 | |- context[B.Positional.eval _ (snd (chain_op' ?c ?p ?q))]
                   => specialize (IHn p q c); autorewrite with push_id uncps in IHn;
                   rewrite (proj1 IHn); rewrite (proj2 IHn)
                 | _ => split; ring
                 | _ => solve [split; repeat (f_equal; ring_simplify; try omega)]
                 end.
        Qed.

        Lemma sat_add_mod n p q :
          eval (snd (@sat_add n p q)) = (eval p + eval q) mod (uweight s n).
        Proof. exact (proj1 (sat_add_divmod n p q)). Qed.

        Lemma sat_add_div n p q :
          fst (@sat_add n p q) = (eval p + eval q) / (uweight s n).
        Proof. exact (proj2 (sat_add_divmod n p q)). Qed.

        Lemma small_sat_add n p q : small (snd (@sat_add n p q)).
        Proof.
          cbv [small UniformWeight.small sat_add sat_add_cps chain_op_cps].
          remember None as c. destruct Heqc. revert c.
          induction n; intros;
            repeat match goal with
                   | p: Z^0 |- _ => destruct p
                   | _ => progress (cbv [Let_In] in * )
                   | _ => progress (simpl chain_op'_cps in * )
                   | _ => progress autorewrite with uncps push_id cancel_pair in H
                   | H : _ |- _ => rewrite to_list_append in H;
                                     simpl In in H
                   | H : _ \/ _ |- _ => destruct H
                   | _ => contradiction
                   | _ => break_innermost_match_hyps_step
                   | _ => progress subst
                   | [ H : In _ (to_list _ (snd _)) |- _ ]
                     => apply IHn in H; assumption
                   end;
            try solve [ rewrite ?Z.add_with_get_carry_full_mod,
                        ?Z.add_get_carry_full_mod;
                        apply Z.mod_pos_bound; omega ].
       Qed.

        Definition sat_sub_cps {n} p q T (f:Z*Z^n->T) :=
          chain_op_cps (op_get_carry_cps := fun T => Z.sub_get_borrow_full_cps s)
                       (op_with_carry_cps := fun T => Z.sub_with_get_borrow_full_cps s)
                       p q f.
        Definition sat_sub {n} p q := @sat_sub_cps n p q _ id.

        Lemma sat_sub_id n p q T f :
          @sat_sub_cps n p q T f = f (sat_sub p q).
        Proof. cbv [sat_sub sat_sub_cps]. autorewrite with uncps. reflexivity. Qed.
        Lemma sat_sub_divmod n p q :
          eval (snd (@sat_sub n p q)) = (eval p - eval q) mod (uweight s n)
          /\ fst (@sat_sub n p q) = - ((eval p - eval q) / (uweight s n)).
        Proof.
          cbv [sat_sub sat_sub_cps chain_op_cps].
          remember None as c.
          replace (eval p - eval q) with
          (eval p - eval q - match c with | None => 0 | Some x => x end)
            by (subst; ring).
          destruct Heqc. revert c.
          induction n; [|destruct c]; intros; simpl chain_op'_cps;
          repeat match goal with
                 | _ => progress cbv [eval Let_In] in *
                 | _ => progress autorewrite with uncps divmod push_id cancel_pair push_basesystem_eval
                 | _ => rewrite uweight_0, ?Z.mod_1_r, ?Z.div_1_r
                 | _ => rewrite uweight_succ
                 | _ => rewrite Z.sub_opp_r
                 | _ => rewrite sat_add_mod_step
                 | _ => rewrite sat_add_div_step
                 | p : Z ^ 0 |- _ => destruct p
                 | _ => rewrite uweight_eval_step, ?hd_append, ?tl_append
                 | |- context[B.Positional.eval _ (snd (chain_op' ?c ?p ?q))]
                   => specialize (IHn p q c); autorewrite with push_id uncps in IHn;
                   rewrite (proj1 IHn); rewrite (proj2 IHn)
                 | _ => split; ring
                 | _ => solve [split; repeat (f_equal; ring_simplify; try omega)]
                 end.
        Qed.

        Lemma sat_sub_mod n p q :
          eval (snd (@sat_sub n p q)) = (eval p - eval q) mod (uweight s n).
        Proof. exact (proj1 (sat_sub_divmod n p q)). Qed.

        Lemma sat_sub_div n p q :
          fst (@sat_sub n p q) = - ((eval p - eval q) / uweight s n).
        Proof. exact (proj2 (sat_sub_divmod n p q)). Qed.

        Lemma small_sat_sub n p q : small (snd (@sat_sub n p q)).
        Proof.
          cbv [small UniformWeight.small sat_sub sat_sub_cps chain_op_cps].
          remember None as c. destruct Heqc. revert c.
          induction n; intros;
            repeat match goal with
                   | p: Z^0 |- _ => destruct p
                   | _ => progress (cbv [Let_In] in * )
                   | _ => progress (simpl chain_op'_cps in * )
                   | _ => progress autorewrite with uncps push_id cancel_pair in H
                   | H : _ |- _ => rewrite to_list_append in H;
                                     simpl In in H
                   | H : _ \/ _ |- _ => destruct H
                   | _ => contradiction
                   | _ => break_innermost_match_hyps_step
                   | _ => progress subst
                   | [ H : In _ (to_list _ (snd _)) |- _ ]
                     => apply IHn in H; assumption
                   end;
            try solve [ rewrite ?Z.sub_with_get_borrow_full_mod,
                        ?Z.sub_get_borrow_full_mod;
                        apply Z.mod_pos_bound; omega ].
        Qed.
      End AddSub.
    End Positional.
  End Positional.
End B.
Hint Opaque B.Positional.sat_sub B.Positional.sat_add B.Positional.chain_op B.Positional.chain_op' : uncps.
Hint Rewrite @B.Positional.sat_sub_id @B.Positional.sat_add_id : uncps.
Hint Rewrite @B.Positional.chain_op_id @B.Positional.chain_op' using (assumption || (intros; autorewrite with uncps; reflexivity)) : uncps.
Hint Rewrite @B.Positional.sat_sub_mod @B.Positional.sat_sub_div @B.Positional.sat_add_mod @B.Positional.sat_add_div using (omega || assumption) : push_basesystem_eval.

Hint Unfold
     B.Positional.chain_op'_cps
     B.Positional.chain_op'
     B.Positional.chain_op_cps
     B.Positional.chain_op
     B.Positional.sat_add_cps
     B.Positional.sat_add
     B.Positional.sat_sub_cps
     B.Positional.sat_sub
     : basesystem_partial_evaluation_unfolder.

Ltac basesystem_partial_evaluation_unfolder t :=
  let t := (eval cbv delta [
                   B.Positional.chain_op'_cps
                     B.Positional.chain_op'
                     B.Positional.chain_op_cps
                     B.Positional.chain_op
                     B.Positional.sat_add_cps
                     B.Positional.sat_add
                     B.Positional.sat_sub_cps
                     B.Positional.sat_sub
                 ] in t) in
  let t := Arithmetic.Saturated.Core.basesystem_partial_evaluation_unfolder t in
  let t := Arithmetic.Core.basesystem_partial_evaluation_unfolder t in
  t.

Ltac Arithmetic.Core.basesystem_partial_evaluation_default_unfolder t ::=
  basesystem_partial_evaluation_unfolder t.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimunLogic.Syntax.

Local Open Scope logic_base.
Local Open Scope syntax.

Module Semantics.

Definition impp {model: Type} (X: Ensemble model) (Y: Ensemble model): Ensemble model :=
  fun m => X m -> Y m.

End Semantics.

Class TrivialMinimunSemantics (L: Language) {minL: MinimunLanguage L} (MD: Model) (SM: Semantics L MD): Type := {
  denote_impp: forall x y, Same_set _ (denotation (x --> y)) (Semantics.impp (denotation x) (denotation y))
}.

Lemma sat_impp {L: Language} {minL: MinimunLanguage L} {MD: Model} {SM: Semantics L MD} {tminSM: TrivialMinimunSemantics L MD SM}: forall m x y, m |= x --> y <-> (m |= x -> m |= y).
Proof.
  intros; simpl.
  unfold satisfies.
  destruct (denote_impp x y).
  split; auto; [apply H | apply H0].
Qed.