Require Import Coq.Arith.EqNat.
Require Import Coq.Structures.Equalities.
Require Import Coq.Lists.List.
Require Import Coq.MSets.MSetInterface.
Require Import Coq.MSets.MSetWeakList.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Program.Equality.
Require Import Coq.Arith.PeanoNat.
Require Import MSetProperties.
Require Import Coq.Init.Specif.

Module STLCPoly
       (Import VarTyp : BooleanDecidableType')
       (Import set : MSetInterface.S).

Module EqFacts := BoolEqualityFacts(VarTyp).

Module M := MSetWeakList.Make(VarTyp).
Export M.

Module MSetProperties := WPropertiesOn(VarTyp)(M).

Definition var : Type := VarTyp.t.

Inductive STyp :=
  | STUnitT : STyp
  | STInt : STyp
  | STFun : STyp -> STyp -> STyp
  | STTuple : STyp -> STyp -> STyp
  | STFVarT : var -> STyp
  | STBVarT : nat -> STyp
  | STForAll : STyp -> STyp.

Inductive SExp (A : Type) :=
  | STFVar  : A -> SExp A
  | STBVar  : nat -> SExp A
  | STUnit  : SExp A
  | STLit   : nat -> SExp A
  | STLam   : STyp -> SExp A -> SExp A
  | STLam'  : SExp A -> SExp A
  | STApp   : SExp A -> SExp A -> SExp A
  | STPair  : SExp A -> SExp A -> SExp A
  | STProj1 : SExp A -> SExp A
  | STProj2 : SExp A -> SExp A
  | STTLam  : SExp A -> SExp A
  | STTApp  : SExp A -> STyp -> SExp A.

Definition Exp := forall A, SExp A.

Definition vars := M.t.

(** Definitions borrowed from STLC_Tutorial **)

(* Contexts *)
Definition context (A : Type) := list (var * A).

Definition extend {A} (x : var) (a : A) (c : context A) : context A :=
  ((x,a) :: nil) ++ c.

Definition dom {A} (c : context A) : vars :=
  fold_right (fun el r => add (fst el) r) empty c.

(* Functions on contexts *)
Definition mapctx {A B} (f : A -> B) (c : context A) : context B :=
  map (fun p => (fst p, (f (snd p)))) c.

Lemma cons_to_push : forall {A} x v (E : context A),
  (x, v) :: E = extend x v E.
Proof. intros; unfold extend; simpl; reflexivity. Defined.

Lemma env_ind : forall {A} (P : context A -> Prop),
  (P nil) ->
  (forall E x v, P E -> P (extend x v E)) ->
  (forall E, P E).
Proof.
  unfold extend.
  induction E as [|(x,v)].
  assumption.
  pose (H0 _ x v IHE).
  now simpl in p.
Defined.

Lemma dom_map_id : forall (A B : Type) (E : context A) (f : A -> B),
  dom E = dom (mapctx f E).
Proof.
  unfold mapctx.
  intros.
  induction E.
  simpl; reflexivity.
  simpl in *.
  rewrite IHE.
  reflexivity.
Defined.

Lemma dom_union : forall (A : Type) (E G : context A) x,
  M.In x (dom (E ++ G)) <-> M.In x (M.union (dom E) (dom G)).
Proof.
  intros. generalize dependent G.
  induction E; intros.
  unfold dom at 2; simpl.
  unfold "<->".
  split; intros.
  apply MSetProperties.Dec.F.union_3.
  assumption.
  apply MSetProperties.Dec.F.union_1 in H.
  inversion H.
  inversion H0.
  assumption.
  simpl.
  destruct a.
  split; intros.
  simpl in *.
  assert (Ha : sumbool (VarTyp.eq v x) (not( VarTyp.eq v x))) by apply VarTyp.eq_dec.
  destruct Ha.
  apply MSetProperties.Dec.F.union_2.
  apply MSetProperties.Dec.F.add_iff.
  auto.
  rewrite (MSetProperties.Dec.F.add_neq_iff _ n) in H.
  assert (Ha : M.Equal (M.union (M.add v (dom E)) (dom G)) (M.add v (M.union (dom E) (dom G)))) by apply MSetProperties.union_add.
  apply Ha.
  apply IHE in H.
  unfold not in n.
  apply MSetProperties.Dec.F.add_2.
  assumption.
  simpl in *.
  apply MSetProperties.Dec.F.union_1 in H.
  destruct H.
  assert (Ha : sumbool (VarTyp.eq v x) (not( VarTyp.eq v x))) by apply VarTyp.eq_dec.
  destruct Ha.
  apply MSetProperties.Dec.F.add_iff; auto.
  rewrite (MSetProperties.Dec.F.add_neq_iff _ n) in H.
  apply MSetProperties.Dec.F.add_neq_iff; auto.
  apply IHE.
  apply MSetProperties.Dec.F.union_2; assumption.
  apply MSetProperties.Dec.F.add_iff.
  right.
  apply IHE.
  apply MSetProperties.Dec.F.union_3; assumption.
Defined.

Lemma list_impl_m : forall {A} Gamma x (v : A), List.In (x, v) Gamma -> M.In x (dom Gamma).
Proof.
  intros.
  induction Gamma.
  inversion H.
  simpl.
  destruct a.
  simpl in *.
  inversion H.
  apply MSetProperties.Dec.F.add_1.
  apply f_equal with (f := fst) in H0.
  simpl in H0.
  rewrite H0.
  reflexivity.
  apply MSetProperties.Dec.F.add_2.
  apply IHGamma; assumption.
Defined.

Ltac not_in_L x :=
  repeat rewrite dom_union; repeat rewrite M.union_spec;
  repeat match goal with
    | H: M.In x M.empty |- _ => inversion H
    | H:_ |- context [M.In x (dom nil)] => simpl
    | H:_ |- context [M.In x (dom ((?v, ?t) :: ?l))] => simpl; rewrite MSetProperties.Dec.F.add_iff
    | H: _ |- context [M.In ?v (dom ((x, ?t) :: ?l))] => simpl; rewrite MSetProperties.Dec.F.add_iff
    | H1: ~ ?l, H2: ?l |- _ => contradiction
    | H: ~ M.In ?y (M.singleton x) |- not (VarTyp.eq x ?y) => rewrite MSetProperties.Dec.F.singleton_iff in H; assumption
    | H: ~ M.In x (M.singleton ?y) |- not (VarTyp.eq x ?y) => rewrite MSetProperties.Dec.F.singleton_iff in H; unfold not; intros; apply H; symmetry; assumption
    | H: ~ M.In x (M.add ?v M.empty) |- _ => rewrite <- MSetProperties.singleton_equal_add in H
    | H: not (M.In x (dom ?l)) |- _ => rewrite dom_union in H; simpl in H
    | H: not (M.In x (M.union ?l1 ?l2)) |- _ =>
      rewrite M.union_spec in H
    | H: not (M.In x ?l3 \/ ?l) |- _ =>
      let l := fresh in
      let r := fresh in
      apply not_or_and in H; destruct H as [l r]
    | H: not (?l \/ M.In x ?l3) |- _ =>
      let l := fresh in
      let r := fresh in
      apply not_or_and in H; destruct H as [l r]
    | H: not (M.In x ?l1) |- not (M.In x ?l1) => assumption
    | H:_ |- ~ (x == ?v \/ M.In ?v ?l) => unfold not; intro HInv; inversion HInv as [HH | HH]
    | H:_ |- not (?A \/ ?B) => apply and_not_or; split
    | H1: ~ M.In x (M.singleton ?v), H2: ?v == x |- _ => exfalso; apply H1; apply MSetProperties.Dec.F.singleton_2; assumption
    | H1: ~ M.In x (M.singleton ?v), H2: x == ?v |- _ => exfalso; apply H1; apply MSetProperties.Dec.F.singleton_2; symmetry; assumption
    | H: not (M.In x ?l1) |- not (M.In x ?l2) =>
      unfold not; intros; apply H; repeat rewrite M.union_spec; auto 10
  end.

(* Ok *)

Inductive ok {A} : context A -> Prop :=
  | Ok_nil : ok nil
  | Ok_push : forall (E : context A) (v : var) (ty : A),
                ok E -> not (In v (dom E)) -> ok (extend v ty E).

Hint Constructors ok.

Lemma ok_app_l : forall {A} (E F : context A), ok (E ++ F) -> ok E.
Proof.
  intros A E; induction E; intros.
  apply Ok_nil.
  inversion H.
  subst.
  apply Ok_push.
  apply (IHE _ H2).
  not_in_L v.
Defined.

Lemma ok_app_r : forall {A} (E F : context A), ok (E ++ F) -> ok F.
Proof.
  intros A E.
  induction E; intros.
  - rewrite app_nil_l in H.
    auto.
  - inversion H; subst.
    apply (IHE _ H2).
Defined.

Lemma ok_remove : forall {A} (E F G : context A), ok (E ++ G ++ F) -> ok (E ++ F).
Proof.
  intros.
  induction E using env_ind.
  rewrite app_nil_l in *.
  now apply ok_app_r in H.
  unfold extend; rewrite <- app_assoc.
  apply Ok_push.
  apply IHE.
  unfold extend in H; rewrite <- app_assoc in H.
  inversion H; subst.
  assumption.
  unfold extend in H.
  inversion H; subst.
  rewrite dom_union in *.
  rewrite union_spec in *.
  unfold not; intros.
  apply H4.
  inversion H0.
  auto.
  right.
  rewrite dom_union; rewrite union_spec.
  auto.
Defined.

Lemma ok_extend_comm : forall {A} (E F : context A) x v,
               ok (F ++ E ++ (x, v) :: nil) ->
               ok (F ++ (x, v) :: nil ++ E).
Proof.
  intros A E F x v HOk.
  generalize dependent E.

  induction F using env_ind; intros.
  unfold extend; simpl.
  rewrite app_nil_l in HOk.
  apply Ok_push.
  now apply ok_app_l in HOk.
  induction E.
  unfold not; intros HInv; inversion HInv.
  simpl.
  rewrite <- app_comm_cons in HOk.
  inversion HOk; subst.
  apply IHE in H1.
  simpl in *.
  unfold not; intros H3; apply MSetProperties.Dec.F.add_iff in H3.
  inversion H3.
  rewrite H in H2.
  rewrite dom_union in H2.
  rewrite union_spec in H2.
  apply not_or_and in H2.
  inversion H2.
  simpl in H4.
  apply H4.
  apply MSetProperties.Dec.F.add_1.
  reflexivity.
  contradiction.
  unfold extend.
  rewrite <- app_assoc.
  apply Ok_push.
  apply IHF.
  inversion HOk.
  subst.
  assumption.
  rewrite dom_union.
  rewrite union_spec.
  unfold not; intros.
  inversion H.
  apply ok_app_l in HOk.
  inversion HOk.
  subst.
  contradiction.
  simpl in H0.
  apply MSetProperties.Dec.F.add_iff in H0.
  inversion H0.
  unfold extend in HOk.
  apply ok_remove in HOk.
  rewrite <- app_assoc in HOk.
  apply ok_remove in HOk.
  simpl in HOk.
  inversion HOk; subst.
  simpl in *.
  apply H6.
  apply MSetProperties.Dec.F.add_1.
  assumption.
  inversion HOk; subst.
  rewrite dom_union in H6; rewrite union_spec in H6.
  apply not_or_and in H6.
  inversion H6.
  rewrite dom_union in H3; rewrite union_spec in H3; apply not_or_and in H3.
  inversion H3.
  contradiction.
Defined.

Lemma ok_app_comm : forall {A} (E F : context A), ok (F ++ E) -> ok (E ++ F).
Proof.
  intros.
  generalize dependent H.
  generalize dependent F.
  dependent induction E using (@env_ind A).
  intros.
  rewrite app_nil_r in H.
  now simpl.
  intros.
  unfold extend in *.
  rewrite <- app_assoc.
  apply Ok_push.
  apply IHE.
  apply ok_remove in H.
  assumption.
  rewrite dom_union.
  rewrite union_spec.
  unfold not; intros.
  inversion H0.
  apply ok_app_r in H.
  inversion H; subst.
  contradiction.
  rewrite app_assoc in H.
  apply ok_app_l in H.
  rewrite <- app_nil_l in H.
  apply ok_extend_comm in H.
  rewrite app_nil_l in H.
  simpl in H.
  inversion H; subst.
  contradiction.
Defined.

Definition ok_app_and {A} (E F : context A) (H : ok (E ++ F)) : ok E /\ ok F :=
  conj (ok_app_l _ _ H) (ok_app_r _ _ H).

Lemma ok_middle_comm :
  forall {A} (E : context A) F G H, ok (E ++ F ++ G ++ H) -> ok (E ++ G ++ F ++ H).
Proof.
  intros.
  induction E.
  generalize dependent F.
  induction H; intros.
  rewrite app_nil_l in *.
  rewrite app_nil_r in *.
  now apply ok_app_comm.
  rewrite app_nil_l.
  rewrite app_assoc.
  apply ok_app_comm.
  rewrite <- app_comm_cons.
  destruct a.
  apply Ok_push.
  apply ok_app_comm.
  rewrite <- app_assoc.
  rewrite app_nil_l in H0.
  rewrite app_assoc in H0.
  apply ok_app_comm in H0.
  rewrite <- app_comm_cons in H0.
  inversion H0; subst.
  apply IHlist.
  rewrite app_nil_l.
  apply ok_app_comm in H3.
  now rewrite <- app_assoc in H3.
  rewrite app_nil_l in H0.
  rewrite app_assoc in H0.
  apply ok_app_comm in H0.
  rewrite <- app_comm_cons in H0.
  inversion H0; subst.
  not_in_L v.
  rewrite dom_union in H2; rewrite union_spec in H2; inversion H2; contradiction.
  intros.
  rewrite <- app_comm_cons.
  destruct a.
  apply Ok_push.
  apply IHE.
  rewrite <- app_comm_cons in H0.
  inversion H0.
  assumption.
  rewrite <- app_comm_cons in H0.
  inversion H0.
  subst.
  not_in_L v.
  rewrite dom_union in H5; rewrite union_spec in H5; inversion H5.
  contradiction.
  rewrite dom_union in H7; rewrite union_spec in H7; inversion H7.
  contradiction.
  contradiction.
Defined.

(** Target language **)
Fixpoint fv (sExp : SExp var) : vars :=
  match sExp with
    | STFVar _ v => singleton v
    | STBVar _ _ => empty
    | STUnit _ => empty
    | STLit _ _ => empty
    | STLam _ _ t => fv t
    | STLam' _ t => fv t
    | STApp _ t1 t2 => union (fv t1) (fv t2)
    | STPair _ t1 t2 => union (fv t1) (fv t2)
    | STProj1 _ t => fv t
    | STProj2 _ t => fv t
    | STTLam _ t => fv t
    | STTApp _ t ty => fv t
  end.

Fixpoint open_rec_type (k : nat) (u : STyp) (t : STyp) {struct t} : STyp :=
  match t with
  | STUnitT       => STUnitT
  | STInt         => STInt
  | STFun t1 t2   => STFun (open_rec_type k u t1) (open_rec_type k u t2)
  | STTuple t1 t2 => STTuple (open_rec_type k u t1) (open_rec_type k u t2)
  | STFVarT x     => STFVarT x
  | STBVarT i     => if Nat.eqb k i then u else (STBVarT i)
  | STForAll t    => STForAll (open_rec_type (S k) u t)
  end.

Fixpoint open_rec_type_term (k : nat) (u : STyp) (t : SExp var) {struct t} :
  SExp var :=
  match t with
  | STBVar _ i => STBVar _ i
  | STFVar _ x => STFVar _ x
  | STUnit _ => STUnit _
  | STLit _ x => STLit _ x
  | STLam _ ty t1 => STLam _ (open_rec_type k u ty) (open_rec_type_term k u t1)
  | STLam' _ t1 => STLam' _ (open_rec_type_term k u t1)
  | STApp _ t1 t2 => STApp _ (open_rec_type_term k u t1) (open_rec_type_term k u t2)
  | STPair _ t1 t2 => STPair _ (open_rec_type_term k u t1) (open_rec_type_term k u t2)
  | STProj1 _ t => STProj1 _ (open_rec_type_term k u t)
  | STProj2 _ t => STProj2 _ (open_rec_type_term k u t)
  | STTLam _ t => STTLam _ (open_rec_type_term (S k) u t)
  | STTApp _ t ty => STTApp _ (open_rec_type_term k u t) (open_rec_type k u ty)
  end.

Fixpoint open_rec (k : nat) (u : SExp var) (t : SExp var) {struct t} : SExp var :=
  match t with
  | STBVar _ i => if Nat.eqb k i then u else (STBVar _ i)
  | STFVar _ x => STFVar _ x
  | STUnit _ => STUnit _
  | STLit _ x => STLit _ x
  | STLam _ ty t1 => STLam _ ty (open_rec (S k) u t1)
  | STLam' _ t1 => STLam' _ (open_rec (S k) u t1)
  | STApp _ t1 t2 => STApp _ (open_rec k u t1) (open_rec k u t2)
  | STPair _ t1 t2 => STPair _ (open_rec k u t1) (open_rec k u t2)
  | STProj1 _ t => STProj1 _ (open_rec k u t)
  | STProj2 _ t => STProj2 _ (open_rec k u t)
  | STTLam _ t => STTLam _ (open_rec k u t)
  | STTApp _ t ty => STTApp _ (open_rec k u t) ty
  end.

Definition open (t : SExp var) u := open_rec 0 u t.
Definition open_typ (t : STyp) u := open_rec_type 0 u t.
Definition open_typ_term (t : SExp var) u := open_rec_type_term 0 u t.

(* Notation "[ z ~> u ] t" := (subst z u t) (at level 68). *)
Notation "{ k ~> u } t" := (open_rec k u t) (at level 67).
Notation "t ^ x" := (open t (STFVar var x)).
Notation "t ^^ u" := (open t u) (at level 67).

Lemma fv_distr :
  forall t1 t2 x n, In x (fv (open_rec n t2 t1)) ->
               In x (union (fv t1) (fv t2)).
Proof.
  intros.
  generalize dependent t2.
  generalize dependent n.
  induction t1; intros; simpl in *; rewrite union_spec in *; auto.
  - destruct (Nat.eqb n0 n); auto.
  - rewrite <- union_spec.
    eapply IHt1.
    apply H.
  - apply IHt1 in H.
    now rewrite union_spec in H.
  - rewrite union_spec.
    inversion H.
    rewrite or_comm at 1.
    rewrite <- or_assoc.
    left; rewrite or_comm; rewrite <- union_spec.
    eapply IHt1_1; apply H0.
    rewrite or_assoc.
    right; rewrite <- union_spec.
    eapply IHt1_2; apply H0.
  - rewrite union_spec.
    inversion H.
    rewrite or_comm at 1.
    rewrite <- or_assoc.
    left; rewrite or_comm; rewrite <- union_spec.
    eapply IHt1_1; apply H0.
    rewrite or_assoc.
    right; rewrite <- union_spec.
    eapply IHt1_2; apply H0.
  - rewrite <- union_spec.
    eapply IHt1; apply H.
  - rewrite <- union_spec.
    apply (IHt1 _ _ H).
  - rewrite <- union_spec.
    apply (IHt1 _ _ H).
  - rewrite <- union_spec.
    apply (IHt1 _ _ H).
Defined.

Inductive STType : STyp -> Prop :=
  | STType_Var : forall x, STType (STFVarT x)
  | STType_Unit : STType STUnitT
  | STType_Int : STType STInt
  | STType_Fun : forall t1 t2, STType (STFun t1 t2)
  | STType_Tuple : forall t1 t2, STType (STTuple t1 t2)
  | STType_ForAll : forall L t,
      (forall x, not (In x L) -> STType (open_typ t (STFVarT x))) ->
      STType (STForAll t).

Print SExp.

Inductive STTerm : SExp var -> Prop :=
  | STTerm_Var : forall x,
      STTerm (STFVar _ x)
  | STTerm_Unit : STTerm (STUnit _)
  | STTerm_Lit : forall n,
      STTerm (STLit _ n)
  | STTerm_Lam : forall L t1 ty,
      (forall x, not (In x L) -> STTerm (open t1 (STFVar _ x))) ->
      STType ty ->
      STTerm (STLam _ ty t1)
  | STTerm_Lam' : forall L t1,
      (forall x, not (In x L) -> STTerm (open t1 (STFVar _ x))) ->
      STTerm (STLam' _ t1)
  | STTerm_App : forall t1 t2,
      STTerm t1 ->
      STTerm t2 ->
      STTerm (STApp _ t1 t2)
  | STTerm_Pair : forall t1 t2,
      STTerm t1 ->
      STTerm t2 ->
      STTerm (STPair _ t1 t2)
  | STTerm_Proj1 : forall t,
      STTerm t ->
      STTerm (STProj1 _ t)
  | STTerm_Proj2 : forall t,
      STTerm t ->
      STTerm (STProj2 _ t)
  | STTerm_TLam : forall L t,
      (forall x, not (In x L) -> STTerm (open_typ_term t (STFVarT x))) ->
      STTerm (STTLam _ t)
  | STTerm_TApp : forall t ty,
      STTerm t ->
      STType ty ->
      STTerm (STTApp _ t ty).

Hint Constructors STTerm.

(* Tactics dealing with fresh variables, taken from STLC_Tutorial *)

Ltac gather_vars_with F :=
  let rec gather V :=
   (match goal with
    | H:?S
      |- _ =>
          let FH := constr:(F H) in
          match V with
          | empty => gather FH
          | context [FH] => fail 1
          | _ => gather (union FH V)
          end
    | _ => V
    end)
  in
  let L := gather (empty : vars) in
  eval simpl in L.

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => singleton x) in
  (*let C := gather_vars_with (fun (x : context PTyp) => dom x) in *)
  let D := gather_vars_with (fun (x : context STyp) => dom x) in
  (*let E := gather_vars_with (fun x : PExp => fv_source x) in *)
  let F := gather_vars_with (fun (x : SExp var) => fv x) in
  constr:(union A (union B (union D F))).

Ltac beautify_fset V :=
  let rec go Acc E :=
   (match E with
    | union ?E1 ?E2 => let Acc1 := go Acc E1 in
                    go Acc1 E2
    | empty => Acc
    | ?E1 => match Acc with
             | empty => E1
             | _ => constr:(union Acc E1)
             end
    end)
  in
  go (empty : vars) V.

Parameter var_fresh : forall L : vars, (sig (A := var) (fun x => not (In x L))).

Ltac pick_fresh_gen L Y :=
  let Fr := fresh "Fr" in
  let L := beautify_fset L in
  destruct (var_fresh L) as (Y, Fr).

Ltac pick_fresh x :=
  let L := gather_vars in (pick_fresh_gen L x).

Ltac apply_fresh_base_simple lemma gather :=
  let L0 := gather in
  let L := beautify_fset L0 in
  first
  [ apply (lemma L) | eapply (lemma L) ].

Ltac intros_fresh x :=
  first
  [ let Fr := fresh "Fr" x in
    intros x Fr
  | let x2 :=
     (match goal with
      | |- ?T -> _ =>
            match T with
            | var => fresh "y"
            | vars => fresh "ys"
            | list var => fresh "ys"
            | _ => fresh "y"
            end
      end)
    in
    let Fr := fresh "Fr" x2 in
    intros x2 Fr ].

Fixpoint fresh (L : vars) (n : nat) (xs : list var) : Prop :=
  match xs with
  | nil => match n with
           | 0 => True
           | S _ => False
           end
  | (x :: xs')%list =>
      match n with
      | 0 => False
      | S n' => (not (In x L)) /\ fresh (union L (singleton x)) n' xs'
      end
  end.

Ltac apply_fresh_base lemma gather var_name :=
  apply_fresh_base_simple lemma gather;
   try
    match goal with
    | |- _ -> not (In _ _) -> _ => intros_fresh var_name
    | |- _ -> fresh _ _ _ -> _ => intros_fresh var_name
    end.

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.

Lemma open_rec_term_core :forall t j v i u, i <> j ->
  { j ~> v }t = { i ~> u }({ j ~> v }t) -> t = { i ~> u }t.
Proof.
  intro t; induction t; intros; simpl; auto.
  - simpl in *.
    case_eq (Nat.eqb i n); intros.
    case_eq (Nat.eqb j n); intros.
    exfalso. apply H. apply Nat.eqb_eq in H1.
    apply Nat.eqb_eq in H2. rewrite H1, H2.
    reflexivity.
    rewrite H2 in H0.
    unfold open_rec in H0.
    rewrite H1 in H0.
    assumption.
    reflexivity.
  - inversion H0.
    erewrite <- IHt.
    reflexivity.
    apply not_eq_S.
    apply H.
    apply H2.
  - inversion H0.
    erewrite <- IHt.
    reflexivity.
    apply not_eq_S.
    apply H.
    apply H2.
  - inversion H0.
    erewrite <- IHt1.
    erewrite <- IHt2.
    reflexivity.
    apply H.
    apply H3.
    apply H.
    apply H2.
  - inversion H0.
    erewrite <- IHt1.
    erewrite <- IHt2.
    reflexivity.
    apply H.
    apply H3.
    apply H.
    apply H2.
  - inversion H0.
    erewrite <- IHt.
    reflexivity.
    apply H.
    apply H2.
  - inversion H0.
    erewrite <- IHt.
    reflexivity.
    apply H.
    apply H2.
  - inversion H0; erewrite <- IHt; [ reflexivity | apply H | apply H2 ].
  - inversion H0; erewrite <- IHt; [ reflexivity | apply H | apply H2 ].
Defined.

(** Substitution on indices is identity on well-formed terms. *)

Lemma open_rec_term : forall t u,
  STTerm  t -> forall k, t =  { k ~> u }t.
Proof.
  induction 1; intros; simpl; auto.
  - pick_fresh x.
    rewrite <- open_rec_term_core with (j := 0) (v := STFVar _ x).
    reflexivity.
    auto.
    simpl.
    unfold open in *.
    rewrite <- H0.
    reflexivity.
    unfold not; intros; apply Fr; rewrite union_spec; rewrite union_spec; left; left.
    assumption.
  - pick_fresh x.
    rewrite <- open_rec_term_core with (j := 0) (v := STFVar _ x).
    reflexivity.
    auto.
    simpl.
    unfold open in *.
    rewrite <- H0.
    reflexivity.
    unfold not; intros; apply Fr; rewrite union_spec; rewrite union_spec; left; left.
    assumption.
  - rewrite <- IHSTTerm1.
    rewrite <- IHSTTerm2.
    reflexivity.
  - rewrite <- IHSTTerm1.
    rewrite <- IHSTTerm2.
    reflexivity.
  - rewrite <- IHSTTerm.
    reflexivity.
  - rewrite <- IHSTTerm.
    reflexivity.
  - pick_fresh x. Check open_rec_term_core.
    admit.
    (*
    rewrite <- open_rec_term_core with (j := (S k)) (v := STFVar _ x).
    reflexivity.
    auto.
    apply H0.*)
  - rewrite <- IHSTTerm.
    reflexivity.
Admitted.

Hint Resolve open_rec_term.

Lemma open_app_eq : forall x E n F,
  not (In x (fv E)) ->
  not (In x (fv F)) ->
  (open_rec n (STFVar var x) E) = (open_rec n (STFVar var x) F) ->
  E = F.
Proof.
  intros x E.
  induction E; intros n' F HNotE HNotF HEqOpen.
  - simpl in *.
    induction F; try (inversion HEqOpen; auto).
    destruct (Nat.eqb n' n); auto.
    exfalso; apply HNotE.
    apply MSetProperties.Dec.F.singleton_2; inversion H0; reflexivity.
  - induction F; simpl in *; try (now (destruct (Nat.eqb n' n); inversion HEqOpen)).
    destruct (Nat.eqb n' n).
    exfalso; apply HNotF.
    apply MSetProperties.Dec.F.singleton_2; inversion HEqOpen; reflexivity.
    inversion HEqOpen.
    case_eq (Nat.eqb n' n); intros.
    case_eq (Nat.eqb n' n0); intros.
    apply f_equal.
    apply beq_nat_true in H.
    apply beq_nat_true in H0.
    now subst.
    rewrite H in HEqOpen.
    rewrite H0 in HEqOpen.
    inversion HEqOpen.
    rewrite H in HEqOpen.
    case_eq (Nat.eqb n' n0); intros;
    rewrite H0 in HEqOpen; inversion HEqOpen.
    reflexivity.
  - induction F; simpl in *; try (now inversion HEqOpen).
    destruct (Nat.eqb n' n); [ inversion HEqOpen | auto ].
  - induction F; simpl in *; try (now inversion HEqOpen).
    destruct (Nat.eqb n' n0); [ inversion HEqOpen | auto ].
  - induction F; simpl in *; try (now inversion HEqOpen).
    destruct (Nat.eqb n' n); inversion HEqOpen.
    inversion HEqOpen.
    apply f_equal.
    now apply (IHE (S n')).
  - induction F; simpl in *; try (now inversion HEqOpen).
    destruct (Nat.eqb n' n); inversion HEqOpen.
    inversion HEqOpen.
    apply f_equal.
    now apply (IHE (S n')).
  - induction F; simpl in *; try (now inversion HEqOpen).
    destruct (Nat.eqb n' n); inversion HEqOpen.
    rewrite IHE1 with (F := F1) (n := n'); try not_in_L x.
    rewrite IHE2 with (F := F2) (n := n'); try not_in_L x.
    reflexivity.
    not_in_L x.
    not_in_L x.
    now inversion HEqOpen.
    not_in_L x.
    not_in_L x.
    now inversion HEqOpen.
  - induction F; simpl in *; try (now inversion HEqOpen).
    destruct (Nat.eqb n' n); inversion HEqOpen.
    rewrite IHE1 with (F := F1) (n := n'); try not_in_L x.
    rewrite IHE2 with (F := F2) (n := n'); try not_in_L x.
    reflexivity.
    not_in_L x.
    not_in_L x.
    now inversion HEqOpen.
    not_in_L x.
    not_in_L x.
    now inversion HEqOpen.
  - induction F; simpl in *; try (now inversion HEqOpen).
    destruct (Nat.eqb n' n); inversion HEqOpen.
    apply f_equal.
    apply IHE with (n := n'); try not_in_L x.
    now inversion HEqOpen.
  - induction F; simpl in *; try (now inversion HEqOpen).
    destruct (Nat.eqb n' n); inversion HEqOpen.
    apply f_equal.
    apply IHE with (n := n'); try not_in_L x.
    now inversion HEqOpen.
  - induction F; simpl in *; try (now inversion HEqOpen).
    destruct (Nat.eqb n' n); inversion HEqOpen.
    apply f_equal.
    apply IHE with (n := n'); try not_in_L x.
    now inversion HEqOpen.
  - induction F; simpl in *; try (now inversion HEqOpen).
    destruct (Nat.eqb n' n); inversion HEqOpen.
    erewrite IHE.
    apply f_equal.
    now inversion HEqOpen.
    auto.
    auto.
    inversion HEqOpen.
    apply H0.
Defined.

(* Typing rules *)

Print STyp.

(* Typing rules of STLC, inspired by STLC_Tutorial *)
Inductive has_type_st : (context STyp) -> (SExp var) -> STyp -> Prop :=
  | STTyVar : forall (Gamma : context STyp) x ty,
                ok Gamma -> List.In (x,ty) Gamma -> has_type_st Gamma (STFVar _ x) ty
  | STTyUnit : forall Gamma, ok Gamma -> has_type_st Gamma (STUnit _) STUnitT
  | STTyLit : forall Gamma x, ok Gamma -> has_type_st Gamma (STLit _ x) STInt
  | STTyLam : forall L Gamma t A B,
                (forall x, not (In x L) ->
                      has_type_st (extend x A Gamma) (open t (STFVar _ x)) B) ->
                STType A ->
                has_type_st Gamma (STLam _ A t) (STFun A B)
  | STTyLam' : forall L Gamma t A B,
                 (forall x, not (In x L) ->
                       has_type_st (extend x A Gamma) (open t (STFVar _ x)) B) ->
                 has_type_st Gamma (STLam' _ t) (STFun A B)
  | STTyApp : forall Gamma A B t1 t2, has_type_st Gamma t1 (STFun A B) ->
                             has_type_st Gamma t2 A -> has_type_st Gamma (STApp _ t1 t2) B
  | STTyPair : forall Gamma A B t1 t2, has_type_st Gamma t1 A ->
                              has_type_st Gamma t2 B ->
                              has_type_st Gamma (STPair _ t1 t2) (STTuple A B)
  | STTyProj1 : forall Gamma t A B, has_type_st Gamma t (STTuple A B) ->
                           has_type_st Gamma (STProj1 _ t) A
  | STTyProj2 : forall Gamma t A B, has_type_st Gamma t (STTuple A B) ->
                           has_type_st Gamma (STProj2 _ t) B
  | STTyTLam : forall L Gamma t A,
                 (forall x, not (In x L) ->
                       has_type_st (extend x A Gamma)
                                   (open_typ_term t (STFVarT x))
                                   (open_typ A (STFVarT x))) ->
                 STType A ->
                 has_type_st Gamma (STTLam _ t) (STForAll A)
  | STTyTApp : forall Gamma t A ty, STType A ->
                           has_type_st Gamma t (STForAll ty) ->
                           has_type_st Gamma (STTApp _ t A) (open_typ ty A).

Hint Constructors has_type_st.

(* Typing lemmas *)

Lemma typing_weaken : forall G E F t T,
   has_type_st (E ++ G) t T ->
   ok (E ++ F ++ G) ->
   has_type_st (E ++ F ++ G) t T.
Proof.
  intros.
  generalize dependent H0.
  remember (E ++ G) as H'.
  generalize dependent HeqH'.
  generalize dependent E.
  dependent induction H; intros; eauto.
  (* STTyVar *)
  - subst.
    apply STTyVar.
    assumption.
    apply in_app_or in H0.
    inversion H0.
    apply in_or_app; left; assumption.
    apply in_or_app; right; apply in_or_app; right; assumption.
  (* STTyLam *)
  - apply_fresh STTyLam as x.
    unfold open in *; simpl in *.
    subst.
    unfold extend; simpl.
    rewrite app_comm_cons.
    apply H0.
    not_in_L x.
    unfold extend; simpl; reflexivity.
    rewrite <- app_comm_cons.
    apply Ok_push.
    assumption.
    not_in_L x.
    rewrite dom_union in H7.
    rewrite union_spec in H7.
    inversion H7; exfalso; contradiction.
    auto.
  - apply_fresh STTyLam' as x.
    unfold open in *; simpl in *.
    subst.
    unfold extend; simpl.
    rewrite app_comm_cons.
    apply H0.
    not_in_L x.
    unfold extend; simpl; reflexivity.
    rewrite <- app_comm_cons.
    apply Ok_push.
    assumption.
    not_in_L x.
    rewrite dom_union in H6.
    rewrite union_spec in H6.
    inversion H6; exfalso; [apply H8 | apply H9]; auto.
  - apply_fresh STTyTLam as x.
    unfold open in *; simpl in *.
    subst.
    unfold extend; simpl.
    rewrite app_comm_cons.
    apply H0.
    not_in_L x.
    unfold extend; simpl; reflexivity.
    rewrite <- app_comm_cons.
    apply Ok_push.
    assumption.
    not_in_L x.
    rewrite dom_union in H7.
    rewrite union_spec in H7.
    inversion H7; exfalso; contradiction.
    auto.
Defined.

Lemma typing_strengthen : forall z U E F t T,
  not (In z (fv t)) ->
  has_type_st (E ++ ((z,U) :: nil) ++ F) t T ->
  has_type_st (E ++ F) t T.
Proof.
  intros.
  remember (E ++ ((z,U) :: nil) ++ F).

  generalize dependent Heql.
  generalize dependent E.

  induction H0; intros; auto.
  - subst; apply STTyVar.
    now apply ok_remove in H0.
    apply in_or_app.
    repeat apply in_app_or in H1.
    inversion H1.
    auto.
    apply in_app_or in H2.
    inversion H2.
    inversion H3.
    inversion H4.
    subst.
    exfalso; apply H; simpl.
    left; reflexivity.
    inversion H4.
    auto.
  - apply STTyUnit.
    subst.
    now apply ok_remove in H0.
  - apply STTyLit.
    subst.
    now apply ok_remove in H0.
  - subst.
    apply_fresh STTyLam as x.
    unfold extend in *; simpl in *.
    rewrite app_comm_cons.
    apply H1.
    not_in_L x.
    not_in_L z.
    apply fv_distr in H3; rewrite union_spec in H3; inversion H3.
    auto.
    assert (NeqXZ : not (In x (singleton z))) by (not_in_L x).
    simpl in H3.
    inversion H3.
    contradiction.
    exfalso; apply NeqXZ.
    apply MSetProperties.Dec.F.singleton_2.
    apply MSetProperties.Dec.F.singleton_1 in H5.
    symmetry; assumption.
    rewrite app_comm_cons.
    reflexivity.
    auto.
  - subst.
    apply_fresh STTyLam' as x.
    unfold extend in *; simpl in *.
    rewrite app_comm_cons.
    apply H1.
    not_in_L x.
    not_in_L z.
    apply fv_distr in H2.
    rewrite union_spec in H2.
    inversion H2.
    auto.
    assert (NeqXZ : not (In x (singleton z))) by (not_in_L x).
    simpl in H3.
    exfalso; apply NeqXZ.
    apply MSetProperties.Dec.F.singleton_2.
    apply MSetProperties.Dec.F.singleton_1 in H3.
    symmetry; assumption.
    rewrite app_comm_cons.
    reflexivity.
  - eapply STTyApp.
    subst.
    apply IHhas_type_st1; simpl in *; not_in_L z; reflexivity.
    subst.
    apply IHhas_type_st2; simpl in *; not_in_L z; reflexivity.
  - subst.
    apply STTyPair.
    apply IHhas_type_st1; simpl in *; not_in_L z; reflexivity.
    apply IHhas_type_st2; simpl in *; not_in_L z; reflexivity.
  - subst.
    eapply STTyProj1.
    apply IHhas_type_st.
    not_in_L z.
    reflexivity.
  - subst.
    eapply STTyProj2.
    apply IHhas_type_st.
    not_in_L z.
    reflexivity.
  - subst.
    eapply STTyTLam.
    intros.
    unfold extend in *; simpl in *.
    rewrite app_comm_cons.
    apply H1.
    apply H3.
    not_in_L z.
    Check fv_distr.
    admit.
(*
    apply fv_distr in H4. rewrite union_spec in H4; inversion H4.
    auto.
    assert (NeqXZ : not (In x (singleton z))) by (not_in_L x).
    simpl in H3.
    inversion H3.
    contradiction.
    exfalso; apply NeqXZ.
    apply MSetProperties.Dec.F.singleton_2.
    apply MSetProperties.Dec.F.singleton_1 in H5.
    symmetry; assumption.
    rewrite app_comm_cons.
    reflexivity.
    auto.

Defined. *)
Admitted.

Lemma has_type_env_comm : forall E F G H T t,
              has_type_st (E ++ F ++ G ++ H) t T ->
              has_type_st (E ++ G ++ F ++ H) t T.
Proof.
  intros.
  remember (E ++ F ++ G ++ H).
  generalize dependent Heql.
  generalize dependent E.
  generalize dependent F.
  generalize dependent G.
  dependent induction H0; intros; subst; auto.
  - apply STTyVar.
    apply ok_app_comm.
    rewrite <- app_assoc.
    apply ok_app_comm.
    rewrite <- app_assoc.
    apply ok_app_comm.
    rewrite <- app_assoc.
    now apply ok_middle_comm.
    apply in_app_or in H1.
    inversion H1.
    apply in_or_app; auto.
    apply in_or_app; right.
    apply in_app_or in H2.
    inversion H2.
    apply in_or_app.
    right; apply in_or_app; left.
    assumption.
    apply in_app_or in H3.
    inversion H3.
    apply in_or_app; auto.
    apply in_or_app; right; apply in_or_app; auto.
  - apply STTyUnit.
    now apply ok_middle_comm.
  - apply STTyLit.
    now apply ok_middle_comm.
  - apply_fresh STTyLam as x.
    unfold extend.
    rewrite app_assoc.
    apply H1.
    not_in_L x.
    unfold extend.
    rewrite <- app_assoc.
    reflexivity.
    assumption.
  - apply_fresh STTyLam' as x.
    unfold extend.
    rewrite app_assoc.
    apply H1.
    not_in_L x.
    unfold extend.
    rewrite <- app_assoc.
    reflexivity.
  - eapply STTyApp.
    apply IHhas_type_st1; reflexivity.
    apply IHhas_type_st2; reflexivity.
  - eapply STTyProj1; apply IHhas_type_st; reflexivity.
  - eapply STTyProj2; apply IHhas_type_st; reflexivity.
  - apply_fresh STTyTLam as x.
    unfold extend.
    rewrite app_assoc.
    apply H1.
    not_in_L x.
    unfold extend.
    rewrite <- app_assoc.
    reflexivity.
    assumption.
Defined.

Lemma has_type_env_comm_extend : forall Gamma x y v1 v2 E t,
              has_type_st (extend x v1 (extend y v2 Gamma)) t E ->
              has_type_st (extend y v2 (extend x v1 Gamma)) t E.
Proof.
  unfold extend.
  intros.
  rewrite <- app_nil_l with (l := ((x, v1) :: nil) ++ ((y, v2) :: nil) ++ Gamma) in H.
  apply has_type_env_comm in H.
  now rewrite app_nil_l in H.
Defined.

Lemma typing_weaken_extend : forall t T x v Gamma,
   has_type_st Gamma t T ->
   not (M.In x (dom Gamma)) ->
   has_type_st ((x,v) :: Gamma) t T.
Proof.
  intros.
  induction H; eauto.
  apply STTyVar.
  apply Ok_push; assumption.
  apply in_cons; assumption.
  apply STTyUnit.
  apply Ok_push; assumption.
  apply STTyLit.
  apply Ok_push; assumption.
  apply_fresh STTyLam as x; cbn.
  unfold extend in H1.
  apply has_type_env_comm_extend.
  apply H1.
  not_in_L y.
  not_in_L x.
  not_in_L y.
  assumption.
  apply_fresh STTyLam' as x; cbn.
  unfold extend in H1.
  apply has_type_env_comm_extend.
  apply H1.
  not_in_L y.
  not_in_L x.
  not_in_L y.
  apply_fresh STTyTLam as x; cbn.
  apply has_type_env_comm_extend.
  apply H1.
  not_in_L y.
  not_in_L x.
  unfold extend in H3; simpl in H3.
  apply MSetProperties.FM.add_iff in H3; destruct H3.
  not_in_L y.
  assumption.
  assumption.
Defined.

Lemma typing_ok_env : forall Gamma E ty, has_type_st Gamma E ty -> ok Gamma.
Proof.
  intros.
  induction H; auto;
  pick_fresh x;
  assert (Ha: not (In x L)) by not_in_L x;
  pose (H0 _ Ha) as HInv;
  inversion HInv; auto.
Defined.

Lemma typing_gives_terms : forall Gamma E ty, has_type_st Gamma E ty -> STTerm E.
Proof.
  intros.
  induction H; auto.
  - apply_fresh STTerm_Lam as x.
    apply H0.
    not_in_L x.
    assumption.
  - apply_fresh STTerm_Lam' as x.
    apply H0.
    not_in_L x.
  - apply_fresh STTerm_TLam as x.
    apply H0.
    not_in_L x.
Defined.

End STLCPoly.


Inductive day : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

Definition next_weekday (d:day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Compute (next_weekday friday).


Require Import Verse.BitVector.
Require Import Verse.Machine.BitVector.
Require Import Verse.Monoid.
Require Import Verse.HlistMachine.

Require Import Verse.
(* The file defining a custom entry seems to be a required import to
   import any file using said custom entry!

   Might have to change `Require Import Verse` and `Require Import
   Verse.Language` to `Require Export`s.
 *)
Require Import Verse.AnnotatedCode.
Require Import Verse.ModularCode.
Require Import Verse.ProofTac.

Set Implicit Arguments.

Section Code.

  Variable v : VariableT.

  Variable A B C : v of type Word8.

  Definition f (w : VariableT) (a b : w of type Word8)
    : specBlock bvDenote w.

    verse ([code| a := b + b |]
                DOES
          (VAL a = INIT b + INIT b)
          )%list%verse.
  Defined.

  Definition verF : verFun bvDenote.
    Pack f.
    realize.
  Defined.

  Definition middle : list (modular bvDenote v).
    verse ([code| B := A; A := `6` |]
             ++
             (ASSERT VAL B = INIT A)
             ++
             CALL verF WITH (- A, B -))%list%verse.
  Defined.

  Definition test : Repeat (modular bvDenote v).
    (* This actually works without the `verse` tactic *)
    verse (
        [code| A := A; B := B; C := `0` |]
        ++
        CALL verF WITH (- A, B -)
        ++
        [ repeat 2 middle ]
        ++
        (ASSERT VAL A = INIT B + INIT B + INIT B + INIT B)
        ++
        (ASSERT VAL A = VAL C)
      )%list%verse.
  Defined.

End Code.

Definition toProve : Prop.
  getProp test.
Defined.

Require Import ProofTac.

Definition proof : toProve.
  time mrealize.
Abort.

(** Timing notes -
    mrealize
    repeat 5  - 21 sec  1 sec
    repeat 6  - 38 sec
    repeat 7  - 45 sec  8 sec
    repeat 8  - 75 sec  11 sec
    repeat 9  - 101 sec 13 sec
    repeat 10 - 133 sec 18 sec

    Realize
    repeat 5  - .3 sec
    repeat 13 - 81 sec
*)


Require Import
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.orders
  HoTT.Classes.interfaces.rationals
  HoTT.Classes.interfaces.archimedean
  HoTT.Classes.theory.fields
  HoTT.Classes.orders.rings.

Generalizable Variables Q F.

Section strict_field_order.
  Context `{Rationals Q}.
  Context {Qmeet} {Qjoin} `{@LatticeOrder Q (_ : Le Q) Qmeet Qjoin}.
  Context `{OrderedField F}.
  Context {archim : ArchimedeanProperty Q F}.

  Definition qinc : Cast Q F := rationals_to_field Q F.
  Existing Instance qinc.

  Lemma char_minus_left x y : - x < y -> - y < x.
  Proof.
    intros ltnxy. rewrite <- (negate_involutive x). apply (snd (flip_lt_negate _ _)). assumption.
  Qed.

  Lemma char_minus_right x y : x < - y -> y < - x.
  Proof.
    intros ltnxy. rewrite <- (negate_involutive y). apply (snd (flip_lt_negate _ _)). assumption.
  Qed.

  Lemma char_plus_left : forall (q : Q) (x y : F),
      ' q < x + y <-> hexists (fun s : Q => (' s < x) /\ (' (q - s) < y)).
  Proof. Abort.
  Lemma char_plus_right : forall (r : Q) (x y : F),
      x + y < ' r <-> hexists (fun t : Q => (x < ' t) /\ (y < ' (r - t))).
  Proof. Abort.

  Definition hexists4 {X Y Z W} (f : X -> Y -> Z -> W -> Type) : HProp
    := hexists (fun xyzw => match xyzw with
                            | ((x , y) , (z , w)) => f x y z w
                            end).

  Lemma char_times_left : forall (q : Q) (x y : F),
          ' q < x * y
      <-> hexists4 (fun a b c d : Q =>
                      (q < meet (meet a b) (meet c d))
                      /\
                      ((' a < x < ' b)
                       /\
                       (' c < y < ' d)
                      )
                   ).
  Proof. Abort.
  Lemma char_times_right : forall (r : Q) (x y : F),
          x * y < ' r
      <-> hexists4 (fun a b c d : Q =>
                      and (join (join a b) (join c d) < r)
                          (and
                             (' a < x < ' b)
                             (' c < y < ' d)
                          )
                   ).
  Proof. Abort.
  Lemma char_recip_pos_left : forall (q : Q) (z : F) (nu : 0 < z),
    'q < recip' z (positive_apart_zero z nu) <-> ' q * z < 1.
  Proof. Abort.
  Lemma char_recip_pos_right : forall (r : Q) (z : F) (nu : 0 < z),
    recip' z (positive_apart_zero z nu) < ' r <-> 1 < ' r * z.
  Proof. Abort.
  Lemma char_recip_neg_left : forall (q : Q) (w : F) (nu : w < 0),
    'q < recip' w (negative_apart_zero w nu) <-> ' q * w < 1.
  Proof. Abort.
  Lemma char_recip_neg_right : forall (r : Q) (w : F) (nu : w < 0),
    recip' w (negative_apart_zero w nu) < ' r <-> ' r * w < 1.
  Proof. Abort.

  Lemma char_meet_left : forall (q : Q) (x y : F),
      ' q < meet x y <-> ' q < x /\ ' q < y.
  Proof. Abort.
  Lemma char_meet_right : forall (r : Q) (x y : F),
      meet x y < 'r <-> hor (x < 'r) (y < 'r).
  Proof. Abort.
  Lemma char_join_left : forall (q : Q) (x y : F),
      ' q < join x y <-> hor ('q < x) ('q < y).
  Proof. Abort.
  Lemma char_join_right : forall (r : Q) (x y : F),
      join x y < ' r <-> x < ' r /\ y < ' r.
  Proof. Abort.

End strict_field_order.


Require Import ListAux.
Require Import TreeAux.
Lemma batchedq1consistent_ListIsEmpty0 (il_0:list nat) (b_0:bool) (u_0:nat) : (is_empty_spec  il_0 b_0) -> ((Bool.Is_true b_0) -> (not (list_member  il_0 u_0))).
Proof. solve_is_empty. Qed.

Lemma batchedq1consistent_ListIsEmpty1 (il_0:list nat) (b_0:bool) (u_0:nat) : (is_empty_spec  il_0 b_0) -> ((Bool.Is_true b_0) -> (not (list_head  il_0 u_0))).
Proof. solve_is_empty. Qed.

Lemma batchedq1consistent_ListIsEmpty2 (il_0:list nat) (b_0:bool) (u_0:nat) : (is_empty_spec  il_0 b_0) -> (((not (list_member  il_0 u_0))/\(not (Bool.Is_true b_0))) -> (not (list_head  il_0 u_0))).
Proof. solve_is_empty. Qed.


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

 This defines the dynamic semantics of heap objects, pg. 60.

*)

Require Export LanguageModuleDef.

Inductive get : E -> Path -> E -> Prop :=
 | get_pdot: forall (v : E),
               Value v ->
               get v [] v
 | get_l:    forall (v v0 v1 : E) (p : Path),
               Value v  ->
               Value v0 ->
               Value v1 ->
               get v0 p v ->
               get (cpair v0 v1) ((i_pe zero_pe) :: p) v
 | get_r:    forall (v v0 v1 : E) (p : Path),
               Value v  ->
               Value v0 ->
               Value v1 ->
               get v1 p v ->
               get (cpair v0 v1) ((i_pe one_pe) :: p) v
 | get_pack: forall (v v1 : E) (p : Path) (tau tau' : Tau) (alpha : TVar)
                    (k : Kappa),
               Value v  ->
               Value v1 ->
               get v1 p v ->
               get (pack tau' v1 (etype aliases k tau)) (u_pe :: p) v.

Inductive set : E -> Path -> E -> E -> Prop :=
  | set_ip: forall (v v' : E),
                Value v  ->
                Value v' ->
                set v' [] v v

  | set_l:    forall (v v' v0 v1 : E) (p : Path),
                Value v  ->
                Value v' ->
                Value v0 ->
                set v0 p v v' ->
                set (cpair v0 v1)  ((i_pe zero_pe) :: p) v (cpair v' v1)

  | set_r:    forall (v v' v0 v1 : E) (p : Path),
                Value v  ->
                Value v' ->
                Value v0 ->
                set v1 p v v' ->
                set (cpair v0 v1)  ((i_pe one_pe) :: p) v (cpair v0 v')

  | set_pack: forall (v v' v1 : E) (p : Path) (tau tau' : Tau)
                     (q : Phi) (alpha : TVar) (k : Kappa),
                Value v  ->
                Value v' ->
                Value v1 ->
                set (pack tau' v1 (etype q k tau))
                    (u_pe :: p) v (pack tau' v' (etype q k tau)).


(* begin hide *)
Require Export HoTT Ch04.
(* end hide *)
(** printing <~> %\ensuremath{\eqvsym}% **)
(** printing == %\ensuremath{\sim}% **)
(** printing ^-1 %\ensuremath{^{-1}}% **)
(** * Induction *)

(** %\exerdone{5.1}{175}%
Derive the induction principle for the type $\lst{A}$ of lists from its
definition as an inductive type in %\S5.1%.
*)

(** %\soln%
The induction principle constructs an element $f : \prd{\ell:\lst{A}} P(\ell)$
for some family $P : \lst{A} \to \UU$.  The constructors for $\lst{A}$ are
$\nil : \lst{A}$ and $\cons : A \to \lst{A} \to \lst{A}$, so the hypothesis for
the induction principle is given by
%\[
  d : P(\nil)
      \to \left(\prd{h:A} \prd{t:\lst{A}}P(t) \to P(\cons(h, t))\right)
      \to \prd{\ell:\lst{A}}P(\ell)
\]%
So, given a $p_{n} : P(\nil)$ and a function $p_{c} : \prd{h:A} \prd{t:\lst{A}}
P(t) \to P(\cons(h, t))$, we obtain a function $f : \prd{\ell:\lst{A}}P(\ell)$
with the following computation rules:
%\begin{align*}
  f(\nil) &\defeq p_{n} \\
  f(\cons(h, t)) &\defeq p_{c}(h, t, f(t))
\end{align*}%
In Coq we can just use the pattern-matching syntax.
*)

Module Ex1.

  Section Ex1.
    Variable A : Type.
    Variable P : list A -> Type.
    Hypothesis d : P nil
                   -> (forall h t, P t -> P (cons h t))
                   -> forall l, P l.
    Variable p_n : P nil.
    Variable p_c : forall h t, P t -> P (cons h t).

    Fixpoint f (l : list A) : P l :=
      match l with
        | nil => p_n
        | cons h t => p_c h t (f t)
      end.
    End Ex1.
End Ex1.

(** %\exerdone{5.2}{175}%
Construct two functions on natural numbers which satisfy the same recurrence
$(e_{z}, e_{s})$ but are not definitionally equal.
*)

(** %\soln%
Let $C$ be any type, with $c : C$ some element.  The constant function
$f' \defeq \lam{n}c$ is not definitionally equal to the function
defined recursively by
%\begin{align*}
  f(0) &\defeq c \\
  f(\suc(n)) &\defeq f(n)
\end{align*}%
However, they both satisfy the same recurrence; namely, $e_{z} \defeq c$ and
$e_{s} \defeq \lam{n}\idfunc{C}$.
*)

Module Ex2.
Section Ex2.
  Variables (C : Type) (c : C).

  Definition f (n : nat) := c.
  Fixpoint f' (n : nat) :=
    match n with
      | O => c
      | S n' => f' n'
    end.

  Theorem ex5_2_O : f O = f' O.
  Proof.
    reflexivity.
  Qed.

  Theorem ex5_2_S : forall n, f (S n) = f' (S n).
  Proof.
    intros. unfold f, f'.
    induction n. reflexivity. apply IHn.
  Qed.
End Ex2.
End Ex2.

(** %\exerdone{5.3}{175}%
Construct two different recurrences $(e_{z}, e_{s})$ on the same type $E$ which
are both satisfied by the same function $f : \N \to E$.
*)

(** %\soln%
From the previous exercise we have the recurrences
%\[
  e_{z} \defeq c
  \qquad\qquad
  e_{s} \defeq \lam{n}\idfunc{C}
\]%
which give rise to the same function as the recurrences
%\[
  e'_{z} \defeq c
  \qquad\qquad
  e'_{s} \defeq \lam{n}\lam{x}c
\]%
Clearly $f \defeq \lam{n}c$ satisfies both of these recurrences.
However, suppose that $c, c' : C$ are such that $c \neq c'$.  Then
$\lam{n}\lam{x} \neq \lam{n}\idfunc{C}$, so $e_{s} \neq e'_{s}$, so
the recurrences are not equal.
*)

Module Ex3.
Section Ex3.
  Variables (C : Type) (c c' : C) (p : ~ (c = c')).

  Definition ez := c.
  Definition es (n : nat) (x : C) := x.
  Definition ez' := c.
  Definition es' (n : nat) := fun (x : C) => c.

  Theorem f_O : Ex2.f C c O = ez.
  Proof.
    reflexivity.
  Defined.
  Theorem f_S : forall n, Ex2.f C c (S n) = es n (Ex2.f C c n).
  Proof.
    reflexivity.
  Defined.

  Theorem f_O' : Ex2.f C c O = ez'.
  Proof.
    reflexivity.
  Defined.
  Theorem f_S' : forall n, Ex2.f C c (S n) = es' n (Ex2.f C c n).
  Proof.
    reflexivity.
  Defined.

  Theorem ex5_3 : ~ ((ez, es) = (ez', es')).
  Proof.
    intro q. apply (ap snd) in q. simpl in q. unfold es, es' in q.
    assert (idmap = fun x:C => c) as r.
    apply (apD10 q O).
    assert (c' = c) as s.
    apply (apD10 r).
    symmetry in s.
    contradiction p.
  Defined.

End Ex3.
End Ex3.

(** %\exerdone{5.4}{175}%
Show that for any type family $E : \bool \to \UU$, the induction operator
%\[
  \ind{\bool}(E) :
  (E(0_{\bool}) \times E(1_{\bool}))
  \to
  \prd{b : \bool} E(b)
\]%
is an equivalence.
*)

(** %\soln%
For a quasi-inverse, suppose that $f : \prd{b:\bool} E(b)$.  To provide an
element of $E(0_{\bool}) \times E(1_{\bool})$, we take the pair $(f(0_{\bool}),
f(1_{\bool}))$.  For one direction around the loop, consider an element
$(e_{0}, e_{1})$ of the domain.  We then have
%\[
  \left(
    \ind{\bool}(E, e_{0}, e_{1}, 0_{\bool}),
    \ind{\bool}(E, e_{0}, e_{1}, 1_{\bool})
  \right)
  \equiv
  ( e_{0}, e_{1} )
\]%
by the computation rule for $\ind{\bool}$.  For the other direction, suppose
that $f : \prd{b:\bool} E(b)$, so that once around the loop gives
$\ind{\bool}(E, f(0_{\bool}), f(1_{\bool}))$.  Suppose that $b : \bool$.  Then
there are two cases:
 - $b \equiv 0_{\bool}$ gives $\ind{\bool}(E, f(0_{\bool}), f(1_{\bool}),
   0_{\bool}) \equiv f(0_{\bool})$
 - $b \equiv 1_{\bool}$ gives $\ind{\bool}(E, f(0_{\bool}), f(1_{\bool}),
   1_{\bool}) \equiv f(1_{\bool})$
by the computational rule for $\ind{\bool}$.  By function extensionality, then,
the result is equal to $f$.
*)

Definition Bool_rect_uncurried (E : Bool -> Type) :
  (E false) * (E true) -> (forall b, E b).
  intros p b. destruct b; [apply (snd p) | apply (fst p)].
Defined.

Definition Bool_rect_uncurried_inv (E : Bool -> Type) :
  (forall b, E b) -> (E false) * (E true).
  intro f. split; [apply (f false) | apply (f true)].
Defined.

Theorem ex5_4 `{Funext} (E : Bool -> Type) : IsEquiv (Bool_rect_uncurried E).
Proof.
  refine (isequiv_adjointify _ (Bool_rect_uncurried_inv E) _ _);
    unfold Bool_rect_uncurried, Bool_rect_uncurried_inv.
  intro f. apply path_forall; intro b. destruct b; reflexivity.
  intro p. apply eta_prod.
Qed.

(** %\exerdone{5.5}{175}%
Show that the analogous statement to Exercise 5.4 for $\N$ fails.
*)

(** %\soln%
The analogous statement is that
%\[
  \ind{\N}(E) : \left(E(0) \times \prd{n:\N}E(n) \to E(\suc(n))\right)
  \to
  \prd{n:\N}E(n)
\]%
is an equivalence.  To show that it fails, note that an element of the domain
is a recurrence $(e_{z}, e_{s})$.  Recalling the solution to Exercise 5.3, we
have recurrences $(e_{z}, e_{s})$ and $(e'_{z}, e'_{s})$ such that $(e_{z},
e_{s}) \neq (e'_{z}, e'_{s})$, but such that $\ind{\N}(E, e_{z}, e_{s}) =
\ind{\N}(E, e'_{z}, e'_{s})$.  Suppose for contradiction that
$\ind{\N}(E)$ has a quasi-inverse $\ind{\N}^{-1}(E)$.  Then
%\[
  (e_{z}, e_{s})
  =
  \ind{\N}^{-1}(E, \ind{\N}(E, e_{z}, e_{s}))
  =
  \ind{\N}^{-1}(E, \ind{\N}(E, e'_{z}, e'_{s}))
  =
  (e'_{z}, e'_{s})
\]%
The first and third equality are from the fact that a quasi-inverse is a left
inverse.  The second comes from the fact that $\ind{\N}(E)$ sends the two
recurrences to the same function.  So we have derived a contradiction.
*)

Definition nat_rect_uncurried (E : nat -> Type) :
  (E O) * (forall n, E n -> E (S n)) -> forall n, E n.
  intros p n. induction n. apply (fst p). apply (snd p). apply IHn.
Defined.

Theorem ex5_5 `{Funext} : ~ IsEquiv (nat_rect_uncurried (fun _ => Bool)).
Proof.
  intro e. destruct e.
  set (ez := (Ex3.ez Bool true)).
  set (es := (Ex3.es Bool)).
  set (ez' := (Ex3.ez' Bool true)).
  set (es' := (Ex3.es' Bool true)).
  assert ((ez, es) = (ez', es')) as H'.
  transitivity (equiv_inv (nat_rect_uncurried (fun _ => Bool) (ez, es))).
  symmetry. apply eissect.
  transitivity (equiv_inv (nat_rect_uncurried (fun _ => Bool) (ez', es'))).
  apply (ap equiv_inv). apply path_forall; intro n. induction n.
    reflexivity.
    simpl. rewrite IHn. unfold Ex3.es, Ex3.es'. induction n; reflexivity.
  apply eissect.
  assert (~ ((ez, es) = (ez', es'))) as nH.
    apply (Ex3.ex5_3 Bool true false). apply true_ne_false.
    contradiction nH.
Qed.

(** %\exer{5.6}{175}%
Show that if we assume simple instead of dependent elimination for $\w$-types,
the uniqueness property fails to hold.  That is, exhibit a type satisfying the
recursion principle of a $\w$-type, but for which functions are not determined
uniquely by their recurrence.
*)

(** %\exerdone{5.7}{175}%
Suppose that in the ``inductive definition'' of the type $C$ at the beginning
of %\S5.6%, we replace the type $\N$ by $\emptyt$.  Analogously to
5.6.1, we might consider a recursion principle for this type with hypothesis
%\[
  h : (C \to \emptyt) \to (P \to \emptyt) \to P.
\]%
Show that even without a computation rule, this recursion principle is
inconsistent, %i.e.~it% allows us to construct an element of $\emptyt$.
*)

(** %\soln%
The constructor for $C$ is $g : (C \to \emptyt) \to C$, and the associated
recursion principle is
%\[
  \rec{C} : \prd{P:\UU} ((C \to \emptyt) \to (P \to \emptyt) \to P) \to C \to P
\]%
Note first that the relevant recursion hypothesis can be constructed from $g$:
%\[
  h
  \defeq \lam{f:C \to \emptyt}{i:\emptyt \to \emptyt}f(g(f))
  : ((C \to \emptyt) \to (\emptyt \to \emptyt) \to \emptyt) \to \emptyt
\]%
And so we have $\rec{C}(\emptyt, h) : C \to \emptyt$.  But then
%\[
  \rec{C}(\emptyt, h, g(\rec{C}(\emptyt, h))) : \emptyt
\]%
meaning that our recursion principle is inconsistent.

Alternatively, note that there is an equivalence
%\begin{align*}
  (C \to \emptyt) \to (\emptyt \to \emptyt) \to \emptyt
  &\eqvsym
  (C \to \emptyt) \times (\emptyt \to \emptyt) \to \emptyt
  \eqvsym
  (C \to \emptyt) \times \unit \to \emptyt
  \eqvsym
  (C \to \emptyt) \to \emptyt
  \equiv \lnot\lnot C
\end{align*}%
so the recursion principle says $\lnot\lnot C \to \lnot C$.  By double negation
introduction composed with this we get $C \to \lnot C$.  On the other hand, by
$g$ we have $\lnot C \to C$, and composing this with the recursion principle
gives $\lnot\lnot C \to C$.  So $C$ is decidable, and in both cases we have a
contradiction because $C \to \lnot C$ and $\lnot C \to C$.
*)

Section Ex7.

Variable (C : Type) (g : (C -> Empty) -> C).
Variable (rec : forall P, ((C -> Empty) -> (P -> Empty) -> P) -> C -> P).

Theorem ex7 : Empty.
Proof.
  set (h := (fun k i => k (g k)): ((C -> Empty) -> (Empty -> Empty) -> Empty)).
  apply (rec Empty h).
  apply g. apply (rec Empty h).
Defined.

End Ex7.

(** %\exerdone{5.8}{175}%
Consider now an ``inductive type'' $D$ with one constructor $\mathsf{scott} :
(D \to D) \to D$.  The second recursor for $C$ suggested in %\S5.6% leads to
the following recursor for $D$:
%\[
  \rec{D} : \prd{P:\UU} ((D \to D) \to (D \to P) \to P) \to D \to P
\]%
with computation rule $\rec{D}(P, h, \mathsf{scott}(\alpha)) \equiv h(\alpha,
(\lam{d}\rec{D}(P, h, \alpha(d))))$. Show that this also leads to a
contradiction.
*)

(** %\soln%
As in the previous problem, we can construct the recursion hypothesis from the
constructor:
%\[
  h
  \defeq \lam{f : D \to D}{g : D \to \emptyt}g(\mathsf{scott}(f))
  : (D \to D) \to (D \to \emptyt) \to \emptyt
\]%
Then by $h(\idfunc{D})$ it suffices to give a function $D \to \emptyt$ to
construct an element of $\emptyt$, which we have in $\lam{d:D}\rec{D}(\emptyt,
h, d) : \emptyt$.  So, putting it all together, we have
%\[
  h(\idfunc{D}, \lam{d}\rec{D}(\emptyt, h, d))
\]%
which by the computation rule is judgementally equal to
%\[
  \rec{D}(\emptyt, h, \mathsf{scott}(\idfunc{D})).
\]%
*)

Section Ex8.

Variable (D : Type) (scott : (D -> D) -> D).
Hypothesis (rec : forall P, ((D -> D) -> (D -> P) -> P) -> D -> P).

Theorem ex8 : Empty.
Proof.
  set (h := (fun f g => g (scott f)) : (D -> D) -> (D -> Empty) -> Empty).
  apply (h idmap). intro d.
  apply (rec Empty h d).
Defined.

End Ex8.

(** %\exerdone{5.9}{176}%
Let $A$ be an arbitrary type and consider generally an ``inductive definition''
of a type $L_{A}$ with constructor $\mathsf{lawvere}:(L_{A} \to A) \to L_{A}$.
The second recursor for $C$ suggested in %\S5.6% leads to the following
recursor for $L_{A}$:
%\[
  \rec{L_{A}} : \prd{P:\UU} ((L_{A} \to A) \to P) \to L_{A} \to P
\]%
with computation rule $\rec{L_{A}}(P, h, \mathsf{lawvere}(\alpha)) \equiv
h(\alpha)$.  Using this, show that $A$ has a _fixed-point property_, %i.e.~for%
every function $f : A \to A$ there exists an $a : A$ such that $f(a) = a$.  In
particular, $L_{A}$ is inconsistent if $A$ is a type without the fixed-point
property, such as $\emptyt$, $\bool$, $\N$.
*)

(** %\soln%
This is an instance of Lawvere's fixed-point theorem, which says that in a
cartesian closed category, if there is a point-surjective map $T \to A^{T}$,
then every endomorphism $f : A \to A$ has a fixed point.  Working at an
intuitive level, the recursion principle ensures that we have the required
properties of a point-surjective map in a CCC.  In particular, we have the map
$\phi : (L_{A} \to A) \to A^{L_{A} \to A}$ given by
%\[
  \phi \defeq
  \lam{f : L_{A} \to A}{\alpha : L_{A} \to A}f(\mathsf{lawvere}(\alpha))
\]%
and for any $h : A^{L_{A} \to A}$, we have
%\[
  \phi(\rec{L_{A}}(A, h))
  \equiv
  \lam{\alpha : L_{A} \to A}\rec{L_{A}}(A, h, \mathsf{lawvere}(\alpha))
  \equiv
  \lam{\alpha : L_{A} \to A}h(\alpha)
  =
  h
\]%
So we can recap the proof of Lawvere's fixed-point theorem with this $\phi$.
Suppose that $f : A \to A$, and define
%\begin{align*}
  q &\defeq \lam{\alpha:L_{A} \to A}f(\phi(\alpha, \alpha))
     : (L_{A} \to A) \to A \\
  p &\defeq \rec{L_{A}}(A, q)
     : L_{A} \to A
\end{align*}%
so that $p$ lifts $q$:
%\[
  \phi(p)
  \equiv
  \lam{\alpha : L_{A} \to A}\rec{L_{A}}(A, q, \mathsf{lawvere}(\alpha))
  \equiv
  \lam{\alpha : L_{A} \to A}q(\alpha)
  =
  q
\]%
This make $\phi(p, p)$ a fixed point of $f$:
%\[
  f(\phi(p, p))
  = (\lam{\alpha : L_{A} \to A}f(\phi(\alpha, \alpha)))(p)
  = q(p)
  = \phi(p, p)
\]%
*)

Definition onto {X Y} (f : X -> Y) := forall y : Y, {x : X & f x = y}.

Lemma LawvereFP {X Y} (phi : X -> (X -> Y)) :
  onto phi -> forall (f : Y -> Y), {y : Y & f y = y}.
Proof.
  intros Hphi f.
  set (q := fun x => f (phi x x)).
  set (p := Hphi q). destruct p as [p Hp].
  exists (phi p p).
  change (f (phi p p)) with ((fun x => f (phi x x)) p).
  change (fun x => f (phi x x)) with q.
  symmetry. apply (apD10 Hp).
Defined.

Module Ex9.
Section Ex9.

Variable (L A : Type).
Variable lawvere : (L -> A) -> L.
Variable rec : forall P, ((L -> A) -> P) -> L -> P.
Hypothesis rec_comp : forall P h alpha, rec P h (lawvere alpha) = h alpha.

Definition phi : (L -> A) -> ((L -> A) -> A) :=
  fun f alpha => f (lawvere alpha).

Theorem ex5_9 `{Funext} : forall (f : A -> A), {a : A & f a = a}.
Proof.
  intro f. apply (LawvereFP phi).
  intro q. exists (rec A q). unfold phi.
  change q with (fun alpha => q alpha).
  apply path_forall; intro alpha. apply rec_comp.
Defined.

End Ex9.
End Ex9.

(** %\exerdone{5.10}{176}%
Continuing from Exercise 5.9, consider $L_{\unit}$, which is not obviously
inconsistent since $\unit$ does have the fixed-point property.  Formulate an
induction principle for $L_{\unit}$ and its computation rule, analogously to
its recursor, and using this, prove that it is contractible.
*)

(** %\soln%
The induction principle for $L_{\unit}$ is
%\[
  \ind{L_{\unit}}
  : \prd{P : L_{\unit} \to \UU}
    \left(\prd{\alpha : L_{\unit} \to \unit} P(\mathsf{lawvere}(\alpha))\right)
    \to \prd{\ell : L_{\unit}}P(\ell)
\]%
and it has the computation rule
%\[
  \ind{L_{\unit}}(P, f, \mathsf{lawvere}(\alpha)) \equiv f(\alpha)
\]%
for all $f : \prd{\alpha : L_{\unit} \to \unit} P(\mathsf{lawvere}(\alpha))$
and $\alpha : L_{\unit} \to \unit$.

Let ${!} : L_{\unit} \to \unit$ be the unique terminal arrow.
$L_{\unit}$ is contractible with center $\mathsf{lawvere}({!})$.  By
$\ind{L_{\unit}}$, it suffices to show that $\mathsf{lawvere}({!}) =
\mathsf{lawvere}(\alpha)$ for any $\alpha : L_{\unit} \to \unit$.  And by the
universal property of the terminal object, $\alpha = {!}$, so we're done.
*)

Module Ex10.
Section Ex10.

Variable L : Type.
Variable lawvere : (L -> Unit) -> L.

Variable indL : forall P, (forall alpha, P (lawvere alpha)) -> forall l, P l.
Hypothesis ind_comp : forall P f alpha, indL P f (lawvere alpha) = f alpha.

Theorem ex5_10 `{Funext} : Contr L.
Proof.
  apply (BuildContr L (lawvere (fun _ => tt))).
  apply indL; intro alpha.
  apply (ap lawvere).
  apply path_ishprop.
Defined.

End Ex10.
End Ex10.

(** %\exerdone{5.11}{176}%
In %\S5.1% we defined the type $\lst{A}$ of finite lists of elements of some
type $A$.  Consider a similiar inductive definition of a type $\lost{A}$, whose
only constructor is
%\[
  \cons : A \to \lost{A} \to \lost{A}.
\]%
Show that $\lost{A}$ is equivalent to $\emptyt$.
*)

(** %\soln%
Consider the recursor for $\lost{A}$, given by
%\[
  \rec{\lost{A}} : \prd{P : \UU} (A \to \lost{A} \to P \to P) \to \lost{A} \to P
\]%
with computation rule
%\[
  \rec{\lost{A}}(P, f, \cons(h, t)) \equiv f(h, \rec{\lost{A}}(P, f, t))
\]%
Now $\rec{\lost{A}}(\emptyt, \lam{a}{\ell}\idfunc{\emptyt}) : \lost{A} \to
\emptyt$, so $\lnot \lost{A}$ is inhabited, thus $\lost{A} \eqvsym \emptyt$.
*)

Theorem not_equiv_empty (A : Type) : ~ A -> (A <~> Empty).
Proof.
  intro nA. refine (equiv_adjointify nA (Empty_rect (fun _ => A)) _ _);
  intro; contradiction.
Defined.

Module Ex11.

Inductive lost (A : Type) := cons : A -> lost A -> lost A.

Theorem ex5_11 (A : Type) : lost A <~> Empty.
Proof.
  apply not_equiv_empty.
  intro l.
  apply (lost_rect A). auto. apply l.
Defined.

End Ex11.


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

 The bicategory of objects with an endomorphisms

 Note: if we would have defined this bicategory via algebras on a
 pseudofunctor, then we would have obtained a different notion of 1-cell.
 In this file, we define it in such a way, that the commutativity cell
 of 1-cells do not have to be invertible.

 Contents
 1. The definition via displayed bicategories
 2. The univalence

 ************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.

Local Open Scope cat.

Section EndoMap.
  Context (B : bicat).

  (**
   1. The definition via displayed bicategories
   *)
  Definition disp_end_ob_mor
    : disp_cat_ob_mor B.
  Proof.
    use make_disp_cat_ob_mor.
    - exact (λ x, x --> x).
    - exact (λ x y mx my f, f · my ==> mx · f).
  Defined.

  Definition disp_end_cat_id_comp
    : disp_cat_id_comp B disp_end_ob_mor.
  Proof.
    simple refine (_ ,, _).
    - exact (λ x mx, lunitor _ • rinvunitor _).
    - exact (λ x y z f g mx my mz mf mg,
             rassociator _ _ _
             • (_ ◃ mg)
             • lassociator _ _ _
             • (mf ▹ _)
             • rassociator _ _ _).
  Defined.

  Definition disp_end_cat_data
    : disp_cat_data B.
  Proof.
    simple refine (_ ,, _).
    - exact disp_end_ob_mor.
    - exact disp_end_cat_id_comp.
  Defined.

  Definition disp_end_prebicat_1_id_comp_cells
    : disp_prebicat_1_id_comp_cells B.
  Proof.
    simple refine (_ ,, _).
    - exact disp_end_cat_data.
    - exact (λ x y f g α mx my mf mg,
             mf • (_ ◃ α)
             =
             (α ▹ _) • mg).
  Defined.

  Definition disp_end_prebicat_ops
    : disp_prebicat_ops disp_end_prebicat_1_id_comp_cells.
  Proof.
    repeat split.
    - intros x y f mx my mf ; cbn in *.
      rewrite lwhisker_id2, id2_rwhisker.
      rewrite id2_left, id2_right.
      apply idpath.
    - intros x y f mx my mf ; cbn in *.
      rewrite !vassocl.
      rewrite lunitor_lwhisker.
      rewrite rwhisker_vcomp.
      rewrite !vassocl.
      rewrite rinvunitor_runitor.
      rewrite id2_right.
      rewrite lunitor_triangle.
      rewrite !vcomp_lunitor.
      rewrite !vassocr.
      rewrite <- lunitor_triangle.
      rewrite !vassocr.
      rewrite rassociator_lassociator.
      rewrite id2_left.
      apply idpath.
    - intros x y f mx my mf ; cbn in *.
      rewrite !vassocl.
      rewrite runitor_triangle.
      rewrite vcomp_runitor.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      rewrite <- runitor_triangle.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        apply id2_left.
      }
      rewrite lwhisker_vcomp.
      rewrite !vassocl.
      rewrite rinvunitor_runitor.
      rewrite id2_right.
      rewrite lunitor_lwhisker.
      apply idpath.
    - intros x y f mx my mf ; cbn in *.
      rewrite !vassocr.
      rewrite <- linvunitor_assoc.
      rewrite !lwhisker_hcomp.
      rewrite <- linvunitor_natural.
      rewrite <- !lwhisker_hcomp.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite linvunitor_assoc.
      rewrite !vassocl.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rassociator_lassociator.
        rewrite id2_left.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite !vassocr.
      rewrite linvunitor_lunitor.
      rewrite id2_left.
      rewrite rwhisker_hcomp.
      rewrite <- triangle_r_inv.
      rewrite <- lwhisker_hcomp.
      apply idpath.
    - intros x y f mx my mf ; cbn in *.
      rewrite !vassocr.
      rewrite rwhisker_hcomp.
      rewrite <- triangle_r_inv.
      rewrite <- lwhisker_hcomp.
      rewrite lwhisker_vcomp.
      rewrite !vassocr.
      rewrite linvunitor_lunitor.
      rewrite id2_left.
      rewrite <- left_unit_inv_assoc₂.
      rewrite rwhisker_hcomp.
      rewrite <- rinvunitor_natural.
      rewrite !vassocl.
      rewrite left_unit_inv_assoc₂.
      rewrite !vassocl.
      rewrite lassociator_rassociator.
      rewrite id2_right.
      apply idpath.
    - intros w x y z f g h mw mx my mz mf mg mh ; cbn in *.
      rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp.
      rewrite !vassocl.
      etrans.
      {
        do 7 apply maponpaths.
        rewrite !vassocr.
        rewrite rassociator_rassociator.
        apply idpath.
      }
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite rassociator_rassociator.
      rewrite !vassocl.
      apply maponpaths.
      rewrite rwhisker_rwhisker_alt.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite lwhisker_lwhisker_rassociator.
      use vcomp_move_L_Mp ; [ is_iso | ] ; cbn.
      rewrite !vassocl.
      apply maponpaths.
      rewrite <- rassociator_rassociator.
      use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite <- rassociator_rassociator.
      rewrite !vassocl.
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite lassociator_rassociator.
        rewrite id2_rwhisker.
        apply id2_left.
      }
      rewrite <- rwhisker_lwhisker_rassociator.
      apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite rassociator_lassociator.
      rewrite lwhisker_id2.
      rewrite id2_left.
      apply idpath.
    - intros w x y z f g h mw mx my mz mf mg mh ; cbn in *.
      rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp.
      rewrite !vassocr.
      do 2 (use vcomp_move_L_Mp ; [ is_iso | ] ; cbn).
      rewrite !vassocl.
      do 2 (use vcomp_move_R_pM ; [ is_iso | ] ; cbn).
      etrans.
      {
        do 5 apply maponpaths.
        etrans.
        {
          do 2 apply maponpaths.
          rewrite !vassocr.
          rewrite lassociator_lassociator.
          apply idpath.
        }
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite rassociator_lassociator.
          apply id2_left.
        }
        rewrite <- rwhisker_rwhisker.
        apply idpath.
      }
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite lassociator_lassociator.
      refine (!_).
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        rewrite id2_left.
        rewrite !vassocl.
        apply idpath.
      }
      etrans.
      {
        rewrite !vassocr.
        rewrite <- lwhisker_lwhisker.
        rewrite !vassocl.
        apply idpath.
      }
      apply maponpaths.
      rewrite <- lassociator_lassociator.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite <- lassociator_lassociator.
      rewrite !vassocl.
      apply maponpaths.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        rewrite rassociator_lassociator.
        rewrite lwhisker_id2.
        apply id2_left.
      }
      rewrite rwhisker_lwhisker.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      rewrite rwhisker_vcomp.
      rewrite lassociator_rassociator.
      rewrite id2_rwhisker.
      rewrite id2_right.
      apply idpath.
    - intros x y f g h α β mx my mf mg mh mα mβ ; cbn in *.
      rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp.
      rewrite !vassocr.
      rewrite mα.
      rewrite !vassocl.
      apply maponpaths.
      exact mβ.
    - intros x y z f g₁ g₂ α mx my mz mf mg₁ mg₂ mα ; cbn in *.
      rewrite !vassocr.
      rewrite <- rwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite <- mα.
      rewrite <- lwhisker_vcomp.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_lwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- vcomp_whisker.
      rewrite !vassocl.
      rewrite lwhisker_lwhisker_rassociator.
      apply idpath.
    - intros x y z f₁ f₂ g α mx my mz mf₁ mf₂ mg mα ; cbn in *.
      rewrite !vassocr.
      rewrite rwhisker_rwhisker_alt.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite vcomp_whisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- rwhisker_rwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite <- mα.
      rewrite <- !rwhisker_vcomp.
      rewrite !vassocl.
      rewrite rwhisker_lwhisker_rassociator.
      apply idpath.
  Qed.

  Definition disp_end_prebicat_data
    : disp_prebicat_data B.
  Proof.
    simple refine (_ ,, _).
    - exact disp_end_prebicat_1_id_comp_cells.
    - exact disp_end_prebicat_ops.
  Defined.

  Definition disp_end_prebicat_laws
    : disp_prebicat_laws disp_end_prebicat_data.
  Proof.
    repeat split ; intro ; intros ; apply cellset_property.
  Qed.

  Definition disp_end_prebicat
    : disp_prebicat B.
  Proof.
    simple refine (_ ,, _).
    - exact disp_end_prebicat_data.
    - exact disp_end_prebicat_laws.
  Defined.

  Definition disp_end : disp_bicat B.
  Proof.
    simple refine (_ ,, _).
    - exact disp_end_prebicat.
    - intro ; intros.
      use isasetaprop.
      apply cellset_property.
  Defined.

  Definition end_bicat : bicat := total_bicat disp_end.

  Definition disp_2cells_isaprop_end_bicat
    : disp_2cells_isaprop disp_end.
  Proof.
    intros x y f g τ ex ey ef eg.
    apply cellset_property.
  Qed.

  Definition disp_locally_sym_end_bicat
    : disp_locally_sym disp_end.
  Proof.
    intros x y f g τ ex ey ef eg eτ ; cbn in eτ ; cbn.
    use vcomp_move_R_Mp ; [ is_iso | ] ; cbn.
    rewrite !vassocl.
    use vcomp_move_L_pM ; [ is_iso | ] ; cbn.
    exact (!(eτ)).
  Qed.

  Definition disp_locally_groupoid_end_bicat
    : disp_locally_groupoid disp_end.
  Proof.
    use make_disp_locally_groupoid.
    - exact disp_locally_sym_end_bicat.
    - exact disp_2cells_isaprop_end_bicat.
  Qed.

  (**
   2. The univalence
   *)
  Definition disp_univalent_2_1_disp_end
    : disp_univalent_2_1 disp_end.
  Proof.
    intros x y f g p ex ey ef eg.
    induction p.
    use isweqimplimpl.
    - intro τ.
      pose (p := pr1 τ).
      cbn in p.
      rewrite lwhisker_id2, id2_rwhisker in p.
      rewrite id2_left, id2_right in p.
      cbn.
      exact p.
    - apply cellset_property.
    - use invproofirrelevance.
      intros τ₁ τ₂.
      use subtypePath ; [ intro ; apply isaprop_is_disp_invertible_2cell | ].
      apply disp_2cells_isaprop_end_bicat.
  Qed.

  Definition inv2cell_to_disp_adj_equiv_disp_end
             {x : B}
             {ex ey : disp_end x}
             (τ : invertible_2cell ex ey)
    : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) ex ey.
  Proof.
    simple refine (_ ,, ((_ ,, (_ ,, _)) ,, ((_ ,, _) ,, (_ ,, _)))).
    - exact (lunitor _ • τ^-1 • rinvunitor _).
    - exact (lunitor _ • τ • rinvunitor _).
    - abstract
        (cbn ;
         rewrite <- !lwhisker_vcomp ;
         rewrite <- !rwhisker_vcomp ;
         rewrite !vassocr ;
         rewrite <- linvunitor_assoc ;
         refine (!_) ;
         rewrite lwhisker_hcomp ;
         rewrite <- linvunitor_natural ;
         rewrite !vassocl ;
         apply maponpaths ;
         rewrite !rwhisker_hcomp ;
         rewrite <- triangle_r_inv ;
         rewrite <- !lwhisker_hcomp ;
         rewrite <- !rwhisker_hcomp ;
         rewrite !vassocr ;
         apply maponpaths_2 ;
         rewrite !vassocl ;
         etrans ;
         [ do 3 apply maponpaths ;
           rewrite !vassocr ;
           rewrite lunitor_triangle ;
           apply idpath
         | ] ;
         etrans ;
         [ do 2 apply maponpaths ;
           rewrite !vassocr ;
           rewrite vcomp_lunitor ;
           rewrite !vassocl;
           rewrite rwhisker_hcomp ;
           rewrite <- rinvunitor_natural ;
           apply idpath
         | ] ;
         rewrite !vassocr ;
         refine (_ @ id2_left _) ;
         apply maponpaths_2 ;
         use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ;
         rewrite !vassocl ;
         use vcomp_move_R_pM ; [ is_iso | ] ; cbn ;
         rewrite id2_left ;
         rewrite vcomp_lunitor ;
         apply idpath).
    - abstract
        (cbn ;
         rewrite <- !lwhisker_vcomp ;
         rewrite <- !rwhisker_vcomp ;
         rewrite !vassocr ;
         rewrite lunitor_lwhisker ;
         rewrite runitor_lunitor_identity ;
         rewrite !vassocl ;
         apply maponpaths ;
         rewrite lunitor_lwhisker ;
         rewrite rwhisker_vcomp ;
         rewrite rinvunitor_runitor ;
         rewrite id2_rwhisker ;
         rewrite id2_right ;
         use vcomp_move_R_pM ; [ is_iso | ] ; cbn ;
         rewrite !vassocr ;
         rewrite rinvunitor_triangle ;
         rewrite rwhisker_hcomp ;
         rewrite <- rinvunitor_natural ;
         rewrite vcomp_lunitor ;
         rewrite !vassocl ;
         apply maponpaths ;
         rewrite rinvunitor_natural ;
         rewrite <- rwhisker_hcomp ;
         apply idpath).
    - apply disp_2cells_isaprop_end_bicat.
    - apply disp_2cells_isaprop_end_bicat.
    - apply disp_locally_groupoid_end_bicat.
    - apply disp_locally_groupoid_end_bicat.
  Defined.

  Definition disp_adj_equiv_to_inv2cell_disp_end
             {x : B}
             {ex ey : disp_end x}
             (τ : disp_adjoint_equivalence
                    (internal_adjoint_equivalence_identity x)
                    ex ey)
    : invertible_2cell ex ey.
  Proof.
    use make_invertible_2cell.
    - exact (linvunitor _ • pr112 τ • runitor _).
    - use make_is_invertible_2cell.
      + exact (linvunitor _ • pr1 τ • runitor _).
      + abstract
          (rewrite !vassocl ;
           use vcomp_move_R_pM ; [ is_iso | ] ; cbn ;
           rewrite !vassocr ;
           use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ;
           rewrite id2_right ;
           use (vcomp_rcancel (ex ◃ linvunitor _)) ; [ is_iso | ] ;
           refine (_ @ !(pr1 (pr212 τ))) ; cbn ;
           rewrite !vassocr ;
           rewrite <- linvunitor_assoc ;
           refine (!_) ;
           rewrite lwhisker_hcomp ;
           rewrite <- linvunitor_natural ;
           rewrite !vassocl ;
           apply maponpaths ;
           rewrite linvunitor_assoc ;
           rewrite !vassocl ;
           rewrite (maponpaths (λ z, _ • z) (vassocr _ _ _)) ;
           rewrite rassociator_lassociator ;
           rewrite id2_left ;
           rewrite !vassocr ;
           rewrite <- vcomp_runitor ;
           rewrite !vassocl ;
           apply maponpaths ;
           rewrite !vassocr ;
           rewrite <- vcomp_runitor ;
           rewrite !vassocl ;
           apply maponpaths ;
           rewrite <- runitor_triangle ;
           rewrite runitor_lunitor_identity ;
           rewrite !vassocl ;
           rewrite lwhisker_vcomp ;
           rewrite lunitor_linvunitor ;
           rewrite lwhisker_id2 ;
           rewrite id2_right ;
           apply idpath).
      + abstract
          (rewrite !vassocl ;
           use vcomp_move_R_pM ; [ is_iso | ] ; cbn ;
           rewrite !vassocr ;
           use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ;
           rewrite id2_right ;
           use (vcomp_lcancel (lunitor _ ▹ ey)) ; [ is_iso | ] ;
           refine (_ @ pr2 (pr212 τ)) ; cbn ;
           rewrite !vassocl ;
           use vcomp_move_L_pM ; [ is_iso | ] ; cbn ;
           rewrite !vassocr ;
           rewrite lunitor_triangle ;
           rewrite <- vcomp_lunitor ;
           rewrite !vassocl ;
           apply maponpaths ;
           rewrite lunitor_runitor_identity ;
           rewrite runitor_triangle ;
           rewrite vcomp_runitor ;
           rewrite !vassocr ;
           apply maponpaths_2 ;
           rewrite !vassocl ;
           rewrite <- vcomp_runitor ;
           rewrite !vassocr ;
           apply maponpaths_2 ;
           use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ;
           rewrite lunitor_triangle ;
           apply idpath).
  Defined.

  Definition inv2cell_weq_disp_adj_equiv_disp_end
             (HB : is_univalent_2_1 B)
             {x : B}
             (ex ey : disp_end x)
    : invertible_2cell ex ey
      ≃
      disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) ex ey.
  Proof.
    use make_weq.
    - exact inv2cell_to_disp_adj_equiv_disp_end.
    - use isweq_iso.
      + exact disp_adj_equiv_to_inv2cell_disp_end.
      + abstract
          (intros τ ;
           use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ;
           cbn ;
           rewrite !vassocr ;
           rewrite linvunitor_lunitor ;
           rewrite id2_left ;
           rewrite !vassocl ;
           rewrite rinvunitor_runitor ;
           apply id2_right).
      + abstract
          (intros τ ;
           use subtypePath ;
           [ intro ;
             use (isaprop_disp_left_adjoint_equivalence _ _ HB) ;
             apply disp_univalent_2_1_disp_end
           | ] ;
           cbn ;
           rewrite !vassocr ;
           rewrite lunitor_linvunitor ;
           rewrite id2_left ;
           rewrite !vassocl ;
           rewrite runitor_rinvunitor ;
           apply id2_right).
  Defined.

  Definition disp_univalent_2_0_disp_end
             (HB : is_univalent_2_1 B)
    : disp_univalent_2_0 disp_end.
  Proof.
    intros x y p ex ey.
    induction p.
    use weqhomot.
    - exact (inv2cell_weq_disp_adj_equiv_disp_end HB ex ey
             ∘ make_weq _ (HB x x ex ey))%weq.
    - abstract
        (intro p ;
         induction p ;
         use subtypePath ;
         [ intro ;
           use (isaprop_disp_left_adjoint_equivalence _ _ HB) ;
           apply disp_univalent_2_1_disp_end
         | ] ;
         cbn ;
         rewrite id2_right ;
         apply idpath).
  Defined.
End EndoMap.


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

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Export Reals.
Require Export ProjectiveGeometry.Dev.general_tactics.

Open Scope R_scope.

(*************************************************)
(* Variable isolation tactic                     *)
(*************************************************)

(*
This module defines a few tactics :

   IsoleVar x H isolates one occurence of x in H
   Warning it does not factorize, but it is still usefull.

   NormalizeRing H normalize the hypothesis H using ring.
   RewriteVar x H, isolates x in H and then substitutes x
   everywhere.
*)

Ltac NormalizeRing H :=
  match goal with
  | i:(?X1 = ?X2) |- _ =>
      match i with
      | H => generalize H; ring_simplify X1 X2; clear H; intro H
      | _ => fail
      end
  end.

Lemma Lc : forall a b : R, a = b -> a - b = 0.
intros.
rewrite H.
ring.
Qed.

Lemma Lcinv : forall a b : R, a - b = 0 -> a = b.
intros.
assert (a - b + b = 0 + b).
rewrite H.
auto.
NormalizeRing H0.
auto.
Qed.

Lemma Lcp1 : forall a b c : R, a + b = c -> a = c - b.
intros.
rewrite <- H.
ring.
Qed.

Lemma Lcp2 : forall a b c : R, a + b = c -> b = c - a.
intros.
rewrite <- H.
ring.
Qed.

Lemma Lcm1 : forall a b c : R, a - b = c -> a = c + b.
intros.
rewrite <- H.
ring.
Qed.

Lemma Lcm2 : forall a b c : R, a - b = c -> b = a - c.
intros.
rewrite <- H.
ring.
Qed.

Lemma Lcop1 : forall a b : R, - a = b -> a = - b.
intros.
rewrite <- H.
ring.
Qed.

Lemma Lcmult1 : forall a b c : R, b <> 0 -> a * b = c -> a = c / b.
intros; field_simplify_eq; auto.
Qed.

Lemma Lcmult2 : forall a b c : R, a <> 0 -> a * b = c -> b = c / a.
intros.
rewrite <- H0; field_simplify_eq; trivial.
Qed.

Lemma Lcdiv1 : forall a b c : R, b <> 0 -> a / b = c -> a = b * c.
intros.
rewrite <- H0.
field.
trivial.
Qed.

Lemma Lcdiv2 : forall a b c : R, b <> 0 -> c <> 0 -> a / b = c -> b = a / c.
intros.
rewrite <- H1.
field.
split; trivial.
intuition.
apply H0.
rewrite <- H1 in |- *.
rewrite H2 in |- *.
unfold Rdiv in |- *;  ring.
Qed.

Ltac IsoleVarAux1 var H T Hyp :=
  match T with
  | (var = ?X2 :>?X1) =>
      assert (Hypazerty : T);
       [ exact H | clear Hyp; rename Hypazerty into Hyp ]
  | (?X1 + ?X2 = ?X3 :>?X4) =>
      IsoleVarAux1 var (Lcp1 X1 X2 X3 H) (X1 = X3 - X2 :>X4) Hyp ||
        IsoleVarAux1 var (Lcp2 X1 X2 X3 H) (X2 = X3 - X1 :>X4) Hyp
  | (?X1 - ?X2 = ?X3 :>?X4) =>
      IsoleVarAux1 var (Lcm1 X1 X2 X3 H) (X1 = X3 + X2 :>X4) Hyp ||
        IsoleVarAux1 var (Lcm2 X1 X2 X3 H) (X2 = X1 - X3 :>X4) Hyp
  | (?X1 / ?X2 = ?X3 :>?X4) =>
      match goal with
      | Hop:(?X2 <> 0) |- _ =>
          IsoleVarAux1 var (Lcdiv1 X1 X2 X3 Hop H) (X1 = X2 * X3 :>X4) Hyp
      | _ =>
          cut (X2 <> 0);
           [ intro;
              match goal with
              | Hop:(?X2 <> 0) |- _ =>
                  IsoleVarAux1 var (Lcdiv1 X1 X2 X3 Hop H)
                   (X1 = X2 * X3 :>X4) Hyp
              end
           | idtac ]
      end ||
        match goal with
        | Hop1:(?X2 <> 0),Hop2:(?X3 <> 0) |- _ =>
            IsoleVarAux1 var (Lcdiv2 X1 X2 X3 Hop1 Hop2 H)
             (X2 = X1 / X3 :>X4) Hyp
        | Hop1:(?X2 <> 0) |- _ =>
            cut (X3 <> 0);
             [ intro;
                match goal with
                | Hop2:(?X3 <> 0) |- _ =>
                    IsoleVarAux1 var (Lcdiv2 X1 X2 X3 Hop1 Hop2 H)
                     (X2 = X1 / X3 :>X4) Hyp
                end
             | idtac ]
        | Hop2:(?X3 <> 0) |- _ =>
            cut (X2 <> 0);
             [ intro;
                match goal with
                | Hop1:(?X2 <> 0) |- _ =>
                    IsoleVarAux1 var (Lcdiv2 X1 X2 X3 Hop1 Hop2 H)
                     (X2 = X1 / X3 :>X4) Hyp
                end
             | idtac ]
        | _ =>
            cut (X2 <> 0);
             [ intro; cut (X3 <> 0);
                [ intro;
                   match goal with
                   | Hop1:(?X2 <> 0),Hop2:(?X3 <> 0) |- _ =>
                       IsoleVarAux1 var (Lcdiv2 X1 X2 X3 Hop1 Hop2 H)
                        (X2 = X1 / X3 :>X4) Hyp
                   end
                | trivial ]
             | trivial ]
        end
  | (?X1 * ?X2 = ?X3 :>?X4) =>
      match goal with
      | Hop:(?X2 <> 0) |- _ =>
          IsoleVarAux1 var (Lcmult1 X1 X2 X3 Hop H) (X1 = X3 / X2 :>X4) Hyp
      | _ =>
          cut (X2 <> 0);
           [ intro;
              match goal with
              | Hop:(?X2 <> 0) |- _ =>
                  IsoleVarAux1 var (Lcmult1 X1 X2 X3 Hop H)
                   (X1 = X3 / X2 :>X4) Hyp
              end
           | idtac ]
      end ||
        match goal with
        | Hop:(?X1 <> 0) |- _ =>
            IsoleVarAux1 var (Lcmult2 X1 X2 X3 Hop H) (X2 = X3 / X1 :>X4) Hyp
        | _ =>
            cut (X1 <> 0);
             [ intro;
                match goal with
                | Hop:(?X1 <> 0) |- _ =>
                    IsoleVarAux1 var (Lcmult2 X1 X2 X3 Hop H)
                     (X2 = X3 / X1 :>X4) Hyp
                end
             | idtac ]
        end
  | (- ?X1 = ?X3 :>?X4) =>
      IsoleVarAux1 var (Lcop1 X1 X3 H) (X1 = - X3 :>X4) Hyp
  | _ => fail
  end.

Ltac IsoleVarAux var H T Hyp :=
  match T with
  | (?X2 = ?X3 :>?X1) =>
      IsoleVarAux1 var H T Hyp ||
        IsoleVarAux1 var (sym_eq H) (X3 = X2 :>X1) Hyp
  end.

Ltac TypeOf H :=
  match goal with
  | id:?X1 |- _ => match id with
                   | H => X1
                   | _ => fail
                   end
  end.

Ltac IsoleVar var H := let T := TypeOf H in
                       IsoleVarAux var H T H.

Ltac IsoleVarRing var H := IsoleVar var H; NormalizeRing H.

Ltac RewriteVar var H := IsoleVarRing var H; rewrite_all H.

(* Tests *)

(*

Lemma test_isole_var_1 : forall a b,  a+b=0 -> a = -b.
Proof.
intros.
IsoleVar a H.
rewrite H; ring.
Qed.

Lemma test_isole_var_2 : forall a b,  a-b=0 -> a = b.
Proof.
intros.
IsoleVar a H.
NormalizeRing H.
assumption.
Qed.

Lemma test_isole_var_3 : forall a b,  b<>0 -> a*b=0 -> a = 0.
Proof.
intros.
IsoleVar a H0.
rewrite H0.
field.
assumption.
Qed.

Lemma test_isole_var_4 : forall a b,  b<>0 -> a/b=0 -> a = 0.
Proof.
intros.
IsoleVar a H0.
NormalizeRing H0.
assumption.
Qed.

Theorem premier_degre : forall a b x,  a<>0 -> a*x+b=0 -> x = -b/a.
Proof.
intros.
IsoleVar x H0.
rewrite H0.
field.
assumption.
Qed.

*)