(*
  Definitions of Tm, Ty and Judgement.
  Do not modify these!

  The task starts at line 38.
*)

Inductive Tm : Set :=
  | num (n : nat)
  | plus (t t' : Tm)
  | isZero (t : Tm)
  | true
  | false
  | ifThenElse (t t' t'' : Tm)
.

Notation "t + t'" := (plus t t').
Notation "'If' t 'then' t' 'else' t''" := (ifThenElse t t' t'') (at level 100).

Inductive Ty : Set := Nat | Bool.

Inductive Judgement : Tm -> Ty -> Prop :=
  | J_num {n : nat} : (num n) :: Nat
  | J_plus {t t' : Tm} (j : t :: Nat) (j' : t' :: Nat) : (t + t') :: Nat
  | J_isZero {t : Tm} (j : t :: Nat) : (isZero t) :: Bool
  | J_true : true :: Bool
  | J_false : false :: Bool

  | J_ifThenElse
    {t t' t'' : Tm} {A : Ty}
    (j : t :: Bool) (j' : t' :: A) (j'' : t'' :: A)
    : (If t then t' else t'') :: A

where "tm :: ty" := (Judgement tm ty).

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

(*
  Proove the unicity of the typing relation, meaning that every term can
  at most have one type! The theorem states the following:
  If the term "tm" is of type "ty" and "ty'" at the same time,
  then "ty" must be equal to "ty'".
*)

Theorem unicity : (
  forall tm : Tm, forall ty ty' : Ty,
  tm :: ty -> tm :: ty' -> ty = ty'
).
Proof.
  intros tm ty ty' H.
  induction H.
  1-5: (intros HN; inversion HN; reflexivity).
  + intros HN. inversion HN. apply IHJudgement2. exact j'.
Qed.


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

Require Import NaryFunctions.
Require Import Wf_nat.
Require Export ZArith.
Require Export DoubleType.

(** * 31-bit integers *)

(** This file contains basic definitions of a 31-bit integer
  arithmetic. In fact it is more general than that. The only reason
  for this use of 31 is the underlying mecanism for hardware-efficient
  computations by A. Spiwack. Apart from this, a switch to, say,
  63-bit integers is now just a matter of replacing every occurences
  of 31 by 63. This is actually made possible by the use of
  dependently-typed n-ary constructions for the inductive type
  [int31], its constructor [I31] and any pattern matching on it.
  If you modify this file, please preserve this genericity.  *)

Definition size := 31%nat.

(** Digits *)

Inductive digits : Type := D0 | D1.

(** The type of 31-bit integers *)

(** The type [int31] has a unique constructor [I31] that expects
   31 arguments of type [digits]. *)

Definition digits31 t := Eval compute in nfun digits size t.

Inductive int31 : Type := I31 : digits31 int31.

(* spiwack: Registration of the type of integers, so that the matchs in
   the functions below perform dynamic decompilation (otherwise some segfault
   occur when they are applied to one non-closed term and one closed term). *)
Register digits as int31 bits in "coq_int31" by True.
Register int31 as int31 type in "coq_int31" by True.

Delimit Scope int31_scope with int31.
Bind Scope int31_scope with int31.
Local Open Scope int31_scope.

(** * Constants *)

(** Zero is [I31 D0 ... D0] *)
Definition On : int31 := Eval compute in napply_cst _ _ D0 size I31.

(** One is [I31 D0 ... D0 D1] *)
Definition In : int31 := Eval compute in (napply_cst _ _ D0 (size-1) I31) D1.

(** The biggest integer is [I31 D1 ... D1], corresponding to [(2^size)-1] *)
Definition Tn : int31 := Eval compute in napply_cst _ _ D1 size I31.

(** Two is [I31 D0 ... D0 D1 D0] *)
Definition Twon : int31 := Eval compute in (napply_cst _ _ D0 (size-2) I31) D1 D0.

(** * Bits manipulation *)

(** [sneakr b x] shifts [x] to the right by one bit.
   Rightmost digit is lost while leftmost digit becomes [b].
   Pseudo-code is
    [ match x with (I31 d0 ... dN) => I31 b d0 ... d(N-1) end ]
*)

Definition sneakr : digits -> int31 -> int31 := Eval compute in
 fun b => int31_rect _ (napply_except_last _ _ (size-1) (I31 b)).

(** [sneakl b x] shifts [x] to the left by one bit.
   Leftmost digit is lost while rightmost digit becomes [b].
   Pseudo-code is
    [ match x with (I31 d0 ... dN) => I31 d1 ... dN b end ]
*)

Definition sneakl : digits -> int31 -> int31 := Eval compute in
 fun b => int31_rect _ (fun _ => napply_then_last _ _ b (size-1) I31).

(** [shiftl], [shiftr], [twice] and [twice_plus_one] are direct
    consequences of [sneakl] and [sneakr]. *)

Definition shiftl := sneakl D0.
Definition shiftr := sneakr D0.
Definition twice := sneakl D0.
Definition twice_plus_one := sneakl D1.

(** [firstl x] returns the leftmost digit of number [x].
    Pseudo-code is [ match x with (I31 d0 ... dN) => d0 end ] *)

Definition firstl : int31 -> digits := Eval compute in
 int31_rect _ (fun d => napply_discard _ _ d (size-1)).

(** [firstr x] returns the rightmost digit of number [x].
    Pseudo-code is [ match x with (I31 d0 ... dN) => dN end ] *)

Definition firstr : int31 -> digits := Eval compute in
 int31_rect _ (napply_discard _ _ (fun d=>d) (size-1)).

(** [iszero x] is true iff [x = I31 D0 ... D0]. Pseudo-code is
    [ match x with (I31 D0 ... D0) => true | _ => false end ] *)

Definition iszero : int31 -> bool := Eval compute in
 let f d b := match d with D0 => b | D1 => false end
 in int31_rect _ (nfold_bis _ _ f true size).

(* NB: DO NOT transform the above match in a nicer (if then else).
   It seems to work, but later "unfold iszero" takes forever. *)

(** [base] is [2^31], obtained via iterations of [Zdouble].
   It can also be seen as the smallest b > 0 s.t. phi_inv b = 0
   (see below) *)

Definition base := Eval compute in
 iter_nat size Z Zdouble 1%Z.

(** * Recursors *)

Fixpoint recl_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A)
 (i:int31) : A :=
  match n with
  | O => case0
  | S next =>
          if iszero i then
             case0
          else
             let si := shiftl i in
             caserec (firstl i) si (recl_aux next A case0 caserec si)
  end.

Fixpoint recr_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A)
 (i:int31) : A :=
  match n with
  | O => case0
  | S next =>
          if iszero i then
             case0
          else
             let si := shiftr i in
             caserec (firstr i) si (recr_aux next A case0 caserec si)
  end.

Definition recl := recl_aux size.
Definition recr := recr_aux size.

(** * Conversions *)

(** From int31 to Z, we simply iterates [Zdouble] or [Zdouble_plus_one]. *)

Definition phi : int31 -> Z :=
 recr Z (0%Z)
  (fun b _ => match b with D0 => Zdouble | D1 => Zdouble_plus_one end).

(** From positive to int31. An abstract definition could be :
      [ phi_inv (2n) = 2*(phi_inv n) /\
        phi_inv 2n+1 = 2*(phi_inv n) + 1 ] *)

Fixpoint phi_inv_positive p :=
  match p with
    | xI q => twice_plus_one (phi_inv_positive q)
    | xO q => twice (phi_inv_positive q)
    | xH => In
  end.

(** The negative part : 2-complement  *)

Fixpoint complement_negative p :=
  match p with
    | xI q => twice (complement_negative q)
    | xO q => twice_plus_one (complement_negative q)
    | xH => twice Tn
  end.

(** A simple incrementation function *)

Definition incr : int31 -> int31 :=
 recr int31 In
   (fun b si rec => match b with
     | D0 => sneakl D1 si
     | D1 => sneakl D0 rec end).

(** We can now define the conversion from Z to int31. *)

Definition phi_inv : Z -> int31 := fun n =>
 match n with
 | Z0 => On
 | Zpos p => phi_inv_positive p
 | Zneg p => incr (complement_negative p)
 end.

(** [phi_inv2] is similar to [phi_inv] but returns a double word
    [zn2z int31] *)

Definition phi_inv2 n :=
  match n with
  | Z0 => W0
  | _ => WW (phi_inv (n/base)%Z) (phi_inv n)
  end.

(** [phi2] is similar to [phi] but takes a double word (two args) *)

Definition phi2 nh nl :=
  ((phi nh)*base+(phi nl))%Z.

(** * Addition *)

(** Addition modulo [2^31] *)

Definition add31 (n m : int31) := phi_inv ((phi n)+(phi m)).
Notation "n + m" := (add31 n m) : int31_scope.

(** Addition with carry (the result is thus exact) *)

(* spiwack : when executed in non-compiled*)
(* mode, (phi n)+(phi m) is computed twice*)
(* it may be considered to optimize it *)

Definition add31c (n m : int31) :=
  let npm := n+m in
  match (phi npm ?= (phi n)+(phi m))%Z with
  | Eq => C0 npm
  | _ => C1 npm
  end.
Notation "n '+c' m" := (add31c n m) (at level 50, no associativity) : int31_scope.

(**  Addition plus one with carry (the result is thus exact) *)

Definition add31carryc (n m : int31) :=
  let npmpone_exact := ((phi n)+(phi m)+1)%Z in
  let npmpone := phi_inv npmpone_exact in
  match (phi npmpone ?= npmpone_exact)%Z with
  | Eq => C0 npmpone
  | _ => C1 npmpone
  end.

(** * Substraction *)

(** Subtraction modulo [2^31] *)

Definition sub31 (n m : int31) := phi_inv ((phi n)-(phi m)).
Notation "n - m" := (sub31 n m) : int31_scope.

(** Subtraction with carry (thus exact) *)

Definition sub31c (n m : int31) :=
  let nmm := n-m in
  match (phi nmm ?= (phi n)-(phi m))%Z with
  | Eq => C0 nmm
  | _ => C1 nmm
  end.
Notation "n '-c' m" := (sub31c n m) (at level 50, no associativity) : int31_scope.

(** subtraction minus one with carry (thus exact) *)

Definition sub31carryc (n m : int31) :=
  let nmmmone_exact := ((phi n)-(phi m)-1)%Z in
  let nmmmone := phi_inv nmmmone_exact in
  match (phi nmmmone ?= nmmmone_exact)%Z with
  | Eq => C0 nmmmone
  | _ => C1 nmmmone
  end.

(** Opposite *)

Definition opp31 x := On - x.
Notation "- x" := (opp31 x) : int31_scope.

(** Multiplication *)

(** multiplication modulo [2^31] *)

Definition mul31 (n m : int31) := phi_inv ((phi n)*(phi m)).
Notation "n * m" := (mul31 n m) : int31_scope.

(** multiplication with double word result (thus exact) *)

Definition mul31c (n m : int31) := phi_inv2 ((phi n)*(phi m)).
Notation "n '*c' m" := (mul31c n m) (at level 40, no associativity) : int31_scope.

(** * Division *)

(** Division of a double size word modulo [2^31] *)

Definition div3121 (nh nl m : int31) :=
  let (q,r) := Zdiv_eucl (phi2 nh nl) (phi m) in
  (phi_inv q, phi_inv r).

(** Division modulo [2^31] *)

Definition div31 (n m : int31) :=
  let (q,r) := Zdiv_eucl (phi n) (phi m) in
  (phi_inv q, phi_inv r).
Notation "n / m" := (div31 n m) : int31_scope.

(** * Unsigned comparison *)

Definition compare31 (n m : int31) := ((phi n)?=(phi m))%Z.
Notation "n ?= m" := (compare31 n m) (at level 70, no associativity) : int31_scope.

Definition eqb31 (n m : int31) :=
 match n ?= m with Eq => true | _ => false end.

(** Computing the [i]-th iterate of a function:
    [iter_int31 i A f = f^i] *)

Definition iter_int31 i A f :=
  recr (A->A) (fun x => x)
   (fun b si rec => match b with
      | D0 => fun x => rec (rec x)
      | D1 => fun x => f (rec (rec x))
    end)
    i.

(** Combining the [(31-p)] low bits of [i] above the [p] high bits of [j]:
    [addmuldiv31 p i j = i*2^p+j/2^(31-p)]  (modulo [2^31]) *)

Definition addmuldiv31 p i j :=
 let (res, _ ) :=
 iter_int31 p (int31*int31)
  (fun ij => let (i,j) := ij in (sneakl (firstl j) i, shiftl j))
  (i,j)
 in
 res.

Register add31 as int31 plus in "coq_int31" by True.
Register add31c as int31 plusc in "coq_int31" by True.
Register add31carryc as int31 pluscarryc in "coq_int31" by True.
Register sub31 as int31 minus in "coq_int31" by True.
Register sub31c as int31 minusc in "coq_int31" by True.
Register sub31carryc as int31 minuscarryc in "coq_int31" by True.
Register mul31 as int31 times in "coq_int31" by True.
Register mul31c as int31 timesc in "coq_int31" by True.
Register div3121 as int31 div21 in "coq_int31" by True.
Register div31 as int31 div in "coq_int31" by True.
Register compare31 as int31 compare in "coq_int31" by True.
Register addmuldiv31 as int31 addmuldiv in "coq_int31" by True.

Definition gcd31 (i j:int31) :=
  (fix euler (guard:nat) (i j:int31) {struct guard} :=
   match guard with
   | O => In
   | S p => match j ?= On with
            | Eq => i
            | _ => euler p j (let (_, r ) := i/j in r)
            end
   end)
  (2*size)%nat i j.

(** Square root functions using newton iteration
    we use a very naive upper-bound on the iteration
    2^31 instead of the usual 31.
**)

Definition sqrt31_step (rec: int31 -> int31 -> int31) (i j: int31)  :=
Eval lazy delta [Twon] in
  let (quo,_) := i/j in
  match quo ?= j with
    Lt => rec i (fst ((j + quo)/Twon))
  | _ =>  j
  end.

Fixpoint iter31_sqrt (n: nat) (rec: int31 -> int31 -> int31)
          (i j: int31) {struct n} : int31 :=
  sqrt31_step
   (match n with
      O =>  rec
   | S n => (iter31_sqrt n (iter31_sqrt n rec))
   end) i j.

Definition sqrt31 i :=
Eval lazy delta [On In Twon] in
  match compare31 In i with
    Gt => On
  | Eq => In
  | Lt => iter31_sqrt 31 (fun i j => j) i (fst (i/Twon))
  end.

Definition v30 := Eval compute in (addmuldiv31 (phi_inv (Z_of_nat size - 1)) In On).

Definition sqrt312_step (rec: int31 -> int31 -> int31 -> int31)
   (ih il j: int31)  :=
Eval lazy delta [Twon v30] in
  match ih ?= j with Eq => j | Gt => j | _ =>
  let (quo,_) := div3121 ih il j in
  match quo ?= j with
    Lt => let m := match j +c quo with
                    C0 m1 => fst (m1/Twon)
                  | C1 m1 => fst (m1/Twon) + v30
                  end in rec ih il m
  | _ =>  j
  end end.

Fixpoint iter312_sqrt (n: nat)
          (rec: int31  -> int31 -> int31 -> int31)
          (ih il j: int31) {struct n} : int31 :=
  sqrt312_step
   (match n with
      O =>  rec
   | S n => (iter312_sqrt n (iter312_sqrt n rec))
   end) ih il j.

Definition sqrt312 ih il :=
Eval lazy delta [On In] in
  let s := iter312_sqrt 31 (fun ih il j => j) ih il Tn in
           match s *c s with
            W0 => (On, C0 On) (* impossible *)
          | WW ih1 il1 =>
             match il -c il1 with
                C0 il2 =>
                  match ih ?= ih1 with
                    Gt => (s, C1 il2)
                  | _  => (s, C0 il2)
                  end
              | C1 il2 =>
                  match (ih - In) ?= ih1 with (* we could parametrize ih - 1 *)
                    Gt => (s, C1 il2)
                  | _  => (s, C0 il2)
                  end
              end
          end.

Fixpoint p2i n p : (N*int31)%type :=
  match n with
    | O => (Npos p, On)
    | S n => match p with
               | xO p => let (r,i) := p2i n p in (r, Twon*i)
               | xI p => let (r,i) := p2i n p in (r, Twon*i+In)
               | xH => (N0, In)
             end
  end.

Definition positive_to_int31 (p:positive) := p2i size p.

(** Constant 31 converted into type int31.
    It is used as default answer for numbers of zeros
    in [head0] and [tail0] *)

Definition T31 : int31 := Eval compute in phi_inv (Z_of_nat size).

Definition head031 (i:int31) :=
  recl _ (fun _ => T31)
   (fun b si rec n => match b with
     | D0 => rec (add31 n In)
     | D1 => n
    end)
   i On.

Definition tail031 (i:int31) :=
  recr _ (fun _ => T31)
   (fun b si rec n => match b with
     | D0 => rec (add31 n In)
     | D1 => n
    end)
   i On.

Register head031 as int31 head0 in "coq_int31" by True.
Register tail031 as int31 tail0 in "coq_int31" by True.


Require Export Iron.Language.SimpleData.ExpBase.
Require Export Iron.Language.SimpleData.ExpLift.
Require Export Iron.Language.SimpleData.ExpSubst.
Require Export Iron.Language.SimpleData.ExpAlt.

(* Weak normal forms cannot be reduced further by
   call-by-value evaluation. *)
Inductive wnfX : exp -> Prop :=
 | Wnf_XVar
   : forall i
   , wnfX (XVar i)

 | Wnf_XLam
   : forall t1 x2
   , wnfX (XLam t1 x2)

 | Wnf_XCon
   :  forall dc xs
   ,  Forall wnfX xs
   -> wnfX (XCon dc xs).
Hint Constructors wnfX.

(* Well formed expressions are closed under the given environment. *)
Inductive wfX : tyenv -> exp -> Prop :=
 | WfX_XVar
   :  forall te i
   ,  (exists t, get i te = Some t)
   -> wfX te (XVar i)

 | WfX_XLam
   :  forall te t x
   ,  wfX (te :> t) x
   -> wfX te (XLam t x)

 | WfX_XApp
   :  forall te x1 x2
   ,  wfX te x1 -> wfX te x2
   -> wfX te (XApp x1 x2)

 | WfX_XCon
   :  forall te dc xs
   ,  Forall (wfX te) xs
   -> wfX te (XCon dc xs)

 | WfX_XCase
   :  forall te x alts
   ,  wfX te x
   -> Forall (wfA te) alts
   -> wfX te (XCase x alts)

with    wfA : tyenv -> alt -> Prop :=
 | WfA_AAlt
   :  forall te dc ds ts x tsArgs tResult
   ,  getDataDef dc ds = Some (DefData dc tsArgs tResult)
   -> wfX (te >< tsArgs) x
   -> wfA te (AAlt dc ts x).

Hint Constructors wfX.
Hint Constructors wfA.

(* Closed expressions are well formed under an empty environment. *)
Definition closedX (xx: exp) : Prop
 := wfX nil xx.
Hint Unfold closedX.

(* Values are closed expressions that cannot be reduced further. *)
Inductive value : exp -> Prop :=
 | Value
   :  forall xx
   ,  wnfX xx -> closedX xx
   -> value xx.
Hint Constructors value.

Lemma value_wnfX
 : forall xx, value xx -> wnfX xx.
 Proof. intros. inverts H. auto. Qed.
Hint Resolve value_wnfX.

Lemma value_closedX
 : forall xx, value xx -> closedX xx.
 Proof. intros. inverts H. auto. Qed.
Hint Resolve value_closedX.

Lemma value_wnfXs_XCon
 : forall xs dc
 , value (XCon dc xs) -> Forall wnfX xs.
Proof.
 intros. inverts H. inverts H0. auto.
Qed.
Hint Resolve value_wnfXs_XCon.

Lemma value_closedXs_XCon
 : forall xs dc
 , value (XCon dc xs) -> Forall closedX xs.
Proof.
 intros. inverts H. inverts H1. auto.
Qed.
Hint Resolve value_closedXs_XCon.


(**************************************
  Finish reading, Finish exercise
**************************************)

Require Import List Bool Nat.
Import ListNotations.
Local Open Scope list_scope.

(** **** Exercise: 2 stars (mumble_grumble)  *)
Module MumbleGrumble.

Inductive mumble: Type :=
  | a: mumble
  | b: mumble -> nat -> mumble
  | c: mumble.

Inductive grumble (X: Type): Type :=
  | d: mumble -> grumble X
  | e: X -> grumble X.

(* Check (d (b a 5)). *)
Check (d mumble (b a 5)).
Check (d bool (b a 5)).
Check (e bool true).
Check (e mumble (b c 0)).
(* Check (e bool (b c 0)). *)
Check c.

(*
 - × [d (b a 5)]
 - √ [d mumble (b a 5)]
 - √ [d bool (b a 5)]
 - √ [e bool true]
 - √ [e mumble (b c 0)]
 - × [e bool (b c 0)]
 - × [c]
*)

End MumbleGrumble.

(** **** Exercise: 2 stars, optional (poly_exercises)  *)

Theorem app_nil_r: forall (X: Type), forall l: list X, l ++ nil = l.
Proof.
  intros X l.
  induction l as [|X' l' H].
  - reflexivity.
  - simpl.
    rewrite -> H.
    reflexivity.
Qed.

Theorem app_assoc: forall A (l m n: list A), l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros A l m n.
  induction l as [|X' l' H].
  - reflexivity.
  - simpl.
    rewrite -> H.
    reflexivity.
Qed.

Lemma app_length: forall (X: Type) (l1 l2: list X), length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros X l1 l2.
  induction l1 as [|X' l' H].
  - reflexivity.
  - simpl.
    rewrite -> H.
    reflexivity.
Qed.

(** **** Exercise: 2 stars, optional (more_poly_exercises)  *)
Theorem rev_app_distr: forall X (l1 l2: list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros X l1 l2.
  induction l1.
  - simpl.
    rewrite app_nil_r.
    reflexivity.
  - simpl.
    rewrite IHl1.
    rewrite app_assoc.
    reflexivity.
Qed.

Theorem rev_involutive: forall X: Type, forall l: list X,
  rev (rev l) = l.
Proof.
  induction l.
  - reflexivity.
  - simpl.
    rewrite rev_app_distr.
    rewrite IHl.
    reflexivity.
Qed.

(** **** Exercise: 1 star, optional (combine_checks)  *)
(* not do it *)

(** **** Exercise: 2 stars, recommended (split)  *)
Fixpoint split {X Y: Type}(l: list (X*Y)): (list X) * (list Y) :=
  match l with
  | nil => (nil, nil)
  | (x,y) :: t => let (l,r) := split t in (x :: l, y :: r)
  end.

Example test_split: split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof. reflexivity. Qed.

(** **** Exercise: 1 star, optional (hd_error_poly)  *)
Definition hd_error {X: Type}(l: list X): option X :=
  match l with
  | nil => None
  | h :: t => Some h
  end.

Example test_hd_error1: hd_error [1;2] = Some 1.
Proof. reflexivity. Qed.

Example test_hd_error2: hd_error [[1];[2]] = Some [1].
Proof. reflexivity. Qed.

(* ================================================================= *)
(** * Functions as Data *)

(** **** Exercise: 2 stars (filter_even_gt7)  *)
Definition filter_even_gt7 (l: list nat): list nat :=
  filter (fun x => andb (7 <? x) (even x)) l.

Example test_filter_even_gt7_1: filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
Proof. reflexivity. Qed.

Example test_filter_even_gt7_2: filter_even_gt7 [5;2;6;19;129] = [].
Proof. reflexivity. Qed.

(** **** Exercise: 3 stars (partition)  *)
Definition partition {X: Type}(test: X -> bool)(l: list X): list X * list X :=
  (filter test l, filter (fun x => negb (test x)) l).

Example test_partition1: partition odd [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. reflexivity. Qed.

Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. reflexivity. Qed.

(** **** Exercise: 3 stars (map_rev)  *)
Theorem map_rev: forall (X Y: Type)(f: X -> Y)(l: list X),
  map f (rev l) = rev (map f l).
Proof.
  intros X Y f l.
  induction l.
  - reflexivity.
  - simpl.
    rewrite map_app. (* map_app is a inner Lemma *)
    rewrite IHl.
    reflexivity.
Qed.

(** **** Exercise: 2 stars, recommended (flat_map)  *)
Fixpoint flat_map {X Y: Type}(f: X -> list Y)(l: list X): (list Y) :=
  match l with
  | nil => nil
  | x :: t => (f x) ++ (flat_map f t)
  end.

Example test_flat_map1: flat_map (fun n => [n;n;n]) [1;5;4] = [1; 1; 1; 5; 5; 5; 4; 4; 4].
Proof. reflexivity.  Qed.

(** **** Exercise: 2 stars, optional (implicit_args)  *)
(* not do it *)

(** **** Exercise: 1 star, advanced (fold_types_different) *)
(* sum with nat to Z *)

(* ================================================================= *)
(** * Additional Exercises *)

Fixpoint fold {X Y:Type}(f: X->Y->Y)(l: list X)(b: Y): Y :=
  match l with
  | nil => b
  | h :: t => f h (fold f t b)
  end.

Definition fold_length {X: Type} (l: list X): nat :=
  fold (fun _ n => S n) l 0.

(** **** Exercise: 2 stars (fold_length)  *)
Theorem fold_length_correct: forall X (l: list X), fold_length l = length l.
Proof.
  intros X l.
  induction l.
  - reflexivity.
  - simpl.
    assert (P: forall X (a: X)(l: list X), fold_length (a :: l) = fold_length (a :: nil) + fold_length l). {
      intros Y a' l'.
      unfold fold_length.
      simpl.
      reflexivity.
    }
    rewrite P.
    simpl.
    rewrite IHl.
    reflexivity.
Qed.

(** **** Exercise: 3 starsM (fold_map)  *)
Definition fold_map {X Y: Type}(f: X -> Y)(l: list X): list Y :=
  fold (fun x new_l => f x :: new_l ) l nil.

Theorem fold_map_correct: forall X Y f l, @fold_map X Y f l = map f l.
Proof.
  intros.
  induction l.
  - reflexivity.
  - simpl.
    rewrite <- IHl.
    unfold fold_map.
    simpl.
    reflexivity.
Qed.

(** **** Exercise: 2 stars, advanced (currying)  *)
Definition prod_curry {X Y Z: Type}
  (f: X * Y -> Z)(x: X)(y: Y): Z := f (x, y).

Definition prod_uncurry {X Y Z: Type}(f: X -> Y -> Z)(p: X * Y): Z :=
  f (fst p) (snd p).

Theorem uncurry_curry: forall (X Y Z: Type)(f: X -> Y -> Z) x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof.
  unfold prod_curry.
  unfold prod_uncurry.
  reflexivity.
Qed.

Theorem curry_uncurry: forall (X Y Z: Type)(f: (X * Y) -> Z)(p: X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof.
  unfold prod_curry.
  unfold prod_uncurry.
  destruct p.
  reflexivity.
Qed.

(** **** Exercise: 2 stars, advancedM (nth_error_informal)  *)
(** not do it *)

(** **** Exercise: 4 stars, advanced (church_numerals)  *)
Module Church.
Definition nat := forall X: Type, (X -> X) -> X -> X.

Definition one: nat :=
  fun (X: Type)(f: X -> X)(x: X) => f x.

Definition two: nat :=
  fun (X: Type)(f: X -> X)(x: X) => f (f x).

Definition zero: nat :=
  fun (X: Type)(f: X -> X)(x: X) => x.

Definition three: nat :=
  fun (X: Type)(f: X -> X)(x: X) => f (f (f x)).

(** Successor of a natural number: *)
Definition succ (n: nat): nat := fun (X: Type)(f: X -> X)(x: X) => f (n X f x).

Example succ_1: succ zero = one.
Proof. reflexivity. Qed.

Example succ_2: succ one = two.
Proof. reflexivity. Qed.

Example succ_3: succ two = three.
Proof. reflexivity. Qed.

(** Addition of two natural numbers: *)
Definition plus (n m: nat): nat :=
  fun (X: Type)(f: X -> X)(x: X) => n X f (m X f x).

Example plus_1: plus zero one = one.
Proof. reflexivity. Qed.

Example plus_2: plus two three = plus three two.
Proof. reflexivity. Qed.

Example plus_3:
  plus (plus two two) three = plus one (plus three three).
Proof. reflexivity. Qed.

(** Multiplication: *)

Definition mult (n m: nat): nat :=
  fun (X: Type)(f: X -> X)(x: X) => m X (n X f) x.

Example mult_1: mult one one = one.
Proof. reflexivity. Qed.

Example mult_2: mult zero (plus three three) = zero.
Proof. reflexivity. Qed.

Example mult_3: mult two three = plus three three.
Proof. reflexivity. Qed.

(** Exponentiation: *)

Definition exp (n m: nat): nat := fun (X : Type) => m (X -> X) (n X).

Example exp_1: exp two two = plus two two.
Proof. reflexivity. Qed.

Example exp_2: exp three two = plus (mult two (mult two two)) one.
Proof. reflexivity. Qed.

Example exp_3: exp three zero = one.
Proof. reflexivity. Qed.

End Church.


(** We prove the equivalence of the two definitions of adjunction. *)
Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.theory.setoids MathClasses.interfaces.functors MathClasses.theory.categories
  MathClasses.misc.workaround_tactics MathClasses.theory.jections.
Require MathClasses.categories.dual.

Local Hint Unfold id compose: typeclass_instances. (* todo: move *)
Local Existing Instance injective_mor.
Local Existing Instance surjective_mor.

Lemma equal_because_sole `{Setoid T} (P: T → Prop) x: is_sole P x → forall y z, P y → P z → y = z.
Proof. firstorder. Qed. (* todo: move *)

Section for_φAdjunction.

  (* MacLane p79/p80, showing that from an φAdjunction we can make
   both a ηAdjunction and a ηεAdjunction. *)

  Context `(φAdjunction).

  Arguments φ {_ _} _.

  Instance: forall c d, Bijective (@φ c d) := φ_adjunction_bijective F G.
  Instance: Functor F F'  := φ_adjunction_left_functor F G.
  Instance: Functor G G'  := φ_adjunction_right_functor F G.
  Instance: Category D := functor_from G.
  Instance: Category C := functor_to G.
   (* Waiting for the new proof engine ... *)

  Lemma φ_adjunction_natural_right_inv `(g: c ⟶ G d) `(h: c' ⟶ c): φ⁻¹ (g ◎ h) = φ⁻¹ g ◎ fmap F h.
  Proof with try reflexivity; try apply _.
   intros.
   apply (injective φ).
   rewrite surjective_applied...
   rewrite φ_adjunction_natural_right...
   rewrite surjective_applied...
  Qed.

  Lemma φ_adjunction_natural_left_inv `(g: c ⟶ G d) `(k: d ⟶ d'): φ⁻¹ (fmap G k ◎ g) = k ◎ φ⁻¹ g.
  Proof with try reflexivity; try apply _.
   intros.
   apply (injective φ).
   rewrite surjective_applied...
   rewrite φ_adjunction_natural_left...
   rewrite surjective_applied...
  Qed.

  Let η: id ⇛ G ∘ F := λ c, φ (cat_id: F c ⟶ F c).
  Let ε: F ∘ G ⇛ id := λ d, φ ⁻¹ (cat_id: G d ⟶ G d).

  Global Instance η_natural: NaturalTransformation η.
  Proof with try reflexivity; try apply _.
   intros x' x h.
   change (φ cat_id ◎ h = fmap G (fmap F h) ◎ φ cat_id).
   rewrite <- φ_adjunction_natural_left, <- φ_adjunction_natural_right, left_identity, right_identity...
  Qed.

  Global Instance: NaturalTransformation ε.
  Proof with try reflexivity; try apply _.
   intros d d' f.
   change ((φ ⁻¹) cat_id ◎ fmap F (fmap G f) = f ◎ (φ ⁻¹) cat_id).
   rewrite
    <- φ_adjunction_natural_left_inv,
    <- φ_adjunction_natural_right_inv,
    (left_identity (fmap G f)),
    right_identity...
  Qed.

  Lemma φ_in_terms_of_η `(f: F x ⟶ a): φ f = fmap G f ◎ η x.
  Proof.
   rewrite <- (right_identity f) at 1.
   rewrite φ_adjunction_natural_left. reflexivity. apply _.
  Qed.

  Lemma φ_in_terms_of_ε `(g: x ⟶ G a): φ⁻¹ g = ε a ◎ fmap F g.
  Proof.
   rewrite <- (left_identity g) at 1.
   apply φ_adjunction_natural_right_inv.
  Qed.

  Definition univwit (c : C) (d : D): (c ⟶ G d) → (F c ⟶ d) := φ⁻¹.

  Instance: ∀ c, UniversalArrow (η c: c ⟶ G (F c)) (univwit c).
  Proof.
   unfold univwit.
   constructor; unfold compose.
    rewrite <- (φ_in_terms_of_η ((φ ⁻¹) f)).
    symmetry.
    apply (surjective_applied _).
   intros ? E.
   rewrite E.
   rewrite <- (φ_in_terms_of_η y).
   symmetry.
   apply (bijective_applied _).
  Qed.

  Instance φAdjunction_ηAdjunction: ηAdjunction F G η univwit := {}.

  Instance φAdjunction_ηεAdjunction: ηεAdjunction F G η ε.
  Proof with try apply _.
   constructor; try apply _; intro x.
    rewrite <- @φ_in_terms_of_η.
    unfold ε. apply (surjective_applied _).
   rewrite <- @φ_in_terms_of_ε.
   unfold η. apply (surjective_applied _).
  Qed.

  (* On a side note, if we let F and G map between the duals of C and D, the adjunction is reversed: *)

  Goal @φAdjunction D _ _ _ _ C _ _ _ _ G (dual.fmap_op G) F (dual.fmap_op F) (λ d c, (@φ c d)⁻¹)
    (λ d c, @φ c d).
  Proof with try apply _.
   constructor; intros...
     pose proof (φ_adjunction_bijective F G)...
    change (d' ⟶ d) in k.
    change (d ⟶ G c) in f.
    change ((φ ⁻¹) (f ◎ k) = (φ ⁻¹) f ◎ fmap F k).
    apply (injective (@φ d' c)).
    rewrite (surjective_applied _).
    rewrite φ_adjunction_natural_right...
    now rewrite (surjective_applied _).
   change (c ⟶ c') in h.
   change (d ⟶ G c) in f.
   change ((φ ⁻¹) (fmap G h ◎ f) = h ◎ (φ ⁻¹) f).
   apply (injective (@φ d c')).
   rewrite (surjective_applied _).
   rewrite φ_adjunction_natural_left...
   now rewrite (surjective_applied _).
  Qed.

End for_φAdjunction.

Section for_ηAdjunction.

  Context `(ηAdjunction).

  Instance: Functor F F'  := η_adjunction_left_functor F G.
  Instance: Functor G G'  := η_adjunction_right_functor F G.
  Instance: Category D := functor_from G.
  Instance: Category C := functor_to G.

  Let φ x a (g: F x ⟶ a): (x ⟶ G a) := fmap G g ◎ η x.

  Instance: ∀ (c: C) (d: D), Inverse (@φ c d) := uniwit.

  Instance: ∀ x a, Surjective (@φ x a).
  Proof with try apply _.
   unfold φ.
   repeat intro.
   constructor.
    intros x0 y E. symmetry.
    rewrite <- E.
    apply (η_adjunction_universal F G x).
   constructor...
   intros ?? E. rewrite E. reflexivity.
  Qed.

  Instance: ∀ x a, Injective (@φ x a).
  Proof with try reflexivity; try apply _; auto.
   repeat intro. constructor... unfold φ. repeat intro.
   apply (equal_because_sole _ _ (η_adjunction_universal F G _ _ (fmap G x0 ◎ η x))); unfold compose...
  Qed.

  Instance: ∀ x a, Bijective (@φ x a) := {}.

  Instance ηAdjunction_φAdjunction: φAdjunction F G φ.
  Proof with try reflexivity; try apply _.
   unfold φ. unfold id in *. unfold compose in η.
   constructor...
    repeat intro. unfold compose.
    rewrite (associativity (fmap G k))...
    rewrite preserves_comp...
   repeat intro. unfold compose.
   rewrite preserves_comp...
   rewrite <- associativity.
   pose proof (η_adjunction_natural F G c' c h) as P.
   change (η c ◎ h = fmap G (fmap F h) ◎ η c') in P.
   rewrite <- P.
   rewrite (associativity (fmap G f))...
  Qed.

End for_ηAdjunction.

Section for_ηεAdjunction.

  Context `(ηεAdjunction).

  Instance: Functor F F'  := ηε_adjunction_left_functor F G.
  Instance: Functor G G'  := ηε_adjunction_right_functor F G.
  Instance: Category D := functor_from G.
  Instance: Category C := functor_to G.
  Instance: NaturalTransformation η := ηε_adjunction_η_natural F G.
  Instance: NaturalTransformation ε := ηε_adjunction_ε_natural F G.

  Let φ c d (f: F c ⟶ d): (c ⟶ G d) := fmap G f ◎ η c.
  Instance uniwit c d: Inverse (φ c d) := λ f, ε d ◎ fmap F f.

  Instance ηεAdjunction_ηAdjunction: ηAdjunction F G η uniwit.
  Proof with try apply _.
   constructor...
   unfold uniwit.
   constructor; unfold compose.
    rewrite preserves_comp...
    pose proof (ηε_adjunction_η_natural F G c (G d) f) as P.
    change (η (G d) ◎ f = fmap G (fmap F f) ◎ η c) in P.
    rewrite <- associativity.
    rewrite <- P.
    rewrite associativity.
    pose proof (ηε_adjunction_identity_at_G F G d) as Q.
    simpl in Q.
    rewrite Q.
    symmetry.
    apply left_identity.
   intros y E. rewrite E. clear E f.
   rewrite preserves_comp...
   rewrite associativity.
   pose proof (ηε_adjunction_ε_natural F G (F c) d y) as P.
   change (ε d ◎ fmap F (fmap G y) = y ◎ ε (F c)) in P.
   rewrite P.
   rewrite <- associativity.
   pose proof (ηε_adjunction_identity_at_F F G c) as Q.
   simpl in Q.
   rewrite Q.
   symmetry.
   apply right_identity.
  Qed.

  Instance ηεAdjunction_φAdjunction: φAdjunction F G φ.
  Proof. apply ηAdjunction_φAdjunction, _. Qed.
End for_ηεAdjunction.


Require Import HoTT.HIT.quotient.
Require Import
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.theory.dec_fields.

Module Frac.

Section contents.
Universe UR.
Context `{Funext} `{Univalence} (R:Type@{UR})
  `{IsIntegralDomain R} `{DecidablePaths R}.

Record Frac@{} : Type
  := frac { num: R; den: R; den_ne_0: PropHolds (den <> 0) }.
  (* We used to have [den] and [den_nonzero] bundled,
     which did work relatively nicely with Program, but the
     extra messyness in proofs etc turned out not to be worth it. *)

Lemma Frac_ishset' : IsHSet Frac.
Proof.
assert (E : sig (fun n : R => sig (fun d : R => d <> 0 )) <~> Frac).
- issig.
- apply (istrunc_equiv_istrunc _ E).
Qed.

Global Instance Frac_ishset@{} : IsHSet Frac
  := ltac:(first [exact Frac_ishset'@{UR Ularge Set}|
                  exact Frac_ishset'@{}]).

Local Existing Instance den_ne_0.

Global Instance Frac_inject@{} : Cast R Frac.
Proof.
intros x. apply (frac x 1 _).
Defined.

Global Instance Frac_0@{} : Zero Frac := ('0 : Frac).
Global Instance Frac_1@{} : One Frac := ('1 : Frac).

Instance pl@{} : Plus Frac.
Proof.
intros q r; refine (frac (num q * den r + num r * den q) (den q * den r) _).
Defined.

Definition equiv@{} := fun x y => num x * den y = num y * den x.

Global Instance equiv_equiv_rel@{} : EquivRel equiv.
Proof.
split.
- intros x. hnf. reflexivity.
- intros x y. unfold equiv.
  apply symmetry.
- intros x y z. unfold equiv.
  intros E1 E2.
  apply (mult_left_cancel (den y)).
  + solve_propholds.
  + rewrite !mult_assoc, !(mult_comm (den y)).
    rewrite E1, <-E2.
    rewrite <-!mult_assoc. rewrite (mult_comm (den x)).
    reflexivity.
Qed.

Global Instance equiv_dec@{} : forall x y: Frac, Decidable (equiv x y)
  := fun x y => decide_rel (=) (num x * den y) (num y * den x).

Lemma pl_respect@{} : forall q1 q2, equiv q1 q2 -> forall r1 r2, equiv r1 r2 ->
  equiv (q1 + r1) (q2 + r2).
Proof.
unfold equiv;intros q1 q2 Eq r1 r2 Er.
simpl.
rewrite plus_mult_distr_r.
rewrite <-(associativity (num q1) (den r1)).
rewrite (associativity (den r1)), (mult_comm (den r1)), <-(associativity (den q2)).
rewrite (associativity (num q1)), Eq.
rewrite (mult_comm (den q2)), <-(associativity (num r1)), (associativity (den q1)).
rewrite (mult_comm (den q1)), <-(associativity (den r2)), (associativity (num r1)).
rewrite Er.
rewrite (mult_comm (den r1)), <-(associativity (num q2)), (associativity (den q1)).
rewrite (mult_comm (den q1)), <-(associativity (den r2)), (associativity (num q2)).
rewrite <-(associativity (num r2)), (associativity (den r1)),
  (mult_comm _ (den q2)).
rewrite (mult_comm (den r1)), (associativity (num r2)).
apply symmetry;apply plus_mult_distr_r.
Qed.

Lemma pl_comm@{} : forall q r, equiv (pl q r) (pl r q).
Proof.
intros q r;unfold equiv;simpl.
rewrite (mult_comm (den r)), plus_comm. reflexivity.
Qed.

Lemma pl_assoc@{} : forall q r t, equiv (pl q (pl r t)) (pl (pl q r) t).
Proof.
intros;unfold equiv;simpl.
apply ap011;[|apply symmetry,associativity].
rewrite plus_mult_distr_r.
rewrite (plus_mult_distr_r _ _ (den t)).
rewrite plus_assoc. apply ap011;[apply ap011|].
- apply associativity.
- rewrite <-(associativity (num r)), <-(associativity (num r) (den q)).
  rewrite (mult_comm (den t)). reflexivity.
- rewrite (mult_comm (den q));apply symmetry,associativity.
Qed.

Instance ml@{} : Mult Frac.
Proof.
intros q r; refine (frac (num q * num r) (den q * den r) _).
Defined.

Lemma ml_respect@{} : forall q1 q2, equiv q1 q2 -> forall r1 r2, equiv r1 r2 ->
  equiv (q1 * r1) (q2 * r2).
Proof.
unfold equiv;intros q1 q2 Eq r1 r2 Er.
simpl.
rewrite <-(associativity (num q1)), (associativity (num r1)).
rewrite (mult_comm (num r1)), <-(associativity (den q2)), (associativity (num q1)).
rewrite Eq, Er.
rewrite <-(associativity (num q2)), (associativity (den q1)), (mult_comm (den q1)).
rewrite <-(simple_associativity (num r2)), <-(simple_associativity (num q2)).
reflexivity.
Qed.

Instance neg@{} : Negate Frac.
Proof.
intros q;refine (frac (- num q) (den q) _).
Defined.

Lemma neg_respect@{} : forall q r, equiv q r -> equiv (- q) (- r).
Proof.
unfold equiv;simpl;intros q r E.
rewrite <-2!negate_mult_distr_l. rewrite E;reflexivity.
Qed.

Lemma nonzero_num@{} x : ~ (equiv x 0) <-> num x <> 0.
Proof.
split; intros E F; apply E.
- red. rewrite F. simpl. rewrite 2!mult_0_l. reflexivity.
- red in F;simpl in F. rewrite mult_1_r, mult_0_l in F. trivial.
Qed.

Lemma pl_0_l@{} x : equiv (0 + x) x.
Proof.
red;simpl. rewrite mult_1_r, mult_0_l, mult_1_l, plus_0_l. reflexivity.
Qed.

Lemma pl_0_r@{} x : equiv (x + 0) x.
Proof.
red;simpl. rewrite 2!mult_1_r, mult_0_l, plus_0_r. reflexivity.
Qed.

Lemma pl_neg_l@{} x : equiv (- x + x) 0.
Proof.
red;simpl.
rewrite mult_1_r, mult_0_l.
rewrite <-plus_mult_distr_r.
rewrite plus_negate_l.
apply mult_0_l.
Qed.

Lemma ml_assoc@{} q r t : equiv (ml q (ml r t)) (ml (ml q r) t).
Proof.
red;simpl.
rewrite (associativity (num q)), (associativity (den q)).
reflexivity.
Qed.

Instance dec_rec@{} : DecRecip Frac := fun x =>
  match decide_rel (=) (num x) 0 with
  | inl _ => 0
  | inr P => frac (den x) (num x) P
  end.

Lemma dec_recip_respect@{} : forall q r, equiv q r -> equiv (/ q) (/ r).
Proof.
unfold equiv,dec_recip,dec_rec;intros q r E;simpl.
destruct (decide_rel paths (num q) 0) as [E1|E1],
(decide_rel paths (num r) 0) as [E2|E2];simpl.
- trivial.
- rewrite E1 in E;rewrite mult_0_l in E.
  destruct E2.
  apply (right_cancellation_ne_0 mult (den q));try solve_propholds.
  rewrite mult_0_l;apply symmetry,E.
- rewrite E2 in E;rewrite mult_0_l in E.
  destruct E1.
  apply (right_cancellation_ne_0 mult (den r));try solve_propholds.
  rewrite mult_0_l;trivial.
- rewrite (mult_comm (den q)), (mult_comm (den r)).
  apply symmetry, E.
Qed.

End contents.

Arguments Frac R {Rzero} : rename.
Arguments frac {R Rzero} _ _ _ : rename.
Arguments num {R Rzero} _ : rename.
Arguments den {R Rzero} _ : rename.
Arguments den_ne_0 {R Rzero} _ _ : rename.
Arguments equiv {R _ _} _ _.

Section morphisms.
Context {R1} `{IsIntegralDomain R1} `{DecidablePaths R1}.
Context {R2} `{IsIntegralDomain R2} `{DecidablePaths R2}.
Context `(f : R1 -> R2) `{!IsSemiRingPreserving f} `{!IsInjective f}.

Definition lift (x : Frac R1) : Frac R2.
Proof.
apply (frac (f (num x)) (f (den x))).
apply isinjective_ne_0.
apply (den_ne_0 x).
Defined.

Lemma lift_respects : forall q r, equiv q r -> equiv (lift q) (lift r).
Proof.
unfold equiv;simpl;intros q r E.
rewrite <-2!preserves_mult.
apply ap,E.
Qed.

End morphisms.

End Frac.
Import Frac.

Module FracField.

Section contents.
(* NB: we need a separate IsHSet instance
   so we don't need to depend on everything to define F. *)
Universe UR.
Context `{Funext} `{Univalence} {R:Type@{UR} } `{IsHSet R} `{IsIntegralDomain R}
  `{DecidablePaths R}.

Local Existing Instance den_ne_0.

(* Add Ring R: (stdlib_ring_theory R). *)

Definition F@{} := quotient equiv.

Global Instance class@{} : Cast (Frac R) F := class_of _.

(* injection from R *)

Global Instance inject@{} : Cast R F := Compose class (Frac_inject _).

Definition path@{} {x y} : equiv x y -> ' x = ' y := related_classes_eq _.

Definition F_rect@{i} (P : F -> Type@{i}) {sP : forall x, IsHSet (P x)}
  (dclass : forall x : Frac R, P (' x))
  (dequiv : forall x y E, (path E) # (dclass x) = (dclass y))
  : forall q, P q
  := quotient_ind equiv P dclass dequiv.

Definition F_compute P {sP} dclass dequiv x
 : @F_rect P sP dclass dequiv (' x) = dclass x := 1.

Definition F_compute_path P {sP} dclass dequiv q r (E : equiv q r)
  : apD (@F_rect P sP dclass dequiv) (path E) = dequiv q r E
  := quotient_ind_compute_path _ _ _ _ _ _ _ _.

Definition F_ind@{i} (P : F -> Type@{i}) {sP : forall x, IsHProp (P x)}
  (dclass : forall x : Frac R, P (' x)) : forall x, P x.
Proof.
apply (@F_rect P (fun _ => istrunc_hprop) dclass).
intros;apply path_ishprop.
Qed.

Definition F_ind2@{i j} (P : F -> F -> Type@{i}) {sP : forall x y, IsHProp (P x y)}
  (dclass : forall x y : Frac R, P (' x) (' y)) : forall x y, P x y.
Proof.
apply (@F_ind (fun x => forall y, _)).
- intros;apply Forall.istrunc_forall@{UR i j}.
- intros x.
  apply (F_ind _);intros y.
  apply dclass.
Qed.

Definition F_ind3@{i j} (P : F -> F -> F -> Type@{i})
  {sP : forall x y z, IsHProp (P x y z)}
  (dclass : forall x y z : Frac R, P (' x) (' y) (' z))
  : forall x y z, P x y z.
Proof.
apply (@F_ind (fun x => forall y z, _)).
- intros;apply Forall.istrunc_forall@{UR j j}.
- intros x.
  apply (F_ind2@{i j} _). auto.
Qed.

Definition F_rec@{i} {T : Type@{i} } {sT : IsHSet T}
  : forall (dclass : Frac R -> T)
  (dequiv : forall x y, equiv x y -> dclass x = dclass y),
  F -> T
  := quotient_rec equiv.

Definition F_rec_compute T sT dclass dequiv x
  : @F_rec T sT dclass dequiv (' x) = dclass x
  := 1.

Definition F_rec2@{i j} {T:Type@{i} } {sT : IsHSet T}
  : forall (dclass : Frac R -> Frac R -> T)
  (dequiv : forall x1 x2, equiv x1 x2 -> forall y1 y2, equiv y1 y2 ->
    dclass x1 y1 = dclass x2 y2),
  F -> F -> T
  := @quotient_rec2@{UR UR j i} _ _ _ _ _ (Build_HSet _).

Definition F_rec2_compute {T sT} dclass dequiv x y
  : @F_rec2 T sT dclass dequiv (' x) (' y) = dclass x y
  := 1.

(* Relations, operations and constants *)

Global Instance F0@{} : Zero F := ('0 : F).
Global Instance F1@{} : One F := ('1 : F).

Global Instance Fplus@{} : Plus F.
Proof.
refine (F_rec2 (fun x y => ' (Frac.pl _ x y)) _).
intros. apply path. apply Frac.pl_respect;trivial.
Defined.

Definition Fplus_compute@{} q r : (' q) + (' r) = ' (Frac.pl _ q r)
  := 1.

Global Instance Fneg@{} : Negate F.
Proof.
refine (F_rec (fun x => ' (Frac.neg _ x)) _).
intros;apply path; eapply Frac.neg_respect;try apply _. trivial.
Defined.

Definition Fneg_compute@{} q : - (' q) = ' (Frac.neg _ q) := 1.

Global Instance Fmult@{} : Mult F.
Proof.
refine (F_rec2 (fun x y => ' (Frac.ml _ x y)) _).
intros. apply path. apply Frac.ml_respect;trivial.
Defined.

Definition Fmult_compute@{} q r : (' q) * (' r) = ' (Frac.ml _ q r)
  := 1.

Instance Fmult_comm@{} : Commutative Fplus.
Proof.
hnf. apply (F_ind2 _).
intros;apply path, Frac.pl_comm.
Qed.

Instance F_ring@{} : IsRing F.
Proof.
repeat split;
first [change sg_op with mult; change mon_unit with 1|
       change sg_op with plus; change mon_unit with 0].
- apply _.
- hnf. apply (F_ind3 _).
  intros;apply path. apply Frac.pl_assoc.
- hnf. apply (F_ind _).
  intros;apply path, Frac.pl_0_l.
- hnf. apply (F_ind _).
  intros;apply path, Frac.pl_0_r.
- hnf. apply (F_ind _).
  intros;apply path, Frac.pl_neg_l.
- hnf;intros.
  rewrite (commutativity (f:=plus)).
  revert x;apply (F_ind _).
  intros;apply path, Frac.pl_neg_l.
- apply _.
- apply _.
- hnf; apply (F_ind3 _).
  intros;apply path, Frac.ml_assoc.
- hnf. apply (F_ind _).
  intros;apply path. red;simpl.
  rewrite 2!mult_1_l. reflexivity.
- hnf. apply (F_ind _).
  intros;apply path. red;simpl.
  rewrite 2!mult_1_r. reflexivity.
- hnf; apply (F_ind2 _).
  intros;apply path.
  red;simpl.
  rewrite (mult_comm (num y)), (mult_comm (den y)).
  reflexivity.
- hnf. apply (F_ind3 _).
  intros a b c;apply path.
  red;simpl.
  rewrite <-!(mult_assoc (num a)).
  rewrite <-plus_mult_distr_l.
  rewrite <-(mult_assoc (num a)). apply ap.
  rewrite (mult_comm (den a) (den c)), (mult_comm (den a) (den b)).
  rewrite (mult_assoc (num b)), (mult_assoc (num c)).
  rewrite <-plus_mult_distr_r.
  rewrite <-(mult_assoc _ (den a) (den a * _)).
  apply ap.
  rewrite (mult_comm (den b)), <-mult_assoc. apply ap.
  rewrite (mult_comm (den a)). apply associativity.
Qed.

Global Instance Fdec_rec@{} : DecRecip F.
Proof.
refine (F_rec (fun x => ' (Frac.dec_rec _ x)) _).
intros. apply path. apply Frac.dec_recip_respect;trivial.
Defined.

Lemma classes_eq_related@{} : forall q r, ' q = ' r -> equiv q r.
Proof.
apply classes_eq_related@{UR UR Ularge Uhuge};apply _.
Qed.

Lemma class_neq@{} : forall q r, ~ (equiv q r) -> ' q <> ' r.
Proof.
intros q r E1 E2;apply E1;apply classes_eq_related, E2.
Qed.

Lemma classes_neq_related@{} : forall q r, ' q <> ' r -> ~ (equiv q r).
Proof.
intros q r E1 E2;apply E1,path,E2.
Qed.

Lemma dec_recip_0@{} : / 0 = 0.
Proof.
unfold dec_recip. simpl.
unfold Frac.dec_rec;simpl.
destruct (decide_rel paths 0 0) as [_|E].
- reflexivity.
- destruct E;reflexivity.
Qed.

Lemma dec_recip_nonzero_aux@{} : forall q, ' q <> 0 -> num q <> 0.
Proof.
intros q E;apply classes_neq_related in E.
apply Frac.nonzero_num in E. trivial.
Qed.

Lemma dec_recip_nonzero@{} : forall q (E : ' q <> 0),
  / (' q) = ' (frac (den q) (num q) (dec_recip_nonzero_aux q E)).
Proof.
intros. apply path.
red;simpl. unfold Frac.dec_rec.
apply classes_neq_related, Frac.nonzero_num in E.
destruct (decide_rel paths (num q) 0) as [E'|?];[destruct E;apply E'|].
simpl. reflexivity.
Qed.

Global Instance F_field@{} : IsDecField F.
Proof.
split;try apply _.
- red. apply class_neq.
  unfold equiv;simpl. rewrite 2!mult_1_r. solve_propholds.
- apply dec_recip_0.
- apply (F_ind (fun x => _ -> _)).
  intros x E.
  rewrite (dec_recip_nonzero _ E).
  apply path;red;simpl. rewrite mult_1_r,mult_1_l.
  apply mult_comm.
Qed.

Lemma dec_class@{} : forall q r, Decidable (class q = class r).
Proof.
intros q r.
destruct (dec (equiv q r)) as [E|E].
- left. apply path,E.
- right. intros E'.
  apply E. apply (classes_eq_related _ _ E').
Defined.

Global Instance F_dec@{} : DecidablePaths F.
Proof.
hnf. apply (F_ind2 _).
apply dec_class.
Qed.

Lemma mult_num_den@{} q :
  ' q = (' num q) / ' den q.
Proof.
apply path. red. simpl.
rewrite mult_1_l. unfold Frac.dec_rec.
simpl. destruct (decide_rel paths (den q) 0) as [E|E];simpl.
- destruct (den_ne_0 q E).
- rewrite mult_1_r. reflexivity.
Qed.

Lemma recip_den_num@{} q :
  / ' q = (' den q) / 'num q.
Proof.
apply path;red;simpl.
unfold Frac.dec_rec;simpl.
destruct (decide_rel paths (num q) 0) as [E|E];simpl.
- rewrite (mult_0_r (Azero:=Azero)), 2!mult_0_l. reflexivity.
- rewrite mult_1_l,mult_1_r. reflexivity.
Qed.

(* A final word about inject *)
Global Instance inject_sr_morphism@{} : IsSemiRingPreserving (cast R F).
Proof.
repeat (split; try apply _).
- intros x y. apply path. change ((x + y) * (1 * 1) = (x * 1 + y * 1) * 1).
  rewrite !mult_1_r. reflexivity.
- intros x y. apply path. change ((x * y) * (1 * 1) = x * y * 1).
  rewrite !mult_1_r. reflexivity.
Qed.

Global Instance inject_injective@{} : IsInjective (cast R F).
Proof.
repeat (split; try apply _).
intros x y E. apply classes_eq_related in E.
red in E. simpl in E. rewrite 2!mult_1_r in E;trivial.
Qed.

End contents.

Arguments F R {_ _ _}.

Module Lift.

Section morphisms.
Universe UR1 UR2.
Context `{Funext} `{Univalence}.
Context {R1:Type@{UR1} } `{IsIntegralDomain R1} `{DecidablePaths R1}.
Context {R2:Type@{UR2} } `{IsIntegralDomain R2} `{DecidablePaths R2}.
Context `(f : R1 -> R2) `{!IsSemiRingPreserving f} `{!IsInjective f}.

Definition lift@{} : F R1 -> F R2.
Proof.
apply (F_rec (fun x => class (Frac.lift f x))).
intros;apply path,Frac.lift_respects;trivial.
Defined.

Global Instance lift_sr_morphism@{i} : IsSemiRingPreserving lift.
Proof.
(* This takes a few seconds. *)
split;split;red.
- apply (F_ind2@{UR1 UR2 i} _).
  intros;simpl.
  apply @path. (* very slow or doesn't terminate without the @ but fast with it *)
  red;simpl.
  repeat (rewrite <-(preserves_mult (f:=f)) || rewrite <-(preserves_plus (f:=f))).
  reflexivity.
- simpl. apply path.
  red;simpl. rewrite (preserves_0 (f:=f)). rewrite 2!mult_0_l. reflexivity.
- apply (F_ind2@{UR1 UR2 i} _).
  intros;simpl. apply @path.
  red;simpl.
  rewrite <-!(preserves_mult (f:=f)). reflexivity.
- simpl. apply path.
  red;simpl. apply commutativity.
Qed.

Global Instance lift_injective@{i} : IsInjective lift.
Proof.
red.
apply (F_ind2@{UR1 i i} (fun _ _ => _ -> _)).
intros x y E.
simpl in E.
apply classes_eq_related in E. red in E;simpl in E.
apply path. red.
apply (injective f). rewrite 2!(preserves_mult (f:=f)).
apply E.
Qed.
End morphisms.

End Lift.

End FracField.