Require Import Coq.Unicode.Utf8.
Require Import microMatlab.LibTactics.
Require Import List.
Import ListNotations.
Require Import Lia.

Create HintDb matrix.
#[export] Hint Constants Transparent: matrix.
#[export] Hint Variables Transparent: matrix.

(** [matrix_content] contains the contents of the matrix in a tagged structure *)
Inductive matrix_content (A: Type) : Type :=
  | Scalar: A → matrix_content A
  | Matrix: list (matrix_content A) → matrix_content A
.

#[export] Hint Constructors matrix_content: matrix.

(** with an implicit type argument. *)
Arguments Scalar {A}.
Arguments Matrix {A} _.

(* Parameter P: matrix_content nat → Prop. *)
(* Parameter ms: list (matrix_content nat). *)
(* Parameter f: ∀ m: matrix_content nat, P m. *)
(* Check list_ind (Forall P) (Forall_nil P) (λ h t, Forall_cons h (f h)) ms. *)

(** An induction principle for [matrix_content] that also gives information
 * about the submatrices. This can be used for a proof by induction, but choose
 * the induction hypothesis carefully! *)
Definition matrix_content_ind_strong:
  ∀ {A: Type} (P: matrix_content A → Prop),
  (∀ a: A, P (Scalar a)) →
  (∀ ms: list (matrix_content A), Forall P ms → P (Matrix ms)) →
  (∀ m: matrix_content A, P m)
  := λ A P PScalar PSubmatrix,
  fix f (m: matrix_content A)
  := match m with
     | Scalar a => PScalar a
     | Matrix ms => PSubmatrix ms (list_ind (Forall P) (Forall_nil P) (λ h t, Forall_cons h (f h)) ms)
     end.

(** A tactic that makes induction using [matrix_content_ind_strong] shorter to
 * invoke. *)
Ltac mc_ind x := induction x using matrix_content_ind_strong.

(* Example mc_ind_ex: ∀ mc: matrix_content nat, *)
(*   match mc with *)
(*   | Scalar n => n ≥ 0 *)
(*   | Matrix ms => True (1* stating this part seems hard, so let's do something trivial *1) *)
(*   end. *)
(* Proof. *)
(*   mc_ind mc. *)
(*   (1* induction mc using matrix_content_ind_strong. *1) *)
(*   - apply le_0_n. *)
(*   - (1* induction hypothesis! *1) *)
(*     Check H. *)
(*     exact I. *)
(* Qed. *)

(** The actual matrix type. *)
Record matrix (A: Type) : Type := {
  shape: list nat; (* A list of the dimensions for the matrix. *)
  contents: matrix_content A (* The elements of the matrix. *)
}.

(** Implicit type arguments for matrix. *)
Arguments shape {A} _.
Arguments contents {A} _.

(* Check matrix. *)

(* Check {| shape := [1;2;3]; contents := Matrix [ *)
(*   Matrix [Matrix [Scalar 1; Scalar 2; Scalar 3]; *)
(*           Matrix [Scalar 4; Scalar 5; Scalar 6]]]|}. *)

(* Check List.Forall. *)
(* Check List.Forall_forall. *)
(* Check List.Forall_nth. *)
(* Check List.Forall_app. *)
(* Check List.Forall_elt. *)
(* Check List.Forall_rev. *)
(* (1* and a bunch more *1) *)

(** "Check" by computing a proposition (i.e., proof burdern) that a [matrix] is
 * well formed; i.e. the dimensions of the matrix match with the length of
 * matrix contents. A scalar has empty [shape]. *)
Fixpoint well_formed' {A: Type} (shape: list nat) (contents: matrix_content A): Prop :=
  (* If the [shape] is an empty list, then the [matrix] in question must be a
   * [Scalar]. *)
  match shape with
  | [] => match contents with
          | Scalar _ => True
          | Matrix _ => False
          end
  (* Otherwise, we look at the [matrix_content] and make sure it has the same
   * length as the head of the dimensions list.
   * Then pass the tail to a new call of [well_formed'].*)
  | h::t => match contents with
            | Matrix ms => length ms = h ∧ Forall (well_formed' t) ms
            | Scalar _ => False
            end
  end.

(** A restated version of [well_formed'] that takes a [matrix] record as a
 * parameter instead. This is more convenient then unbundling the matrix in some
 * cases.*)
Definition well_formed {A: Type} (m: matrix A) := well_formed' (shape m) (contents m).
#[export] Hint Unfold well_formed: matrix.

(** A tactic used to repeatedly "unwind" a matrix's shape and contents to prove
 * it is well-formed. Handles most "literal"/"ground" cases automatically. *)
Ltac wf_easy :=
  unfold well_formed;
  repeat (simpl; split; try reflexivity; (* simplify well_formed'/length, split the
                                            conjunct case, solve the length case *)
  apply Forall_forall; simpl; (* convert the Forall to In implies P, simplify In *)
  (let H := fresh "H" in intros x H; decompose sum H; clear H); (* destruct all the In cases *)
  subst (* use the hypothesis to simplify the match arms, which either gets us
  another well_formed' invocation (repeat!) or a "True", which (accidentally)
  gets handled by the split near the top *)).

(* Application of the wf_easy tactic to show that a 3-dimensional matrix is well-formed. *)
Example wf_1: well_formed {| shape := [1;2;3]; contents := Matrix [
                Matrix [Matrix [Scalar 1; Scalar 2; Scalar 3];
                        Matrix [Scalar 4; Scalar 5; Scalar 6]]] |}.
Proof.
  wf_easy.

  (* (1* old tedious proof *1) *)
  (* unfold well_formed. *)
  (* simpl; split; try reflexivity. *)
  (* apply Forall_forall; simpl. intros x [H | []]; subst. *)
  (* simpl; split; try reflexivity. *)
  (* apply Forall_forall; simpl. intros x [H | [H | []]]; subst. *)
  (* all: simpl; split; try reflexivity. *)
  (* all: apply Forall_forall; simpl. *)
  (* all: intros x [H | [H | [H | []]]]; now subst x. *)
Qed.

(** If a dimension of the shape list is 0, then the only matrix that can be
 * represented is the empty matrix. *)
Theorem wf_0_vacuous: ∀ A t, @well_formed A {| shape := 0::t; contents := Matrix [] |}.
Proof. wf_easy. Qed.

(** The same [well_formed'] definition as before, but written as Inductive
 * Proposition instead. This make it possible to perform induction on evidence;
 * i.e., induction on a matrix in an expected way (given that the matrix is
 * [well_formedI']). *)
Inductive well_formedI' {A: Type}: list nat → matrix_content A → Prop :=
  | WF_Scalar: ∀ a, well_formedI' [] (Scalar a)
  | WF_Empty: ∀ t, well_formedI' (0::t) (Matrix [])
  | WF_Cons: ∀ h t m ms,
      well_formedI' (h::t) (Matrix ms) →
      well_formedI' t m →
      well_formedI' ((S h)::t) (Matrix (m::ms))
.
#[export] Hint Constructors well_formedI': matrix.

(** Simple form of [well_formedI'] that only requires a matrix record to be
 * passed as parameter and unwraps it to get its shape and contents. Analogous
 * to [well_formed]. *)
Definition well_formedI {A: Type} (m: matrix A) := well_formedI' (shape m) (contents m).
#[export] Hint Unfold well_formedI: matrix.

(** When given a [shape] [t] and list of [matrix_content] [ms], if every
 * [matrix_content] in [ms] matches [shape] [t], you can construct a
 * [well_formedI'] [Matrix] of [ms], with the length of [ms] being prepended to
 * the list of dimensions. *)
Theorem wfI_all_wf_t: ∀ A t (ms: list (matrix_content A)),
  Forall (well_formedI' t) ms →
  well_formedI' ((length ms)::t) (Matrix ms).
Proof.
  (* induction on the list *)
  induction ms; intros; simpl.
  - (* the base case is the constructor WF_Empty *)
    auto with matrix.
  - (* the inductive case is an instance of WF_Cons, leaving two subgoals. *)
    inverts H;
    (* but the hypothesis provides enough information (combined with the induction
    * hypothesis) to finish the proof. *)
    auto with matrix.
Qed.

(** Proof that both definitions of [well_formed] (boolean and IndProp version)
 * are equivalent to one another. Uses [wfI_all_wf_t] to demonstrate matching
 * shape across both definitions. *)
Theorem well_formed_agree: ∀ A (m: matrix A), well_formed m ↔ well_formedI m.
Proof.
  (* need to discuss specific parts of matrix, esp. for induction to work *)
  destruct m as [shape contents].
  unfold well_formedI; unfold well_formed; simpl.
  split.
  - (* well_formed m → well_formedI m *)
    (* induction on the contents, but with shape crucially generalized *)
    gen shape.
    mc_ind contents; intros shape Hwf;
      (* need case analysis on shape to keep in sync with contents *)
      destruct shape;
      (* but, some cases are trivial (base cases) and others are contradictory *)
      try easy;
      (* and try constructors from well_formedI' on the rest *)
      try auto with matrix.
    (* well_formed' (n::shape) (Matrix ms) → well_formedI' (n::shape) (Matrix ms) *)
    inverts Hwf. (* use the information we know *)
    apply wfI_all_wf_t.
    (* just need to connect all the pieces via the induction hypothesis;
     * Forall_impl could probably do it, but unfolding the Foralls gives enough
     * to put the pieces together *)
    rewrite Forall_forall in *; auto.
  - (* well_formedI m → well_formed m *)
    intros.
    (* induction on the evidence *)
    induction H;
      (* wf_easy takes care of the base-cases *)
      try wf_easy; simpl.
    (* well_formedI' ((S h)::t) Matrix (m::ms) → well_formed' ((S h)::t) (Matrix (m::ms) *)
    (* use what we know *) inverts IHwell_formedI'1.
    (* all the pieces are there, go find them *)
    split; auto.
Qed.

#[export] Hint Resolve <- well_formed_agree: matrix.
#[export] Hint Resolve -> well_formed_agree: matrix.

(** Similar as [well_formed_agree] but for the unwrapped [well_formed'] instead.
 * A more natural way would have been to prove this first, and do the other
 * version as a corollary; yet we initially stated the first agreement, and only
 * later realized we needed this one. *)
Corollary well_formed'_agree: ∀ A (contents: matrix_content A) shape,
  well_formed' shape contents ↔ well_formedI' shape contents.
Proof.
  intros.
  (* introduce the previous theorem *)
  specialize well_formed_agree with (m := {| shape := shape0; contents := contents0 |}).
  (* which is exactly enough *)
  (* intros; assumption. *)
  auto.
Qed.

#[export] Hint Resolve <- well_formed'_agree: matrix.
#[export] Hint Resolve -> well_formed'_agree: matrix.

(** Given some [matrix_content], this will compute the shape (dimensionality) of
 * the matrix. The result is somewhat "normalized," as the empty matrix is given
 * shape [0] (when we have already proved it is well-formed for *any* shape
 * 0::t). *)
Fixpoint compute_shape {A: Type} (m: matrix_content A): list nat :=
  match m with
  | Scalar _ => []
  | Matrix [] => [0]
  | Matrix ((m::t) as ms) => (length ms)::(compute_shape m)
  end.

(* Compute compute_shape (Matrix [Matrix [Matrix [Scalar 1; Scalar 2; Scalar 3]; *)
(*                                        Matrix [Scalar 4; Scalar 5; Scalar 6]]]). *)

(** If two matrices are well-formed and have the same shape, [compute_shape] will
 * yield the same results for both. *)
Lemma wf_same_shape: ∀ A shape (m1 m2: matrix_content A),
  well_formed' shape m1 →
  well_formed' shape m2 →
  compute_shape m1 = compute_shape m2.
Proof.
  intros A shape.
  (* induction on the shape list *)
  induction shape;
    (* case analysis to keep in sync *)
    destruct m1, m2;
    (* get rid of the base/contradictory cases *)
    try easy;
    intros.
  (* a::shape0, Matrix l, Matrix l0 →
   * compute_shape (Matrix l) = compute_shape (Matrix l0) *)
  (* use what we know *) inverts H. inverts H0.
  (* we need information about the actual lists to simplify compute_shape *)
  destruct l; destruct l0; try easy.
  (* both lists non-empty
   * relate m to m0 and l to l0 *)
  simpl in *. inverts H.
  (* l0 gone *) f_equal.
  (* extract heads *) apply Forall_inv in H2, H1.
  (* the induction hypothesis combines with other assumptions to finish it *)
  auto.
Qed.

#[export] Hint Resolve wf_same_shape: matrix.

(** Extension of [wf_same_shape] to lists. *)
Corollary wf_sub_same_shape: ∀ A shape (m: matrix_content A) (ms: list (matrix_content A)),
  well_formed' shape m →
  Forall (well_formed' shape) ms →
  Forall (λ m', compute_shape m' = compute_shape m) ms.
Proof.
  (* previous gives well_formed' shape0 → equivalent compute_shapes; Forall_impl
   * lifts the implication to lists. *)
  eauto using Forall_impl with matrix.
Qed.

(** Proof that if a matrix is well-formed, the matrix formed by its content and
 * the computed shape of its contents will also be well-formed. *)
Theorem compute_shape_wf_normalizes: ∀ A (m: matrix A),
  well_formed m →
  well_formed {| shape := compute_shape (contents m); contents := contents m |}.
Proof.
  destruct m as [shape contents]; simpl.
  (* induction on the contents; generalized shape necessary *)
  gen shape.
  mc_ind contents;
    (* usual case analysis *)
    intros shape; destruct shape; try wf_easy; try easy.
  (* inductive case *)
  simpl. introv [Hlength Hms].
  (* case analsysis on ms to handle match; see if wf_easy is enough to finish *)
  destruct ms; try now wf_easy.
  (* unfold definition; get to the interesting bit *)
  simpl. split; try reflexivity.
  (* change some forms to the usual quantifiers; the goal is to use the
   * induction hypothesis H *)
  inverts Hms as Hm Hms.
  rewrite Forall_forall in *.
  introv HIn.
  specialize H with (x := x).
  (* now apply it, but we have to keep the HIn around, as apply H in HIn doesn't
   * work (cannot find shape?), instead of giving a ∀ shape *)
  apply H with shape0 in HIn as Hwf; clear H.
  - (* original goal: well_formed' (compute_shape m) x
     * but we know well_formed' (compute_shape x) x; can we connect them? cf.
     * Hms and Hin combined with wf_same_shape. *)
    replace (compute_shape m) with (compute_shape x); try assumption.
    clear Hwf.
    inverts HIn; eauto with matrix. (* uses wf_same_shape *)
  - (* premise of the original induction hypothesis needed for application
     * just like earlier, HIn/Hms are enough to finish it *)
    inverts HIn; auto with matrix.
Qed.

(* TODO want to support
 * - index by a range, including the special range ":" meaning everything *)

(* Check List.nth. *)
(* Check List.nth_error. *)

Definition product (shape: list nat) := List.fold_right Nat.mul 1 shape.

(* Check List.concat. *)

(** For a list of lists of length n, the length of all lists concatenated
 * together is equal to n * the number of lists. *)
Theorem concat_length_mult: ∀ A (xss: list (list A)) n,
  Forall (λ xs, length xs = n) xss →
  length (concat xss) = n * length xss.
Proof.
  induction xss; intros.
  - (* [] *)
    simpl. lia.
  - (* a::xss *)
    simpl. inverts H.
    rewrite app_length.
    (* finish with the induction hypothesis *)
    rewrite (IHxss (length a));
      (* by lia, for the original goal *)
      lia
      (* or assumption for the premise *)
      || assumption.
Qed.

(* Maybe not necessary? *)
(** Attempt to relate well-formedness to [concat_length_mult] *)
Theorem wf_all_length_same: ∀ A (ms: list (matrix_content A)) h n t,
  well_formed {| shape := h::n::t; contents := Matrix ms |} →
  Forall (λ m', ∃ ms', m' = Matrix ms' ∧ length ms' = n) ms.
Proof.
  induction ms; intros;
    (* handles [], sets up goals for a::ms *)
    try constructor.
  (* a::ms *)
  - (* P a *)
    clear IHms. destruct a.
    * (* Scalar; contradiction: no-longer well-formed *)
      inverts H. now inverts H1.
    * (* Matrix *)
      exists l. split; try reflexivity.
      inverts H.
      apply Forall_inv in H1.
      now inverts H1.
  - (* Forall P l *)
    (* notice the (h-1), since h is for Matrix (a::ms) and we need ms here *)
    apply (IHms (h-1) n t).
    unfold well_formed; simpl.
    inverts H.
    split; try (simpl; lia).
    (* massaging the Foralls *)
    rewrite Forall_forall in *.
    intros.
    (* easy premise for H1, which is well-formedness on submatrices *)
    assert (In x (a::ms)) by (simpl; now right). clear H.
    apply H1 in H0. clear H1.
    (* resolve a match: well_formed' (n::t) x is enough to finish *)
    destruct x; auto.
Qed.

(** Given a matrix of arbitrary dimensionality, will return a flat list of all
 * the contents. *)
Fixpoint linearize' {A: Type} (contents: matrix_content A): list A :=
  match contents with
  | Scalar a => [a]
  | Matrix ms => flat_map linearize' ms
      (* equivalent to concat (map linearize' ms *)
      (* cf. flat_map_concat_map *)
  end.

(** Same as [linearize'], but with a [matrix] record directly. *)
Definition linearize {A: Type} (m: matrix A): matrix A :=
  {| shape := [product (compute_shape (contents m))];
     contents := Matrix (map Scalar (linearize' (contents m))) |}.
#[export] Hint Unfold linearize: matrix.

(* Compute linearize {| shape := [1;2;3]; contents := Matrix [ *)
(*                 Matrix [Matrix [Scalar 1; Scalar 2; Scalar 3]; *)
(*                         Matrix [Scalar 4; Scalar 5; Scalar 6]]]|}. *)

(** Proof that the length of a linearized matrix will be the same as the product
 * of the matrix's dimensions. Part of the spec of [linearize]. *)
Theorem linearize'_product: ∀ A (m: matrix A),
  well_formed m →
  length (linearize' (contents m)) = product (compute_shape (contents m)).
Proof.
  intros.
  (* let's use the inductive version for better information *)
  rewrite well_formed_agree in H.
  destruct m as [shape contents]; unfold well_formedI in *; simpl in *.
  induction H; (* base cases *) try reflexivity.
  (* inductive case *)
  simpl.
  rewrite app_length.
  (* definition of linearize' on a Matrix *)
  replace (flat_map linearize' ms) with (linearize' (Matrix ms)) by reflexivity.
  rewrite IHwell_formedI'1; clear IHwell_formedI'1.
  rewrite IHwell_formedI'2; clear IHwell_formedI'2.
  (* only need equality for one more set of addends *) f_equal.
  (* depends on length of ms *)
  destruct ms; (* [] *) try reflexivity.
  (* m0::ms *)
  simpl. inverts H.
  (* just need (compute_shape m = compute_shape m0) *)
  enough (compute_shape m = compute_shape m0). { now rewrite H. }
  (* but they are well_formed with respect to the same shape *)
  eauto with matrix.
Qed.

#[export] Hint Resolve linearize'_product: matrix.

(** Proof that if a matrix is well-formed, the linearized form of that matrix
 * will also be well-formed. Part of the spec of [linearize]. *)
Theorem linearize_wf: ∀ A (m: matrix A),
  well_formed m → well_formed (linearize m).
Proof.
  destruct m as [shape contents].
  unfold well_formed; simpl.
  (* regular contents induction is enough; do the usual syncing on shape/get rid
   * of easy/contradictory cases *)
  induction contents; intros; destruct shape; try easy; try wf_easy.
  inverts H.
  (* usual quantifiers *)
  rewrite Forall_forall in *.
  split.
  - (* length … = product … *)
    rewrite map_length.
    (* re-shape for linearize'_product *)
    pose ({| shape := (length l)::shape0; contents := Matrix l |}).
    replace (Matrix l) with (contents m); try reflexivity.
    apply linearize'_product.
    (* now go back and use the details of the matrix, but in the inductive
     * version, since we can relate the use of length to it more easily *)
    subst m. apply well_formed_agree.
    apply wfI_all_wf_t.
    (* back to Forall *)
    apply Forall_forall in H1.
    (* P implies Q under Forall *)
    eauto using Forall_impl with matrix.
  - (* everyting is scalar in the map, since the shape list can only be a single
     * element after linearize. but since the function being mapped is the
     * Scalar constructor, this should be easy. *)
    intros. rewrite in_map_iff in H. decompose record H; clear H.
    now subst.
Qed.

(** Given a matrix, will return the nth element of the matrix after linearizing.
 * [n] will work for values between 1 and the product of the matrix's shape. *)
Definition nth {A: Type} (m: matrix A) (idx: nat): option A :=
  nth_error (linearize' (contents m)) (idx-1).

(* what about 0? 0-1 = 0… *)
(* Compute List.map (nth {| shape := [1;2;3]; contents := Matrix [ *)
(*                 Matrix [Matrix [Scalar 1; Scalar 2; Scalar 3]; *)
(*                         Matrix [Scalar 4; Scalar 5; Scalar 6]]] |}) *)
(*                  [1;2;3;4;5;6;7]. *)

(* TODO spec nth *)

Fixpoint list_option_to_option_list {A: Type} (xs: list (option A)): option (list A)
  := match xs with
     | [] => Some []
     | None::_ => None
     | Some x::t => match list_option_to_option_list t with
                    | None => None
                    | Some t => Some (x::t)
                    end
     end.

Theorem list_option_to_option_list_none_iff_contains_none: ∀ A (xs: list (option A)),
  list_option_to_option_list xs = None ↔ In None xs.
Proof.
  induction xs; (* [] *) try easy.
  (* a::xs
   * to proceed depends on whether a is None or Some
   * some of the ↔ cases are easy *)
  destruct a; simpl; split; try (intros; auto).
  - (* list_option_to_option_list (Some a::xs) = None → In None (Some a::xs) *)
    (* analysis required by definition, but one case is contradictory *)
    destruct (list_option_to_option_list xs); try easy.
    (* but now the induction hypothesis applies *)
    right. now apply IHxs.
  - (* In None (Some a::xs) → list_option_to_option_list (Some a::xs) = None *)
    (* must be the case that None is in xs *)
    destruct H; try discriminate.
    (* but then the induction hypothesis applies *)
    apply IHxs in H.
    now rewrite H.
Qed.

#[export] Hint Resolve <- list_option_to_option_list_none_iff_contains_none: datatypes.
#[export] Hint Resolve -> list_option_to_option_list_none_iff_contains_none: datatypes.

Theorem list_option_to_option_list_some_iff_all_some: ∀ A (xs: list (option A)) xs',
  list_option_to_option_list xs = Some xs'
  ↔
  (length xs = length xs'
  ∧ ∀ i,
  match List.nth_error xs i with
    (* out of bounds *)
  | None => List.nth_error xs' i = None
    (* should be no None in xs *)
  | Some None => False
    (* lists agree in bounds *)
  | Some (Some x) => List.nth_error xs' i = Some x
  end).
Proof.
  (* induction on xs but with xs' in sync; get rid of all the
   * contradictions, and split the ↔ proofs *)
  induction xs; destruct xs'; split; intros; try easy.
  - (* list_option_to_option_list [] = Some [] → … *)
    split; try reflexivity.
    (* nth_error always None on the empty lists *) now destruct i.
  - (* list_option_to_option_list (a::xs) = Some [] → … *)
    (* spot the contradiction in H ^ *)
    destruct a; simpl in H; destruct (list_option_to_option_list xs); try easy.
  - (* list_option_to_option_list (a::xs) = Some (a0::xs') → … *)
    (* really only care about xs' *)
    specialize IHxs with xs'.
    (* usual analysis on a/xs *)
    destruct a; simpl in H; destruct (list_option_to_option_list xs); try easy.
    (* Some (a::l) = Some (a0::xs') *)
    inverts H.
    (* to get the IHxs conclusions *)
    assert (Some xs' = Some xs') by auto.
    apply IHxs in H; clear IHxs. destruct H.
    split.
    * (* length (Some a0::xs) = length (a0::xs') *)
      simpl. (* we know the tails have the same length *) now f_equal.
    * (* ∀ i, … *)
      destruct i; (* 0 *) try easy.
      (* S i *)
      simpl.
      (* at this point, exactly matches info from IH *)
      gen i. auto.
  - (* length … ∧ ∀ i … → list_option_to_option_list (a::xs) = Some (a0::xs') *)
    (* really only care about xs' *)
    specialize IHxs with xs'.
    (* make hyps more useable *)
    destruct H.
    inverts H.
    (* usual analysis on a/xs *)
    destruct a; simpl.
    * (* Some a; need to handle match *)
      destruct (list_option_to_option_list xs).
      + (* Some l *)
        f_equal.
        (* need a = a0, l = xs' *)
        assert (a = a0). (* from the ∀ i *)
        { specialize H0 with 0. simpl in H0. now inverts H0. }
        subst. f_equal.
        (* now l from the IH *)
        enough (Some l = Some xs'). { now inverts H. }
        apply IHxs; clear IHxs.
        split; auto.
        (* careful with the index! hyp has nth_error (Some a0::xs), but we care
         * about nth_error xs *)
        intros. now specialize H0 with (1+i).
      + (* None, contradiction from the same reasoning *)
        enough (None = Some xs') by easy.
        apply IHxs; clear IHxs.
        split; auto.
        intros. now specialize H0 with (1+i).
    * (* None, also contradiction, but faster to find; the list shouldn't have
       * contained None *)
      now specialize H0 with 0.
Qed.

#[export] Hint Resolve <- list_option_to_option_list_some_iff_all_some: datatypes.
#[export] Hint Resolve -> list_option_to_option_list_some_iff_all_some: datatypes.

Inductive range: Type :=
  | Single: nat → range
  | Subrange: nat → nat → range
  | Fullrange: range
.

(* Compute firstn (5-(3-1)) (skipn (3-1) [1;2;3;4;5;6]). *)

Fixpoint index_by_range {A: Type} (m: matrix A) (ranges: list range): option (matrix A)
  :=
  match m with {| shape := m_shape; contents := m_contents |} =>
  if Nat.eqb (length ranges) (length m_shape)
  then
    match m_contents, ranges with
    | Scalar a, [] => Some {| shape := []; contents := Scalar a |}
    | Matrix [], ranges =>
        if forallb (λ r, match r with
                         | Fullrange => true
                         | _=> false
                         end) ranges
        then Some {| shape := m_shape; contents := Matrix [] |}
        else None
    | Matrix ms, rh::rt =>
        match rh with
        | Single n =>
            match nth_error ms (n-1) with
            | Some m => index_by_range {| shape := tl m_shape; contents := m |} rt
            | None => None
            end
            (* what if lo > hi? *)
            (* what if either out of bounds *)
        | Subrange lo hi =>
            let sublist := (firstn (hi-(lo-1)) (skipn (lo-1) ms))
            in let submatrices := map (λ m, index_by_range {| shape := tl m_shape; contents := m |} rt) sublist
            in match list_option_to_option_list submatrices with
              (* TODO tl m_shape bogus *)
               | Some ms' => Some {| shape := length ms'::tl m_shape; contents := Matrix (map contents ms')|}
               | None => None
               end
        | Fullrange =>
            let submatrices := map (λ m, index_by_range {| shape := tl m_shape; contents := m |} rt) ms
            in match list_option_to_option_list submatrices with
               | Some ms' => Some {| shape := length ms'::tl m_shape; contents := Matrix (map contents ms')|}
               | None => None
               end
        end
    | _, _ => None
    end
  else None
  end.


(** This file provides a version of the fractional camera whose elements are
in the internal (0,1] of the rational numbers.

Notice that this camera could in principle be obtained by restricting the
validity of the unbounded fractional camera [ufrac]. *)
From iris.algebra Require Export cmra.
From iris.algebra Require Import proofmode_classes.
From iris.prelude Require Import options.

(** Since the standard (0,1] fractional camera is used more often, we define
[frac] through a [Notation] instead of a [Definition]. That way, Coq infers the
[frac] camera by default when using the [Qp] type. *)
Notation frac := Qp (only parsing).

Section frac.
  Canonical Structure fracO := leibnizO frac.

  Local Instance frac_valid_instance : Valid frac := λ x, (x ≤ 1)%Qp.
  Local Instance frac_pcore_instance : PCore frac := λ _, None.
  Local Instance frac_op_instance : Op frac := λ x y, (x + y)%Qp.

  Lemma frac_valid p : ✓ p ↔ (p ≤ 1)%Qp.
  Proof. done. Qed.
  Lemma frac_op p q : p ⋅ q = (p + q)%Qp.
  Proof. done. Qed.
  Lemma frac_included p q : p ≼ q ↔ (p < q)%Qp.
  Proof. by rewrite Qp_lt_sum. Qed.

  Corollary frac_included_weak p q : p ≼ q → (p ≤ q)%Qp.
  Proof. rewrite frac_included. apply Qp_lt_le_incl. Qed.

  Definition frac_ra_mixin : RAMixin frac.
  Proof.
    split; try apply _; try done.
    intros p q. rewrite !frac_valid frac_op=> ?.
    trans (p + q)%Qp; last done. apply Qp_le_add_l.
  Qed.
  Canonical Structure fracR := discreteR frac frac_ra_mixin.

  Global Instance frac_cmra_discrete : CmraDiscrete fracR.
  Proof. apply discrete_cmra_discrete. Qed.
  Global Instance frac_full_exclusive : Exclusive 1%Qp.
  Proof. intros p. apply Qp_not_add_le_l. Qed.
  Global Instance frac_cancelable (q : frac) : Cancelable q.
  Proof. intros n p1 p2 _. apply (inj (Qp_add q)). Qed.
  Global Instance frac_id_free (q : frac) : IdFree q.
  Proof. intros p _. apply Qp_add_id_free. Qed.

  (* This one has a higher precendence than [is_op_op] so we get a [+] instead
     of an [⋅]. *)
  Global Instance frac_is_op q1 q2 : IsOp (q1 + q2)%Qp q1 q2 | 10.
  Proof. done. Qed.
  Global Instance is_op_frac q : IsOp' q (q/2)%Qp (q/2)%Qp.
  Proof. by rewrite /IsOp' /IsOp frac_op Qp_div_2. Qed.
End frac.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype.
Require Import bigop ssralg div ssrnum ssrint.

(******************************************************************************)
(* This file defines a datatype for rational numbers and equips it with a     *)
(* structure of archimedean, real field, with int and nat declared as closed  *)
(* subrings.                                                                  *)
(*          rat == the type of rational number, with single constructor Rat   *)
(*      Rat p h == the element of type rat build from p a pair of integers and*)
(*                 h a proof of (0 < p.2) && coprime `|p.1| `|p.2|            *)
(*         n%:Q == explicit cast from int to rat, postfix notation for the    *)
(*                 ratz constant                                              *)
(*       numq r == numerator of (r : rat)                                     *)
(*       denq r == denominator of (r : rat)                                   *)
(* x \is a Qint == x is an element of rat whose denominator is equal to 1     *)
(* x \is a Qnat == x is a positive element of rat whose denominator is equal  *)
(*                 to 1                                                       *)
(*       ratr x == generic embedding of  (r : R) into an arbitrary unitring.  *)
(******************************************************************************)

Import GRing.Theory.
Import Num.Theory.

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

Local Open Scope ring_scope.
Local Notation sgr := Num.sg.

Record rat : Set := Rat {
  valq : (int * int) ;
  _ : (0 < valq.2) && coprime `|valq.1| `|valq.2|
}.

Bind Scope ring_scope with rat.
Delimit Scope rat_scope with Q.

Definition ratz (n : int) := @Rat (n, 1) (coprimen1 _).
(* Coercion ratz (n : int) := @Rat (n, 1) (coprimen1 _). *)

Canonical rat_subType := Eval hnf in [subType for valq].
Definition rat_eqMixin := [eqMixin of rat by <:].
Canonical rat_eqType := EqType rat rat_eqMixin.
Definition rat_choiceMixin := [choiceMixin of rat by <:].
Canonical rat_choiceType := ChoiceType rat rat_choiceMixin.
Definition rat_countMixin := [countMixin of rat by <:].
Canonical rat_countType := CountType rat rat_countMixin.
Canonical rat_subCountType := [subCountType of rat].

Definition numq x := nosimpl ((valq x).1).
Definition denq x := nosimpl ((valq x).2).

Lemma denq_gt0  x : 0 < denq x.
Proof. by rewrite /denq; case: x=> [[a b] /= /andP []]. Qed.
Hint Resolve denq_gt0.

Definition denq_ge0 x := ltrW (denq_gt0 x).

Lemma denq_lt0  x : (denq x < 0) = false. Proof. by rewrite ltr_gtF. Qed.

Lemma denq_neq0 x : denq x != 0.
Proof. by rewrite /denq gtr_eqF ?denq_gt0. Qed.
Hint Resolve denq_neq0.

Lemma denq_eq0 x : (denq x == 0) = false.
Proof. exact: negPf (denq_neq0 _). Qed.

Lemma coprime_num_den x : coprime `|numq x| `|denq x|.
Proof. by rewrite /numq /denq; case: x=> [[a b] /= /andP []]. Qed.

Fact RatK x P : @Rat (numq x, denq x) P = x.
Proof. by move:x P => [[a b] P'] P; apply: val_inj. Qed.

Fact fracq_subproof : forall x : int * int,
  let n :=
    if x.2 == 0 then 0 else
    (-1) ^ ((x.2 < 0) (+) (x.1 < 0)) * (`|x.1| %/ gcdn `|x.1| `|x.2|)%:Z in
  let d := if x.2 == 0 then 1 else (`|x.2| %/ gcdn `|x.1| `|x.2|)%:Z in
  (0 < d) && (coprime `|n| `|d|).
Proof.
move=> [m n] /=; case: (altP (n =P 0))=> [//|n0].
rewrite ltz_nat divn_gt0 ?gcdn_gt0 ?absz_gt0 ?n0 ?orbT //.
rewrite dvdn_leq ?absz_gt0 ?dvdn_gcdr //= !abszM absz_sign mul1n.
have [->|m0] := altP (m =P 0); first by rewrite div0n gcd0n divnn absz_gt0 n0.
move: n0 m0; rewrite -!absz_gt0 absz_nat.
move: `|_|%N `|_|%N => {m n} [|m] [|n] // _ _.
rewrite /coprime -(@eqn_pmul2l (gcdn m.+1 n.+1)) ?gcdn_gt0 //.
rewrite muln_gcdr; do 2!rewrite muln_divCA ?(dvdn_gcdl, dvdn_gcdr) ?divnn //.
by rewrite ?gcdn_gt0 ?muln1.
Qed.

Definition fracq (x : int * int) := nosimpl (@Rat (_, _) (fracq_subproof x)).

Fact ratz_frac n : ratz n = fracq (n, 1).
Proof. by apply: val_inj; rewrite /= gcdn1 !divn1 abszE mulr_sign_norm. Qed.

Fact valqK x : fracq (valq x) = x.
Proof.
move:x => [[n d] /= Pnd]; apply: val_inj=> /=.
move: Pnd; rewrite /coprime /fracq /=; case/andP=> hd; move/eqP=> hnd.
by rewrite ltr_gtF ?gtr_eqF //= hnd !divn1 mulz_sign_abs abszE gtr0_norm.
Qed.

Fact scalq_key : unit. Proof. by []. Qed.
Definition scalq_def x := sgr x.2 * (gcdn `|x.1| `|x.2|)%:Z.
Definition scalq := locked_with scalq_key scalq_def.
Canonical scalq_unlockable := [unlockable fun scalq].

Fact scalq_eq0 x : (scalq x == 0) = (x.2 == 0).
Proof.
case: x => n d; rewrite unlock /= mulf_eq0 sgr_eq0 /= eqz_nat.
rewrite -[gcdn _ _ == 0%N]negbK -lt0n gcdn_gt0 ?absz_gt0 [X in ~~ X]orbC.
by case: sgrP.
Qed.

Lemma sgr_scalq x : sgr (scalq x) = sgr x.2.
Proof.
rewrite unlock sgrM sgr_id -[(gcdn _ _)%:Z]intz sgr_nat.
by rewrite -lt0n gcdn_gt0 ?absz_gt0 orbC; case: sgrP; rewrite // mul0r.
Qed.

Lemma signr_scalq x : (scalq x < 0) = (x.2 < 0).
Proof. by rewrite -!sgr_cp0 sgr_scalq. Qed.

Lemma scalqE x :
  x.2 != 0 -> scalq x = (-1) ^+ (x.2 < 0)%R * (gcdn `|x.1| `|x.2|)%:Z.
Proof. by rewrite unlock; case: sgrP. Qed.

Fact valq_frac x :
  x.2 != 0 -> x = (scalq x * numq (fracq x), scalq x * denq (fracq x)).
Proof.
case: x => [n d] /= d_neq0; rewrite /denq /numq scalqE //= (negPf d_neq0).
rewrite mulr_signM -mulrA -!PoszM addKb.
do 2!rewrite muln_divCA ?(dvdn_gcdl, dvdn_gcdr) // divnn.
by rewrite gcdn_gt0 !absz_gt0 d_neq0 orbT !muln1 !mulz_sign_abs.
Qed.

Definition zeroq := fracq (0, 1).
Definition oneq := fracq (1, 1).

Fact frac0q x : fracq (0, x) = zeroq.
Proof.
apply: val_inj; rewrite //= div0n !gcd0n !mulr0 !divnn.
by have [//|x_neq0] := altP eqP; rewrite absz_gt0 x_neq0.
Qed.

Fact fracq0  x : fracq (x, 0) = zeroq. Proof. exact/eqP. Qed.

CoInductive fracq_spec (x : int * int) : int * int -> rat -> Type :=
  | FracqSpecN of x.2 = 0 : fracq_spec x (x.1, 0) zeroq
  | FracqSpecP k fx of k != 0 : fracq_spec x (k * numq fx, k * denq fx) fx.

Fact fracqP x : fracq_spec x x (fracq x).
Proof.
case: x => n d /=; have [d_eq0 | d_neq0] := eqVneq d 0.
  by rewrite d_eq0 fracq0; constructor.
by rewrite {2}[(_, _)]valq_frac //; constructor; rewrite scalq_eq0.
Qed.

Lemma rat_eqE x y : (x == y) = (numq x == numq y) && (denq x == denq y).
Proof.
rewrite -val_eqE [val x]surjective_pairing [val y]surjective_pairing /=.
by rewrite xpair_eqE.
Qed.

Lemma sgr_denq x : sgr (denq x) = 1. Proof. by apply/eqP; rewrite sgr_cp0. Qed.

Lemma normr_denq x : `|denq x| = denq x. Proof. by rewrite gtr0_norm. Qed.

Lemma absz_denq x : `|denq x|%N = denq x :> int.
Proof. by rewrite abszE normr_denq. Qed.

Lemma rat_eq x y : (x == y) = (numq x * denq y == numq y * denq x).
Proof.
symmetry; rewrite rat_eqE andbC.
have [->|] /= := altP (denq _ =P _); first by rewrite (inj_eq (mulIf _)).
apply: contraNF => /eqP hxy; rewrite -absz_denq -[X in _ == X]absz_denq.
rewrite eqz_nat /= eqn_dvd.
rewrite -(@Gauss_dvdr _ `|numq x|) 1?coprime_sym ?coprime_num_den // andbC.
rewrite -(@Gauss_dvdr _ `|numq y|) 1?coprime_sym ?coprime_num_den //.
by rewrite -!abszM hxy -{1}hxy !abszM !dvdn_mull ?dvdnn.
Qed.

Fact fracq_eq x y : x.2 != 0 -> y.2 != 0 ->
  (fracq x == fracq y) = (x.1 * y.2 == y.1 * x.2).
Proof.
case: fracqP=> //= u fx u_neq0 _; case: fracqP=> //= v fy v_neq0 _; symmetry.
rewrite [X in (_ == X)]mulrC mulrACA [X in (_ == X)]mulrACA.
by rewrite [denq _ * _]mulrC (inj_eq (mulfI _)) ?mulf_neq0 // rat_eq.
Qed.

Fact fracq_eq0 x : (fracq x == zeroq) = (x.1 == 0) || (x.2 == 0).
Proof.
move: x=> [n d] /=; have [->|d0] := altP (d =P 0).
  by rewrite fracq0 eqxx orbT.
by rewrite orbF fracq_eq ?d0 //= mulr1 mul0r.
Qed.

Fact fracqMM x n d : x != 0 -> fracq (x * n, x * d) = fracq (n, d).
Proof.
move=> x_neq0; apply/eqP.
have [->|d_neq0] := eqVneq d 0; first by rewrite mulr0 !fracq0.
by rewrite fracq_eq ?mulf_neq0 //= mulrCA mulrA.
Qed.

Definition addq_subdef (x y : int * int) := (x.1 * y.2 + y.1 * x.2, x.2 * y.2).
Definition addq (x y : rat) := nosimpl fracq (addq_subdef (valq x) (valq y)).

Definition oppq_subdef (x : int * int) := (- x.1, x.2).
Definition oppq (x : rat) := nosimpl fracq (oppq_subdef (valq x)).

Fact addq_subdefC : commutative addq_subdef.
Proof. by move=> x y; rewrite /addq_subdef addrC [_.2 * _]mulrC. Qed.

Fact addq_subdefA : associative addq_subdef.
Proof.
move=> x y z; rewrite /addq_subdef.
by rewrite !mulrA !mulrDl addrA ![_ * x.2]mulrC !mulrA.
Qed.

Fact addq_frac x y : x.2 != 0 -> y.2 != 0 ->
  (addq (fracq x) (fracq y)) = fracq (addq_subdef x y).
Proof.
case: fracqP => // u fx u_neq0 _; case: fracqP => // v fy v_neq0 _.
rewrite /addq_subdef /= ![(_ * numq _) * _]mulrACA [(_ * denq _) * _]mulrACA.
by rewrite [v * _]mulrC -mulrDr fracqMM ?mulf_neq0.
Qed.

Fact ratzD : {morph ratz : x y / x + y >-> addq x y}.
Proof.
by move=> x y /=; rewrite !ratz_frac addq_frac // /addq_subdef /= !mulr1.
Qed.

Fact oppq_frac x : oppq (fracq x) = fracq (oppq_subdef x).
Proof.
rewrite /oppq_subdef; case: fracqP => /= [|u fx u_neq0].
  by rewrite fracq0.
by rewrite -mulrN fracqMM.
Qed.

Fact ratzN : {morph ratz : x / - x >-> oppq x}.
Proof. by move=> x /=; rewrite !ratz_frac oppq_frac // /add /= !mulr1. Qed.

Fact addqC : commutative addq.
Proof. by move=> x y; rewrite /addq /=; rewrite addq_subdefC. Qed.

Fact addqA : associative addq.
Proof.
move=> x y z; rewrite -[x]valqK -[y]valqK -[z]valqK.
by rewrite !addq_frac ?mulf_neq0 ?denq_neq0 // addq_subdefA.
Qed.

Fact add0q : left_id zeroq addq.
Proof.
move=> x; rewrite -[x]valqK addq_frac ?denq_neq0 // /addq_subdef /=.
by rewrite mul0r add0r mulr1 mul1r -surjective_pairing.
Qed.

Fact addNq : left_inverse (fracq (0, 1)) oppq addq.
Proof.
move=> x; rewrite -[x]valqK !(addq_frac, oppq_frac) ?denq_neq0 //.
rewrite /addq_subdef /oppq_subdef //= mulNr addNr; apply/eqP.
by rewrite fracq_eq ?mulf_neq0 ?denq_neq0 //= !mul0r.
Qed.

Definition rat_ZmodMixin := ZmodMixin addqA addqC add0q addNq.
Canonical rat_ZmodType := ZmodType rat rat_ZmodMixin.

Definition mulq_subdef (x y : int * int) := nosimpl (x.1 * y.1, x.2 * y.2).
Definition mulq (x y : rat) := nosimpl fracq (mulq_subdef (valq x) (valq y)).

Fact mulq_subdefC : commutative mulq_subdef.
Proof. by move=> x y; rewrite /mulq_subdef mulrC [_ * x.2]mulrC. Qed.

Fact mul_subdefA : associative mulq_subdef.
Proof. by move=> x y z; rewrite /mulq_subdef !mulrA. Qed.

Definition invq_subdef (x : int * int) := nosimpl (x.2, x.1).
Definition invq (x : rat) := nosimpl fracq (invq_subdef (valq x)).

Fact mulq_frac x y : (mulq (fracq x) (fracq y)) = fracq (mulq_subdef x y).
Proof.
rewrite /mulq_subdef; case: fracqP => /= [|u fx u_neq0].
  by rewrite mul0r fracq0 /mulq /mulq_subdef /= mul0r frac0q.
case: fracqP=> /= [|v fy v_neq0].
  by rewrite mulr0 fracq0 /mulq /mulq_subdef /= mulr0 frac0q.
by rewrite ![_ * (v * _)]mulrACA fracqMM ?mulf_neq0.
Qed.

Fact ratzM : {morph ratz : x y / x * y >-> mulq x y}.
Proof. by move=> x y /=; rewrite !ratz_frac mulq_frac // /= !mulr1. Qed.

Fact invq_frac x :
  x.1 != 0 -> x.2 != 0 -> invq (fracq x) = fracq (invq_subdef x).
Proof.
by rewrite /invq_subdef; case: fracqP => // k {x} x k0; rewrite fracqMM.
Qed.

Fact mulqC : commutative mulq.
Proof. by move=> x y; rewrite /mulq mulq_subdefC. Qed.

Fact mulqA : associative mulq.
Proof.
by move=> x y z; rewrite -[x]valqK -[y]valqK -[z]valqK !mulq_frac mul_subdefA.
Qed.

Fact mul1q : left_id oneq mulq.
Proof.
move=> x; rewrite -[x]valqK; rewrite mulq_frac /mulq_subdef.
by rewrite !mul1r -surjective_pairing.
Qed.

Fact mulq_addl : left_distributive mulq addq.
Proof.
move=> x y z; rewrite -[x]valqK -[y]valqK -[z]valqK /=.
rewrite !(mulq_frac, addq_frac) ?mulf_neq0 ?denq_neq0 //=.
apply/eqP; rewrite fracq_eq ?mulf_neq0 ?denq_neq0 //= !mulrDl; apply/eqP.
by rewrite !mulrA ![_ * (valq z).1]mulrC !mulrA ![_ * (valq x).2]mulrC !mulrA.
Qed.

Fact nonzero1q : oneq != zeroq. Proof. by []. Qed.

Definition rat_comRingMixin :=
  ComRingMixin mulqA mulqC mul1q mulq_addl nonzero1q.
Canonical rat_Ring := Eval hnf in RingType rat rat_comRingMixin.
Canonical rat_comRing := Eval hnf in ComRingType rat mulqC.

Fact mulVq x : x != 0 -> mulq (invq x) x = 1.
Proof.
rewrite -[x]valqK fracq_eq ?denq_neq0 //= mulr1 mul0r=> nx0.
rewrite !(mulq_frac, invq_frac) ?denq_neq0 //.
by apply/eqP; rewrite fracq_eq ?mulf_neq0 ?denq_neq0 //= mulr1 mul1r mulrC.
Qed.

Fact invq0 : invq 0 = 0. Proof. by apply/eqP. Qed.

Definition RatFieldUnitMixin := FieldUnitMixin mulVq invq0.
Canonical rat_unitRing :=
  Eval hnf in UnitRingType rat RatFieldUnitMixin.
Canonical rat_comUnitRing := Eval hnf in [comUnitRingType of rat].

Fact rat_field_axiom : GRing.Field.mixin_of rat_unitRing. Proof. exact. Qed.

Definition RatFieldIdomainMixin := (FieldIdomainMixin rat_field_axiom).
Canonical rat_iDomain :=
  Eval hnf in IdomainType rat (FieldIdomainMixin rat_field_axiom).
Canonical rat_fieldType := FieldType rat rat_field_axiom.

Lemma numq_eq0 x : (numq x == 0) = (x == 0).
Proof.
rewrite -[x]valqK fracq_eq0; case: fracqP=> /= [|k {x} x k0].
  by rewrite eqxx orbT.
by rewrite !mulf_eq0 (negPf k0) /= denq_eq0 orbF.
Qed.

Notation "n %:Q" := ((n : int)%:~R : rat)
  (at level 2, left associativity, format "n %:Q")  : ring_scope.

Hint Resolve denq_neq0 denq_gt0 denq_ge0.

Definition subq (x y : rat) : rat := (addq x (oppq y)).
Definition divq (x y : rat) : rat := (mulq x (invq y)).

Notation "0" := zeroq : rat_scope.
Notation "1" := oneq : rat_scope.
Infix "+" := addq : rat_scope.
Notation "- x" := (oppq x) : rat_scope.
Infix "*" := mulq : rat_scope.
Notation "x ^-1" := (invq x) : rat_scope.
Infix "-" := subq : rat_scope.
Infix "/" := divq : rat_scope.

(* ratz should not be used, %:Q should be used instead *)
Lemma ratzE n : ratz n = n%:Q.
Proof.
elim: n=> [|n ihn|n ihn]; first by rewrite mulr0z ratz_frac.
  by rewrite intS mulrzDl ratzD ihn.
by rewrite intS opprD mulrzDl ratzD ihn.
Qed.

Lemma numq_int n : numq n%:Q = n. Proof. by rewrite -ratzE. Qed.
Lemma denq_int n : denq n%:Q = 1. Proof. by rewrite -ratzE. Qed.

Lemma rat0 : 0%:Q = 0. Proof. by []. Qed.
Lemma rat1 : 1%:Q = 1. Proof. by []. Qed.

Lemma numqN x : numq (- x) = - numq x.
Proof.
rewrite /numq; case: x=> [[a b] /= /andP [hb]]; rewrite /coprime=> /eqP hab.
by rewrite ltr_gtF ?gtr_eqF // {2}abszN hab divn1 mulz_sign_abs.
Qed.

Lemma denqN x : denq (- x) = denq x.
Proof.
rewrite /denq; case: x=> [[a b] /= /andP [hb]]; rewrite /coprime=> /eqP hab.
by rewrite gtr_eqF // abszN hab divn1 gtz0_abs.
Qed.

(* Will be subsumed by pnatr_eq0 *)
Fact intq_eq0 n : (n%:~R == 0 :> rat) = (n == 0)%N.
Proof. by rewrite -ratzE /ratz rat_eqE /numq /denq /= mulr0 eqxx andbT. Qed.

(* fracq should never appear, its canonical form is _%:Q / _%:Q *)
Lemma fracqE x : fracq x = x.1%:Q / x.2%:Q.
Proof.
move:x => [m n] /=.
case n0: (n == 0); first by rewrite (eqP n0) fracq0 rat0 invr0 mulr0.
rewrite -[m%:Q]valqK -[n%:Q]valqK.
rewrite [_^-1]invq_frac ?(denq_neq0, numq_eq0, n0, intq_eq0) //.
rewrite [_ / _]mulq_frac /= /invq_subdef /mulq_subdef /=.
by rewrite -!/(numq _) -!/(denq _) !numq_int !denq_int mul1r mulr1.
Qed.

Lemma divq_num_den x : (numq x)%:Q / (denq x)%:Q = x.
Proof. by rewrite -{3}[x]valqK [valq _]surjective_pairing /= fracqE. Qed.

CoInductive divq_spec (n d : int) : int -> int -> rat -> Type :=
| DivqSpecN of d = 0 : divq_spec n d n 0 0
| DivqSpecP k x of k != 0 : divq_spec n d (k * numq x) (k * denq x) x.

(* replaces fracqP *)
Lemma divqP n d : divq_spec n d n d (n%:Q / d%:Q).
Proof.
set x := (n, d); rewrite -[n]/x.1 -[d]/x.2 -fracqE.
by case: fracqP => [_|k fx k_neq0] /=; constructor.
Qed.

Lemma divq_eq (nx dx ny dy : rat) :
  dx != 0 -> dy != 0 -> (nx / dx == ny / dy) = (nx * dy == ny * dx).
Proof.
move=> dx_neq0 dy_neq0; rewrite -(inj_eq (@mulIf _ (dx * dy) _)) ?mulf_neq0 //.
by rewrite mulrA divfK // mulrCA divfK // [dx * _ ]mulrC.
Qed.

CoInductive rat_spec (* (x : rat) *) : rat -> int -> int -> Type :=
  Rat_spec (n : int) (d : nat)  & coprime `|n| d.+1
  : rat_spec (* x  *) (n%:Q / d.+1%:Q) n d.+1.

Lemma ratP x : rat_spec x (numq x) (denq x).
Proof.
rewrite -{1}[x](divq_num_den); case hd: denq => [p|n].
  have: 0 < p%:Z by rewrite -hd denq_gt0.
  case: p hd=> //= n hd; constructor; rewrite -?hd ?divq_num_den //.
  by rewrite -[n.+1]/`|n.+1|%N -hd coprime_num_den.
by move: (denq_gt0 x); rewrite hd.
Qed.

Lemma coprimeq_num n d : coprime `|n| `|d| -> numq (n%:~R / d%:~R) = sgr d * n.
Proof.
move=> cnd /=; have <- := fracqE (n, d).
rewrite /numq /= (eqP (cnd : _ == 1%N)) divn1.
have [|d_gt0|d_lt0] := sgrP d;
by rewrite (mul0r, mul1r, mulN1r) //= ?[_ ^ _]signrN ?mulNr mulz_sign_abs.
Qed.

Lemma coprimeq_den n d :
  coprime `|n| `|d| -> denq (n%:~R / d%:~R) = (if d == 0 then 1 else `|d|).
Proof.
move=> cnd; have <- := fracqE (n, d).
by rewrite /denq /= (eqP (cnd : _ == 1%N)) divn1; case: d {cnd}.
Qed.

Lemma denqVz (i : int) : i != 0 -> denq (i%:~R^-1) = `|i|.
Proof.
by move=> h; rewrite -div1r -[1]/(1%:~R) coprimeq_den /= ?coprime1n // (negPf h).
Qed.

Lemma numqE x : (numq x)%:~R = x * (denq x)%:~R.
Proof. by rewrite -{2}[x]divq_num_den divfK // intq_eq0 denq_eq0. Qed.

Lemma denqP x : {d | denq x = d.+1}.
Proof. by rewrite /denq; case: x => [[_ [[|d]|]] //= _]; exists d. Qed.

Definition normq (x : rat) : rat :=  `|numq x|%:~R / (denq x)%:~R.
Definition le_rat (x y : rat) := numq x * denq y <= numq y * denq x.
Definition lt_rat (x y : rat) := numq x * denq y < numq y * denq x.

Lemma gt_rat0 x : lt_rat 0 x = (0 < numq x).
Proof. by rewrite /lt_rat mul0r mulr1. Qed.

Lemma lt_rat0 x : lt_rat x 0 = (numq x < 0).
Proof. by rewrite /lt_rat mul0r mulr1. Qed.

Lemma ge_rat0 x : le_rat 0 x = (0 <= numq x).
Proof. by rewrite /le_rat mul0r mulr1. Qed.

Lemma le_rat0 x : le_rat x 0 = (numq x <= 0).
Proof. by rewrite /le_rat mul0r mulr1. Qed.

Fact le_rat0D x y : le_rat 0 x -> le_rat 0 y -> le_rat 0 (x + y).
Proof.
rewrite !ge_rat0 => hnx hny.
have hxy: (0 <= numq x * denq y + numq y * denq x).
  by rewrite addr_ge0 ?mulr_ge0.
by rewrite /numq /= -!/(denq _) ?mulf_eq0 ?denq_eq0 !ler_gtF ?mulr_ge0.
Qed.

Fact le_rat0M x y : le_rat 0 x -> le_rat 0 y -> le_rat 0 (x * y).
Proof.
rewrite !ge_rat0 => hnx hny.
have hxy: (0 <= numq x * denq y + numq y * denq x).
  by rewrite addr_ge0 ?mulr_ge0.
by rewrite /numq /= -!/(denq _) ?mulf_eq0 ?denq_eq0 !ler_gtF ?mulr_ge0.
Qed.

Fact le_rat0_anti x : le_rat 0 x -> le_rat x 0 -> x = 0.
Proof.
by move=> hx hy; apply/eqP; rewrite -numq_eq0 eqr_le -ge_rat0 -le_rat0 hx hy.
Qed.

Lemma sgr_numq_div (n d : int) : sgr (numq (n%:Q / d%:Q)) = sgr n * sgr d.
Proof.
set x := (n, d); rewrite -[n]/x.1 -[d]/x.2 -fracqE.
case: fracqP => [|k fx k_neq0] /=; first by rewrite mulr0.
by rewrite !sgrM  mulrACA -expr2 sqr_sg k_neq0 sgr_denq mulr1 mul1r.
Qed.

Fact subq_ge0 x y : le_rat 0 (y - x) = le_rat x y.
Proof.
symmetry; rewrite ge_rat0 /le_rat -subr_ge0.
case: ratP => nx dx cndx; case: ratP => ny dy cndy.
rewrite -!mulNr addf_div ?intq_eq0 // !mulNr -!rmorphM -rmorphB /=.
symmetry; rewrite !lerNgt -sgr_cp0 sgr_numq_div mulrC gtr0_sg //.
by rewrite mul1r sgr_cp0.
Qed.

Fact le_rat_total : total le_rat.
Proof. by move=> x y; apply: ler_total. Qed.

Fact numq_sign_mul (b : bool) x : numq ((-1) ^+ b * x) = (-1) ^+ b * numq x.
Proof. by case: b; rewrite ?(mul1r, mulN1r) // numqN. Qed.

Fact numq_div_lt0 n d : n != 0 -> d != 0 ->
  (numq (n%:~R / d%:~R) < 0)%R = (n < 0)%R (+) (d < 0)%R.
Proof.
move=> n0 d0; rewrite -sgr_cp0 sgr_numq_div !sgr_def n0 d0.
by rewrite !mulr1n -signr_addb; case: (_ (+) _).
Qed.

Lemma normr_num_div n d : `|numq (n%:~R / d%:~R)| = numq (`|n|%:~R / `|d|%:~R).
Proof.
rewrite (normrEsg n) (normrEsg d) !rmorphM /= invfM mulrACA !sgr_def.
have [->|n_neq0] := altP eqP; first by rewrite mul0r mulr0.
have [->|d_neq0] := altP eqP; first by rewrite invr0 !mulr0.
rewrite !intr_sign invr_sign -signr_addb numq_sign_mul -numq_div_lt0 //.
by apply: (canRL (signrMK _)); rewrite mulz_sign_abs.
Qed.

Fact norm_ratN x : normq (- x) = normq x.
Proof. by rewrite /normq numqN denqN normrN. Qed.

Fact ge_rat0_norm x : le_rat 0 x -> normq x = x.
Proof.
rewrite ge_rat0; case: ratP=> [] // n d cnd n_ge0.
by rewrite /normq /= normr_num_div ?ger0_norm // divq_num_den.
Qed.

Fact lt_rat_def x y : (lt_rat x y) = (y != x) && (le_rat x y).
Proof. by rewrite /lt_rat ltr_def rat_eq. Qed.

Definition ratLeMixin := RealLeMixin le_rat0D le_rat0M le_rat0_anti
  subq_ge0 (@le_rat_total 0) norm_ratN ge_rat0_norm lt_rat_def.

Canonical rat_numDomainType := NumDomainType rat ratLeMixin.
Canonical rat_numFieldType := [numFieldType of rat].
Canonical rat_realDomainType := RealDomainType rat (@le_rat_total 0).
Canonical rat_realFieldType := [realFieldType of rat].

Lemma numq_ge0 x : (0 <= numq x) = (0 <= x).
Proof.
by case: ratP => n d cnd; rewrite ?pmulr_lge0 ?invr_gt0 (ler0z, ltr0z).
Qed.

Lemma numq_le0 x : (numq x <= 0) = (x <= 0).
Proof. by rewrite -oppr_ge0 -numqN numq_ge0 oppr_ge0. Qed.

Lemma numq_gt0 x : (0 < numq x) = (0 < x).
Proof. by rewrite !ltrNge numq_le0. Qed.

Lemma numq_lt0 x : (numq x < 0) = (x < 0).
Proof. by rewrite !ltrNge numq_ge0. Qed.

Lemma sgr_numq x : sgz (numq x) = sgz x.
Proof.
apply/eqP; case: (sgzP x); rewrite sgz_cp0 ?(numq_gt0, numq_lt0) //.
by move->.
Qed.

Lemma denq_mulr_sign (b : bool) x : denq ((-1) ^+ b * x) = denq x.
Proof. by case: b; rewrite ?(mul1r, mulN1r) // denqN. Qed.

Lemma denq_norm x : denq `|x| = denq x.
Proof. by rewrite normrEsign denq_mulr_sign. Qed.

Fact rat_archimedean : Num.archimedean_axiom [numDomainType of rat].
Proof.
move=> x; exists `|numq x|.+1; rewrite mulrS ltr_spaddl //.
rewrite pmulrn abszE intr_norm numqE normrM ler_pemulr ?norm_ge0 //.
by rewrite -intr_norm ler1n absz_gt0 denq_eq0.
Qed.

Canonical archiType := ArchiFieldType rat rat_archimedean.

Section QintPred.

Definition Qint := [qualify a x : rat | denq x == 1].
Fact Qint_key : pred_key Qint. Proof. by []. Qed.
Canonical Qint_keyed := KeyedQualifier Qint_key.

Lemma Qint_def x : (x \is a Qint) = (denq x == 1). Proof. by []. Qed.

Lemma numqK : {in Qint, cancel (fun x => numq x) intr}.
Proof. by move=> x /(_ =P 1 :> int) Zx; rewrite numqE Zx rmorph1 mulr1. Qed.

Lemma QintP x : reflect (exists z, x = z%:~R) (x \in Qint).
Proof.
apply: (iffP idP) => [/numqK <- | [z ->]]; first by exists (numq x).
by rewrite Qint_def denq_int.
Qed.

Fact Qint_subring_closed : subring_closed Qint.
Proof.
split=> // _ _ /QintP[x ->] /QintP[y ->]; apply/QintP.
  by exists (x - y); rewrite -rmorphB.
by exists (x * y); rewrite -rmorphM.
Qed.

Canonical Qint_opprPred := OpprPred Qint_subring_closed.
Canonical Qint_addrPred := AddrPred Qint_subring_closed.
Canonical Qint_mulrPred := MulrPred Qint_subring_closed.
Canonical Qint_zmodPred := ZmodPred Qint_subring_closed.
Canonical Qint_semiringPred := SemiringPred Qint_subring_closed.
Canonical Qint_smulrPred := SmulrPred Qint_subring_closed.
Canonical Qint_subringPred := SubringPred Qint_subring_closed.

End QintPred.

Section QnatPred.

Definition Qnat := [qualify a x : rat | (x \is a Qint) && (0 <= x)].
Fact Qnat_key : pred_key Qnat. Proof. by []. Qed.
Canonical Qnat_keyed := KeyedQualifier Qnat_key.

Lemma Qnat_def x : (x \is a Qnat) = (x \is a Qint) && (0 <= x).
Proof. by []. Qed.

Lemma QnatP x : reflect (exists n : nat, x = n%:R) (x \in Qnat).
Proof.
rewrite Qnat_def; apply: (iffP idP) => [/andP []|[n ->]]; last first.
  by rewrite Qint_def pmulrn denq_int eqxx ler0z.
by move=> /QintP [] [] n ->; rewrite ?ler0z // => _; exists n.
Qed.

Fact Qnat_semiring_closed : semiring_closed Qnat.
Proof.
do 2?split; move => // x y; rewrite !Qnat_def => /andP[xQ hx] /andP[yQ hy].
  by rewrite rpredD // addr_ge0.
by rewrite rpredM // mulr_ge0.
Qed.

Canonical Qnat_addrPred := AddrPred Qnat_semiring_closed.
Canonical Qnat_mulrPred := MulrPred Qnat_semiring_closed.
Canonical Qnat_semiringPred := SemiringPred Qnat_semiring_closed.

End QnatPred.

Lemma natq_div m n : n %| m -> (m %/ n)%:R = m%:R / n%:R :> rat.
Proof. by apply: char0_natf_div; apply: char_num. Qed.

Section InRing.

Variable R : unitRingType.

Definition ratr x : R := (numq x)%:~R / (denq x)%:~R.

Lemma ratr_int z : ratr z%:~R = z%:~R.
Proof. by rewrite /ratr numq_int denq_int divr1. Qed.

Lemma ratr_nat n : ratr n%:R = n%:R.
Proof. exact: (ratr_int n). Qed.

Lemma rpred_rat S (ringS : @divringPred R S) (kS : keyed_pred ringS) a :
  ratr a \in kS.
Proof. by rewrite rpred_div ?rpred_int. Qed.

End InRing.

Section Fmorph.

Implicit Type rR : unitRingType.

Lemma fmorph_rat (aR : fieldType) rR (f : {rmorphism aR -> rR}) a :
  f (ratr _ a) = ratr _ a.
Proof. by rewrite fmorph_div !rmorph_int. Qed.

Lemma fmorph_eq_rat rR (f : {rmorphism rat -> rR}) : f =1 ratr _.
Proof. by move=> a; rewrite -{1}[a]divq_num_den fmorph_div !rmorph_int. Qed.

End Fmorph.

Section Linear.

Implicit Types (U V : lmodType rat) (A B : lalgType rat).

Lemma rat_linear U V (f : U -> V) : additive f -> linear f.
Proof.
move=> fB a u v; pose phi := Additive fB; rewrite [f _](raddfD phi).
congr (_ + _); rewrite -{2}[a]divq_num_den mulrC -scalerA.
apply: canRL (scalerK _) _; first by rewrite intr_eq0 denq_neq0.
by rewrite !scaler_int -raddfMz scalerMzl -mulrzr -numqE scaler_int raddfMz.
Qed.

Lemma rat_lrmorphism A B (f : A -> B) : rmorphism f -> lrmorphism f.
Proof. by case=> /rat_linear fZ fM; do ?split=> //; apply: fZ. Qed.

End Linear.

Section InPrealField.

Variable F : numFieldType.

Fact ratr_is_rmorphism : rmorphism (@ratr F).
Proof.
have injZtoQ: @injective rat int intr by apply: intr_inj.
have nz_den x: (denq x)%:~R != 0 :> F by rewrite intr_eq0 denq_eq0.
do 2?split; rewrite /ratr ?divr1 // => x y; last first.
  rewrite mulrC mulrAC; apply: canLR (mulKf (nz_den _)) _; rewrite !mulrA.
  do 2!apply: canRL (mulfK (nz_den _)) _; rewrite -!rmorphM; congr _%:~R.
  apply: injZtoQ; rewrite !rmorphM [x * y]lock /= !numqE -lock.
  by rewrite -!mulrA mulrA mulrCA -!mulrA (mulrCA y).
apply: (canLR (mulfK (nz_den _))); apply: (mulIf (nz_den x)).
rewrite mulrAC mulrBl divfK ?nz_den // mulrAC -!rmorphM.
apply: (mulIf (nz_den y)); rewrite mulrAC mulrBl divfK ?nz_den //.
rewrite -!(rmorphM, rmorphB); congr _%:~R; apply: injZtoQ.
rewrite !(rmorphM, rmorphB) [_ - _]lock /= -lock !numqE.
by rewrite (mulrAC y) -!mulrBl -mulrA mulrAC !mulrA.
Qed.

Canonical ratr_additive := Additive ratr_is_rmorphism.
Canonical ratr_rmorphism := RMorphism ratr_is_rmorphism.

Lemma ler_rat : {mono (@ratr F) : x y / x <= y}.
Proof.
move=> x y /=; case: (ratP x) => nx dx cndx; case: (ratP y) => ny dy cndy.
rewrite !fmorph_div /= !ratr_int !ler_pdivl_mulr ?ltr0z //.
by rewrite ![_ / _ * _]mulrAC !ler_pdivr_mulr ?ltr0z // -!rmorphM /= !ler_int.
Qed.

Lemma ltr_rat : {mono (@ratr F) : x y / x < y}.
Proof. exact: lerW_mono ler_rat. Qed.

Lemma ler0q x : (0 <= ratr F x) = (0 <= x).
Proof. by rewrite (_ : 0 = ratr F 0) ?ler_rat ?rmorph0. Qed.

Lemma lerq0 x : (ratr F x <= 0) = (x <= 0).
Proof. by rewrite (_ : 0 = ratr F 0) ?ler_rat ?rmorph0. Qed.

Lemma ltr0q x : (0 < ratr F x) = (0 < x).
Proof. by rewrite (_ : 0 = ratr F 0) ?ltr_rat ?rmorph0. Qed.

Lemma ltrq0 x : (ratr F x < 0) = (x < 0).
Proof. by rewrite (_ : 0 = ratr F 0) ?ltr_rat ?rmorph0. Qed.

Lemma ratr_sg x : ratr F (sgr x) = sgr (ratr F x).
Proof. by rewrite !sgr_def fmorph_eq0 ltrq0 rmorphMn rmorph_sign. Qed.

Lemma ratr_norm x : ratr F `|x| = `|ratr F x|.
Proof.
rewrite {2}[x]numEsign rmorphMsign normrMsign [`|ratr F _|]ger0_norm //.
by rewrite ler0q ?normr_ge0.
Qed.

End InPrealField.

Implicit Arguments ratr [[R]].

(* Conntecting rationals to the ring an field tactics *)

Ltac rat_to_ring :=
  rewrite -?[0%Q]/(0 : rat)%R -?[1%Q]/(1 : rat)%R
          -?[(_ - _)%Q]/(_ - _ : rat)%R -?[(_ / _)%Q]/(_ / _ : rat)%R
          -?[(_ + _)%Q]/(_ + _ : rat)%R -?[(_ * _)%Q]/(_ * _ : rat)%R
          -?[(- _)%Q]/(- _ : rat)%R -?[(_ ^-1)%Q]/(_ ^-1 : rat)%R /=.

Ltac ring_to_rat :=
  rewrite -?[0%R]/0%Q -?[1%R]/1%Q
          -?[(_ - _)%R]/(_ - _)%Q -?[(_ / _)%R]/(_ / _)%Q
          -?[(_ + _)%R]/(_ + _)%Q -?[(_ * _)%R]/(_ * _)%Q
          -?[(- _)%R]/(- _)%Q -?[(_ ^-1)%R]/(_ ^-1)%Q /=.

Lemma rat_ring_theory : (ring_theory 0%Q 1%Q addq mulq subq oppq eq).
Proof.
split => * //; rat_to_ring;
by rewrite ?(add0r, addrA, mul1r, mulrA, mulrDl, subrr) // (addrC, mulrC).
Qed.

Require setoid_ring.Field_theory setoid_ring.Field_tac.

Lemma rat_field_theory :
  Field_theory.field_theory 0%Q 1%Q addq mulq subq oppq divq invq eq.
Proof.
split => //; first exact rat_ring_theory.
by move=> p /eqP p_neq0; rat_to_ring; rewrite mulVf.
Qed.

Add Field rat_field : rat_field_theory.


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

The category of elements of a presheaf "F : C^op ⟶ HSET"

Contents:

- Category of elements ([cat_of_elems])
- Functoriality of the constructon of the category of elements
  ([cat_of_elems_on_nat_trans])
- The forgetful functor from the category of elements to C
  ([cat_of_elems_forgetful])

Originally written by: Matthew Weaver (based on Elements.v by Dan Grayson)
Ported to CT by: Anders Mörtberg

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

Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.Presheaf.

Local Open Scope cat.

Section cat_of_elems_def.

Context {C : category} (X : C^op ⟶ HSET).

Definition cat_of_elems_ob_mor : precategory_ob_mor.
Proof.
exists (∑ (c : C), X c : hSet).
intros a b.
apply (∑ (f : C⟦pr1 a,pr1 b⟧), (pr2 a) = # X f (pr2 b)).
Defined.

Definition cat_of_elems_data : precategory_data.
Proof.
exists cat_of_elems_ob_mor.
split.
+ intros a.
  exists (identity (pr1 a)).
  abstract (exact (eqtohomot (!(functor_id X) (pr1 a)) (pr2 a))).
+ intros a b c f g.
  exists (pr1 f · pr1 g).
  abstract (exact ((pr2 f) @ maponpaths (#X (pr1 f)) (pr2 g)
                    @ (eqtohomot (!(functor_comp X) (pr1 g) (pr1 f)) (pr2 c)))).
Defined.

Definition get_mor {x y : cat_of_elems_data} (f : _⟦x,y⟧) := pr1 f.

Lemma cat_of_elems_mor_eq (x y : cat_of_elems_data) (f g : _⟦x,y⟧) :
  get_mor f = get_mor g → f = g.
Proof.
intros p.
apply subtypePath.
- intro r; apply setproperty.
- exact p.
Qed.

Lemma is_precategory_cat_of_elems_data : is_precategory cat_of_elems_data.
Proof.
split; [split|split]; intros; apply cat_of_elems_mor_eq.
+ apply id_left.
+ apply id_right.
+ apply assoc.
+ apply assoc'.
Defined.

Definition precat_of_elems : precategory :=
  (cat_of_elems_data,,is_precategory_cat_of_elems_data).

End cat_of_elems_def.

Arguments get_mor {_ _ _ _} _.

Lemma has_homsets_cat_of_elems {C : category} (X : C^op ⟶ HSET)
  : has_homsets (precat_of_elems X).
Proof.
intros a b.
apply isaset_total2.
- apply C.
- intro f. apply isasetaprop, setproperty.
Qed.

Definition cat_of_elems {C : category} (X : C^op ⟶ HSET) : category
  := make_category _ (has_homsets_cat_of_elems X).

(** Type as \int in Agda mode *)
Notation "∫ X" := (cat_of_elems X) (at level 3) : cat.

Section cat_of_elems_theory.

Context {C : category} {X Y : C^op ⟶ HSET}.

Definition get_ob (x : ∫ X) : C := pr1 x.
Definition get_el (x : ∫ X) : X (get_ob x) : hSet := pr2 x.
Definition get_eqn {x y : ∫ X} (f : (∫ X)⟦x,y⟧) :
  get_el x = # X (get_mor f) (get_el y)  := pr2 f.

Definition make_ob (c : C) (x : X c : hSet) : ∫ X := (c,,x).
Definition make_mor (r s : ∫ X) (f : C⟦get_ob r,get_ob s⟧)
  (i : get_el r = # X f (get_el s)) : (∫ X)⟦r,s⟧ := (f,,i).

(* Any f : J → I and ρ : X I defines a morphism from (J,,# X ρ) to (I,,ρ) in ∫ X *)
Definition mor_to_el_mor {I J : C} (f : J --> I) (ρ : pr1 X I : hSet) :
  ∫ X ⟦ make_ob J (# (pr1 X) f ρ), make_ob I ρ ⟧ :=
  make_mor (J,,# (pr1 X) f ρ) (I,,ρ) f (idpath (# (pr1 X) f ρ)).

Lemma base_paths_maponpaths_make_ob {I : C} x y (e : x = y) :
  base_paths _ _ (maponpaths (make_ob I) e) = idpath I.
Proof.
now induction e.
Qed.

Lemma transportf_make_ob_eq {I J} (f : C⟦J,I⟧) {a b} (e : make_ob J a = make_ob J b) :
  transportf (λ x : ∫ X, C⟦pr1 x,I⟧) e f = transportf (λ x, C⟦x,I⟧) (base_paths _ _ e) f.
Proof.
now induction e.
Qed.

Lemma transportf_make_ob {A : PreShv (∫ X)} {I : C} {x y} (e : x = y)
  (u : pr1 (pr1 A (make_ob I x))) :
    transportf (λ x, pr1 (pr1 A (make_ob I x))) e u =
    transportf (λ x, pr1 (pr1 A x)) (maponpaths (make_ob I) e) u.
Proof.
now induction e.
Qed.

Lemma make_ob_identity_eq {I : C} (ρ : pr1 (pr1 X I)) :
  make_ob I (# (pr1 X) (identity I) ρ) = make_ob I ρ.
Proof.
exact (maponpaths (make_ob I) (eqtohomot (functor_id X I) ρ)).
Defined.

Lemma mor_to_el_mor_id {I : C} (ρ : pr1 (pr1 X I)) :
  mor_to_el_mor (identity I) ρ =
  transportb (λ Z, ∫ X⟦Z, make_ob I ρ⟧) (make_ob_identity_eq ρ) (identity _).
Proof.
apply (@transportf_transpose_right _ (λ Z : ∫ X, ∫ X ⟦Z,_⟧)), cat_of_elems_mor_eq; simpl.
unfold transportb; rewrite pathsinv0inv0.
rewrite transportf_total2; simpl; rewrite transportf_make_ob_eq.
now unfold make_ob_identity_eq; rewrite base_paths_maponpaths_make_ob, idpath_transportf.
Qed.

Lemma make_ob_comp_eq {I J K} (ρ : pr1 (pr1 X I)) (f : C^op⟦I,J⟧) (g : C^op⟦J,K⟧) :
  make_ob _ (# (pr1 X) (f · g) ρ) = make_ob _ (# (pr1 X) g (# (pr1 X) f ρ)).
Proof.
exact (maponpaths (make_ob K) (eqtohomot (functor_comp X f g) ρ)).
Defined.

Lemma mor_to_el_mor_comp {I J K} (ρ : pr1 (pr1 X I)) (f : C^op⟦I,J⟧) (g : C^op⟦J,K⟧) :
  mor_to_el_mor (f · g) ρ =
  transportb (λ Z, ∫ X⟦Z,_⟧) (make_ob_comp_eq ρ f g)
             (mor_to_el_mor g (# (pr1 X) f ρ) · mor_to_el_mor f ρ).
Proof.
apply (@transportf_transpose_right _ (λ Z : ∫ X, ∫ X ⟦Z,_⟧)), cat_of_elems_mor_eq; simpl.
unfold transportb; rewrite pathsinv0inv0.
rewrite transportf_total2; simpl; rewrite transportf_make_ob_eq.
now unfold make_ob_comp_eq; rewrite base_paths_maponpaths_make_ob, idpath_transportf.
Qed.

(** Functoriality of the construction of the category of elements *)
Definition cat_of_elems_on_nat_trans_data (α : X ⟹ Y) :
  functor_data (∫ X) (∫ Y).
Proof.
exists (λ a, (get_ob a,, α (get_ob a) (get_el a))).
intros b c f.
exists (get_mor f).
abstract (exact (maponpaths (α (get_ob b)) (get_eqn f)
                @ eqtohomot (pr2 α (get_ob c) (get_ob b) (get_mor f)) (get_el c))).
Defined.

Lemma cat_of_elems_on_nat_trans_is_functor (α : X ⟹ Y) :
  is_functor (cat_of_elems_on_nat_trans_data α).
Proof.
split.
- now intros a; apply cat_of_elems_mor_eq.
- now intros a b c f g; apply cat_of_elems_mor_eq.
Qed.

Definition cat_of_elems_on_nat_trans (α : X ⟹ Y) : ∫ X ⟶ ∫ Y :=
  (cat_of_elems_on_nat_trans_data α,, cat_of_elems_on_nat_trans_is_functor α).

(* maybe make a functor [C,SET] ⟶ [category of Precategories] *)

(** The forgetful functor from the category of elements to C *)
Definition cat_of_elems_forgetful : ∫ X ⟶ C.
Proof.
use make_functor.
- exists pr1.
  intros a b; apply pr1.
- now split.
Defined.

Lemma reflects_isos_cat_of_elems_forgetful : reflects_isos cat_of_elems_forgetful.
Proof.
intros [c x] [d y] f Hf.
destruct f as [f i]; destruct Hf as [f' j].
assert (i' : y = #X f' x).
{ intermediate_path (#X (identity d) y).
  - exact (eqtohomot (!functor_id X d) y).
  - intermediate_path (#X (f ∘ f') y).
    + exact (eqtohomot (!maponpaths #X (pr2 j)) y).
    + intermediate_path (#X f' (#X f y)).
      * exact (eqtohomot ((functor_comp X) f f') y).
      * exact (maponpaths (#X f') (!i)).
}
exists (f',,i').
split; apply cat_of_elems_mor_eq; [ exact (pr1 j) | exact (pr2 j) ].
Qed.

End cat_of_elems_theory.


Require Import refocusing_substitutions.
Require Import Setoid.

Module MiniML <: RED_LANG.

Definition v_name := nat.

Inductive expr :=
| Z : expr
| S : expr -> expr
| App : expr -> expr -> expr
| Var : v_name -> expr
| Lam : v_name -> expr -> expr
| Case: expr -> expr -> v_name -> expr -> expr
| Letv: v_name -> expr -> expr -> expr
| Fix : v_name -> expr -> expr
| Pair: expr -> expr -> expr
| Fst : expr -> expr
| Snd : expr -> expr.
Definition term := expr.

Inductive val :=
| vZ : val
| vS : val -> val
| vLam : v_name -> term -> val
| vVar : v_name -> val
| vPair : val -> val -> val.
Definition value := val.

Inductive red :=
| rApp : value -> value -> red
| rLet : v_name -> value -> expr -> red
| rFix : v_name -> term -> red
| rFst : value -> red
| rSnd : value -> red
| rCase: value -> expr -> v_name -> expr -> red.
Definition redex := red.

Inductive ec :=
| s_c : ec
| ap_l : value -> ec
| ap_r : expr -> ec
| case_c : expr -> v_name -> expr -> ec
| let_c : v_name -> expr -> ec
| fst_c : ec
| snd_c : ec
| pair_l : value -> ec
| pair_r : expr -> ec.
Definition elem_context := ec.

Definition context := list elem_context.
Definition empty : context := nil.

Fixpoint value_to_term (v : value) : term :=
match v with
| vZ => Z
| vS v => S (value_to_term v)
| vLam x e => Lam x e
| vVar x => Var x
| vPair vl vr => Pair (value_to_term vl) (value_to_term vr)
end.
Coercion value_to_term : value >-> term.
Fixpoint redex_to_term (r : redex) : term :=
match r with
| rApp vl vr => App (vl:term) (vr:term)
| rLet x v t => Letv x (v:term) t
| rFix x v => Fix x (v:term)
| rFst v => Fst (v:term)
| rSnd v => Snd (v:term)
| rCase v ez x es => Case (v:term) ez x es
end.
Coercion redex_to_term : redex >-> term.
Lemma value_to_term_injective : forall v v' : value, value_to_term v = value_to_term v' -> v = v'.
Proof with auto.
induction v; destruct v'; simpl; intro H; inversion H; f_equal...
Qed.
Hint Resolve value_to_term_injective : miniml.
Lemma redex_to_term_injective : forall r r' : redex, redex_to_term r = redex_to_term r' -> r = r'.
Proof with auto with miniml.
induction r; destruct r'; simpl; intro H; inversion H; f_equal...
Qed.
Hint Resolve redex_to_term : miniml.

  (** The main functions of reduction semantics, defining plugging terms into contexts and
      composing contexts, effectively defining reduction semantics, and some properties. *)
  Definition compose (c0 c1 : context) : context := app c0 c1.
  Definition atom_plug (t : term) (ec : elem_context) : term :=
  match ec with
  | s_c => S t
  | ap_l v => App (v:term) t
  | ap_r e => App t e
  | case_c ez x es => Case t ez x es
  | let_c x e => Letv x t e
  | fst_c => Fst t
  | snd_c => Snd t
  | pair_l v => Pair (v:term) t
  | pair_r e => Pair t e
  end.
  Definition plug (t : term) (c : context) : term := fold_left atom_plug c t.

  Parameter subst : v_name -> expr -> expr -> expr.

  (** The other main function of reduction semantics -- contraction of a redex into a term *)
  Definition contract (r : redex) : option term :=
  match r with
  | rApp (vLam x e) vr => Some (subst x (vr:term) e)
  | rLet x v e => Some (subst x (v:term) e)
  | rFix x e => Some (subst x (Fix x e) e)
  | rFst (vPair vl vr) => Some (value_to_term vl)
  | rSnd (vPair vl vr) => Some (value_to_term vr)
  | rCase vZ ez x es => Some ez
  | rCase (vS v) ez x es => Some (subst x (value_to_term v) es)
  | _ => None
  end.

  (** Datatype of decompositions -- either a value or a redex in a context (analogous to the decompose lemma) *)
  Inductive decomp : Set :=
  | d_val : value -> decomp
  | d_red : redex -> context -> decomp.

  Inductive interm_dec : Set :=
  | in_red : redex -> interm_dec
  | in_val : value -> interm_dec
  | in_term: term -> elem_context -> interm_dec.

  Definition decomp_to_term (d : decomp) : term :=
  match d with
    | d_val v => value_to_term v
    | d_red r c0 => plug (redex_to_term r) c0
  end.
  Definition only_empty (t : term) : Prop := forall t' c, plug t' c = t -> c = empty.
  Definition only_trivial (t : term) : Prop := forall t' c, plug t' c = t -> c = empty \/ exists v, t' = value_to_term v.

  Lemma value_trivial : forall v : value, only_trivial (value_to_term v).
  Proof with auto.
    intros v t c; generalize dependent t; induction c; simpl in *; auto; right.
    intros; destruct (IHc _ H) as [H0 | [v0 H0]]; subst; simpl in *;
    match goal with [Hv : atom_plug ?t ?a = _ ?v |- _] => destruct a; destruct v; inversion Hv; subst end;
    match goal with [ |- exists u, _ ?v = _ u] => exists v end...
  Qed.
  Lemma redex_trivial : forall r : redex, only_trivial (redex_to_term r).
  Proof with auto.
    intros r t c; generalize dependent t; induction c; simpl in *; auto; intros; right;
    destruct (IHc _ H) as [H0 | [v H0]]; subst; simpl in H; match goal with
    [Hvr : atom_plug ?t ?a = _ ?v |- _] => destruct a; destruct v; inversion Hvr; subst end;
    match goal with [ |- exists u, _ ?v = _ u] => exists v end...
  Qed.
  Lemma value_redex : forall (v : value) (r : redex), value_to_term v <> redex_to_term r.
  Proof with auto.
    destruct v; destruct r; intro H; discriminate H.
  Qed.

  Lemma ot_subt : forall t t0 ec, only_trivial t -> atom_plug t0 ec = t -> exists v, t0 = value_to_term v.
  Proof with auto.
    intros; destruct (H t0 (ec0 :: nil)) as [H1 | [v H1]]...
    discriminate.
    exists v...
  Qed.

  Ltac ot_v t ec :=
  match goal with
  | [Hot : (only_trivial ?H1) |- _] => destruct (ot_subt _ t ec Hot) as [?v HV]; [auto | subst t]
  end.

  Ltac mlr rv :=
  match goal with
  | [ |- (exists v, ?H1 = value_to_term v) \/ (exists r, ?H1 = redex_to_term r)] =>
    match rv with
    | (?v : value) => left; exists v
    | (?r : redex) => right; exists r
    end; simpl; auto
  end.

  Lemma trivial_val_red : forall t : term, only_trivial t ->
    (exists v : value, t = value_to_term v) \/ (exists r : redex, t = redex_to_term r).
  Proof with auto.
    intros; destruct t.
    mlr vZ.
    ot_v t s_c; mlr (vS v).
    ot_v t1 (ap_r t2); ot_v t2 (ap_l v); mlr (rApp v v0).
    mlr (vVar v).
    mlr (vLam v t).
    ot_v t1 (case_c t2 v t3); mlr (rCase v0 t2 v t3).
    ot_v t1 (let_c v t2); mlr (rLet v v0 t2).
    mlr (rFix v t).
    ot_v t1 (pair_r t2); ot_v t2 (pair_l v); mlr (vPair v v0).
    ot_v t fst_c; mlr (rFst v).
    ot_v t snd_c; mlr (rSnd v).
  Qed.

End MiniML.

Module MiniMLRef <: RED_REF_LANG.

  Module R := MiniML.

  Definition dec_term (t : R.term) : R.interm_dec :=
  match t with
  | R.Z              =>  R.in_val R.vZ
  | R.S t            =>  R.in_term t R.s_c
  | R.App t1 t2      =>  R.in_term t1 (R.ap_r t2)
  | R.Var x          =>  R.in_val (R.vVar x)
  | R.Lam x t        =>  R.in_val (R.vLam x t)
  | R.Case t ez x es =>  R.in_term t (R.case_c ez x es)
  | R.Letv x t e     =>  R.in_term t (R.let_c x e)
  | R.Fix x t        =>  R.in_red (R.rFix x t)
  | R.Pair t1 t2     =>  R.in_term t1 (R.pair_r t2)
  | R.Fst t          =>  R.in_term t R.fst_c
  | R.Snd t          =>  R.in_term t R.snd_c
  end.
  Definition dec_context (ec : R.elem_context) (v : R.value) : R.interm_dec :=
  match ec with
  | R.s_c            =>  R.in_val (R.vS v)
  | R.ap_l v0        =>  R.in_red (R.rApp v0 v)
  | R.ap_r t         =>  R.in_term t (R.ap_l v)
  | R.case_c ez x es =>  R.in_red (R.rCase v ez x es)
  | R.let_c x e      =>  R.in_red (R.rLet x v e)
  | R.fst_c          =>  R.in_red (R.rFst v)
  | R.snd_c          =>  R.in_red (R.rSnd v)
  | R.pair_l v0      =>  R.in_val (R.vPair v0 v)
  | R.pair_r t       =>  R.in_term t (R.pair_l v)
  end.

  Inductive subterm_one_step : R.term -> R.term -> Prop :=
  | st_1 : forall t t0 ec (DECT : t = R.atom_plug t0 ec), subterm_one_step t0 t.
  Lemma wf_st1 : well_founded subterm_one_step.
  Proof.
    prove_st_wf.
  Qed.

  Definition subterm_order := clos_trans_n1 R.term subterm_one_step.
  Notation " a <| b " := (subterm_order a b) (at level 40).
  Definition wf_sto : well_founded subterm_order := wf_clos_trans_r _ _ wf_st1.

  Definition ec_order (ec ec0 : R.elem_context) : Prop :=
  match ec, ec0 with
  | R.ap_l _, R.ap_r _ => True
  | R.pair_l _, R.pair_r _ => True
  | _, _ => False
  end.
  Notation " a <: b " := (ec_order a b) (at level 40).
  Lemma wf_eco : well_founded ec_order.
  Proof.
    prove_ec_wf.
  Qed.

  Lemma dec_term_red_empty  : forall t r, dec_term t = R.in_red r -> R.only_empty t.
  Proof with auto.
    intros t r H; destruct t; inversion H; subst; clear H;
    intros t0 c; generalize dependent t0; induction c; intros; simpl in *; auto;
    assert (hh := IHc _ H); subst c; destruct a; inversion H.
  Qed.

  Lemma dec_term_val_empty  : forall t v, dec_term t = R.in_val v -> R.only_empty t.
  Proof.
    intros t r H; destruct t; inversion H; subst; clear H;
    intros t0 c; generalize dependent t0; induction c; intros; simpl in *; auto;
    assert (hh := IHc _ H); subst c; destruct a; inversion H.
  Qed.

  Lemma dec_term_term_top   : forall t t' ec, dec_term t = R.in_term t' ec -> forall ec', ~ec <: ec'.
  Proof.
    intros t t' ec H ec' H0; destruct t; inversion H; subst; destruct ec'; inversion H0.
  Qed.

  Lemma dec_context_red_bot : forall ec v r, dec_context ec v = R.in_red r -> forall ec', ~ ec' <: ec.
  Proof with auto.
    intros ec v r H ec' H0; destruct ec; inversion H; destruct ec'; inversion H0.
  Qed.

  Lemma dec_context_val_bot : forall ec v v', dec_context ec v = R.in_val v' -> forall ec', ~ ec' <: ec.
  Proof.
    intros ec v v' H ec' H0; destruct ec; inversion H; destruct ec'; inversion H0.
  Qed.

  Lemma eco_antirefl : forall ec, ~ec <: ec.
  Proof.
    destruct ec; intro H; destruct H.
  Qed.

  Lemma ec_order_antisym : forall ec ec0, ec <: ec0 -> ~ ec0 <: ec.
  Proof.
    intros ec ec0 H; destruct ec; destruct ec0; inversion H; subst; intro H0; inversion H0.
  Qed.

  Ltac inj_vr := match goal with
  | [Hv : R.value_to_term _ = R.value_to_term _ |- _] => apply R.value_to_term_injective in Hv
  | [Hr : R.redex_to_term _ = R.redex_to_term _ |- _] => apply R.redex_to_term_injective in Hr
  | [ |- _] => idtac
  end.

  Lemma elem_context_det : forall t0 t1 ec0 ec1, ec0 <: ec1 -> R.atom_plug t0 ec0 = R.atom_plug t1 ec1 ->
    exists v, t1 = R.value_to_term v.
  Proof.
    intros; destruct ec0; destruct ec1; inversion H0; inj_vr;
    subst; try (contradiction (eco_antirefl _ H)); match goal with
    | [ |- exists v0, _ ?v = _ v0] => exists v; reflexivity
    | [ H : ( _ <: _) |- _] => inversion H
    end.
  Qed.

  Lemma dec_context_term_next : forall ec v t ec', dec_context ec v = R.in_term t ec' -> ec' <: ec /\ forall ec'', ec'' <: ec -> ~ ec' <: ec''.
  Proof with eauto.
    intros ec v t ec' H; destruct ec; inversion H; subst; split; try constructor; intros ec'' H0 H1; destruct ec''; inversion H0; inversion H1.
  Qed.

  Lemma dec_term_correct : forall t, match dec_term t with
    | R.in_red r => R.redex_to_term r = t
    | R.in_val v => R.value_to_term v = t
    | R.in_term t' ec => R.atom_plug t' ec = t
    end.
  Proof.
    destruct t; simpl; auto.
  Qed.
  Lemma dec_context_correct : forall ec v, match dec_context ec v with
    | R.in_red r => R.redex_to_term r = R.atom_plug (R.value_to_term v) ec
    | R.in_val v' => R.value_to_term v' = R.atom_plug (R.value_to_term v) ec
    | R.in_term t ec' => R.atom_plug t ec' = R.atom_plug (R.value_to_term v) ec
    end.
  Proof.
    destruct ec; simpl; auto.
  Qed.

  Lemma dec_ec_ord : forall t0 t1 ec0 ec1, R.atom_plug t0 ec0 = R.atom_plug t1 ec1 -> ec0 <: ec1 \/ ec1 <: ec0 \/ (t0 = t1 /\ ec0 = ec1).
  Proof with eauto.
    intros t0 t1 ec0 ec1 H; destruct ec0; destruct ec1; inversion H; inj_vr; subst;
    intuition constructor.
  Qed.

End MiniMLRef.

Module MiniML_REF_SEM := RedRefSem MiniMLRef.
Module MiniML_EAM := ProperEAMachine MiniML MiniML_REF_SEM.

Module MiniML_Sem <: RED_SEM MiniML.

  Inductive dec' : MiniML.term -> MiniML.context -> MiniML.decomp -> Prop :=
  | d_z   : forall c d
              (DCTX : decctx MiniML.vZ c d),
              dec' MiniML.Z c d
  | d_s   : forall t c d
              (DEC  : dec' t (MiniML.s_c :: c) d),
              dec' (MiniML.S t) c d
  | d_case: forall t ez x es c d
              (DEC  : dec' t (MiniML.case_c ez x es :: c) d),
              dec' (MiniML.Case t ez x es) c d
  | d_var : forall x c d
              (DCTX : decctx (MiniML.vVar x) c d),
              dec' (MiniML.Var x) c d
  | d_lam : forall x t c d
              (DCTX : decctx (MiniML.vLam x t) c d),
              dec' (MiniML.Lam x t) c d
  | d_app : forall t1 t2 c d
              (DEC  : dec' t1 (MiniML.ap_r t2 :: c) d),
              dec' (MiniML.App t1 t2) c d
  | d_let : forall x t e c d
              (DEC  : dec' t (MiniML.let_c x e :: c) d),
              dec' (MiniML.Letv x t e) c d
  | d_fix : forall x t c,
              dec' (MiniML.Fix x t) c (MiniML.d_red (MiniML.rFix x t) c)
  | d_pair: forall t1 t2 c d
              (DEC  : dec' t1 (MiniML.pair_r t2 :: c) d),
              dec' (MiniML.Pair t1 t2) c d
  | d_fst : forall t c d
              (DEC  : dec' t (MiniML.fst_c :: c) d),
              dec' (MiniML.Fst t) c d
  | d_snd : forall t c d
              (DEC  : dec' t (MiniML.snd_c :: c) d),
              dec' (MiniML.Snd t) c d
  with decctx : MiniML.value -> MiniML.context -> MiniML.decomp -> Prop :=
  | dc_em : forall v,
              decctx v MiniML.empty (MiniML.d_val v)
  | dc_s  : forall v c d
              (DCTX : decctx (MiniML.vS v) c d),
              decctx v (MiniML.s_c :: c) d
  | dc_cs : forall v x ez es c,
              decctx v (MiniML.case_c ez x es :: c) (MiniML.d_red (MiniML.rCase v ez x es) c)
  | dc_apr: forall v t c d
              (DEC  : dec' t (MiniML.ap_l v :: c) d),
              decctx v (MiniML.ap_r t :: c) d
  | dc_apl: forall v v0 c,
              decctx v (MiniML.ap_l v0 :: c) (MiniML.d_red (MiniML.rApp v0 v) c)
  | dc_let: forall v x e c,
              decctx v (MiniML.let_c x e :: c) (MiniML.d_red (MiniML.rLet x v e) c)
  | dc_p_r: forall t v c d
              (DEC  : dec' t (MiniML.pair_l v :: c) d),
              decctx v (MiniML.pair_r t :: c) d
  | dc_p_l: forall v v0 c d
              (DCTX : decctx (MiniML.vPair v0 v) c d),
              decctx v (MiniML.pair_l v0 :: c) d
  | dc_fst: forall v c,
              decctx v (MiniML.fst_c :: c) (MiniML.d_red (MiniML.rFst v) c)
  | dc_snd: forall v c,
              decctx v (MiniML.snd_c :: c) (MiniML.d_red (MiniML.rSnd v) c).
  Definition dec := dec'.
  Scheme dec_Ind := Induction for dec' Sort Prop
  with decctx_Ind := Induction for decctx Sort Prop.

  Lemma dec_val_self : forall v c d, dec (MiniML.value_to_term v) c d <-> decctx v c d.
  Proof with auto.
    induction v;(intros; split; intro H;
    [ inversion H; subst; auto; try rewrite IHv in DEC; try rewrite IHv1 in DEC; inversion DEC; auto; rewrite IHv2 in DEC0; inversion DEC0; subst
    | constructor; auto; try rewrite IHv; try rewrite IHv1; constructor; auto; rewrite IHv2; constructor])...
  Qed.

  (** A redex in context will only ever be reduced to itself *)
  Lemma dec_redex_self : forall (r : MiniML.redex) (c : MiniML.context), dec (MiniML.redex_to_term r) c (MiniML.d_red r c).
  Proof with auto.
    induction r; intros; constructor; rewrite dec_val_self; constructor; rewrite dec_val_self; constructor.
  Qed.

  Lemma decompose : forall t : MiniML.term, (exists v:MiniML.value, t = MiniML.value_to_term v) \/
      (exists r:MiniML.redex, exists c:MiniML.context, MiniML.plug (MiniML.redex_to_term r) c = t).
  Proof with auto with miniml.
    induction t.
    left; exists MiniML.vZ...
    destruct IHt as [[v H] | [r [c H]]]; [left; exists (MiniML.vS v) | right; exists r; exists (c ++ (MiniML.s_c :: nil))];
    subst; simpl; unfold MiniML.plug; auto; apply fold_left_app.
    right; destruct IHt1 as [[v1 H] | [r1 [c1 H]]]; [destruct IHt2 as [[v2 H2] | [r2 [c2 H2]]];
    [exists (MiniML.rApp v1 v2); exists MiniML.empty | exists r2; exists (c2 ++ (MiniML.ap_l v1 :: MiniML.empty))] |
    exists r1; exists (c1 ++ (MiniML.ap_r t2 :: MiniML.empty))]; simpl; subst; auto; unfold MiniML.plug; apply fold_left_app.
    left; exists (MiniML.vVar v)...
    left; exists (MiniML.vLam v t)...
    clear IHt2 IHt3; destruct IHt1 as [[v1 H] | [r [c H]]]; [ right; exists (MiniML.rCase v1 t2 v t3); exists MiniML.empty |
    right; exists r; exists (c ++ (MiniML.case_c t2 v t3 :: MiniML.empty))]; subst; simpl; auto; unfold MiniML.plug; apply fold_left_app.
    clear IHt2; destruct IHt1 as [[v1 H] | [r [c H]]]; [right; exists (MiniML.rLet v v1 t2); exists MiniML.empty | right;
    exists r; exists (c ++ (MiniML.let_c v t2 :: MiniML.empty))]; subst; simpl; auto; unfold MiniML.plug; apply fold_left_app.
    clear IHt; right; exists (MiniML.rFix v t); exists MiniML.empty; simpl; auto.
    destruct IHt1 as [[v1 H1] | [r1 [c1 H1]]]; [destruct IHt2 as [[v2 H2] | [r2 [c2 H2]]]; [left; exists (MiniML.vPair v1 v2) |
    right; exists r2; exists (c2 ++ (MiniML.pair_l v1 :: nil))] | right; exists r1; exists (c1 ++ (MiniML.pair_r t2 :: nil))];
    subst; simpl; auto; unfold MiniML.plug; apply fold_left_app.
    destruct IHt as [[v H] | [r [c H]]]; right; [ exists (MiniML.rFst v); exists MiniML.empty | exists r; exists (c ++ (MiniML.fst_c :: nil)) ];
    subst; simpl; auto; unfold MiniML.plug; apply fold_left_app.
    destruct IHt as [[v H] | [r [c H]]]; right; [ exists (MiniML.rSnd v); exists MiniML.empty | exists r; exists (c ++ (MiniML.snd_c :: nil)) ];
    subst; simpl; auto; unfold MiniML.plug; apply fold_left_app.
  Qed.

  (** dec is left inverse of plug *)
  Lemma dec_correct : forall t c d, dec t c d -> MiniML.decomp_to_term d = MiniML.plug t c.
  Proof.
    induction 1 using dec_Ind with
    (P := fun t c d (H:dec t c d) => MiniML.decomp_to_term d = MiniML.plug t c)
    (P0 := fun v c d (H:decctx v c d) => MiniML.decomp_to_term d = MiniML.plug (MiniML.value_to_term v) c); intros; simpl; auto.
  Qed.

  Lemma dec_plug : forall c c0 t d, dec (MiniML.plug t c) c0 d -> dec t (MiniML.compose c c0) d.
  Proof.
    induction c; simpl; auto; destruct a; intros c0 t0 d DEC; assert (hh := IHc _ _ _ DEC);
    inversion hh; subst; auto; rewrite dec_val_self in DEC0; inversion DEC0; subst; auto.
  Qed.

  Lemma dec_plug_rev : forall c c0 t d, dec t (MiniML.compose c c0) d -> dec (MiniML.plug t c) c0 d.
  Proof.
    induction c; simpl; auto; destruct a; intros; apply IHc;
    repeat (constructor; simpl; auto; try rewrite dec_val_self).
  Qed.

  Inductive decempty : MiniML.term -> MiniML.decomp -> Prop :=
  | d_intro : forall t d (DEC : dec t MiniML.empty d), decempty t d.

  Inductive iter : MiniML.decomp -> MiniML.value -> Prop :=
  | i_val : forall v, iter (MiniML.d_val v) v
  | i_red : forall r t c d v
              (CONTR : MiniML.contract r = Some t)
              (D_EM  : decempty (MiniML.plug t c) d)
              (R_IT  : iter d v),
              iter (MiniML.d_red r c) v.

  Inductive eval : MiniML.term -> MiniML.value -> Prop :=
  | e_intro : forall t d v
                (D_EM : decempty t d)
                (ITER : iter d v),
                eval t v.

End MiniML_Sem.

Lemma dec_sem_ref : forall t c d, MiniML_Sem.dec t c d -> MiniML_REF_SEM.dec t c d.
Proof.
  induction 1 using MiniML_Sem.dec_Ind with
  (P := fun t c d (H : MiniML_Sem.dec t c d) => MiniML_REF_SEM.dec t c d)
  (P0:= fun v c d (H : MiniML_Sem.decctx v c d) => MiniML_REF_SEM.decctx v c d); intros; simpl in *; auto;
  [ econstructor | econstructor 3 | econstructor 3 | econstructor | econstructor 2 | econstructor 3 | econstructor 3
  | econstructor | econstructor 3 | econstructor 3 | econstructor 3 | constructor | econstructor | constructor
  | econstructor 4 | constructor | constructor | econstructor 4 | econstructor | constructor | constructor]; simpl; eauto.
Qed.
Hint Resolve dec_sem_ref.

Lemma dec_ref_sem : forall t c d, MiniML_REF_SEM.dec t c d -> MiniML_Sem.dec t c d.
Proof.
  induction 1 using MiniML_REF_SEM.dec_Ind with
  (P := fun t c d (H : MiniML_REF_SEM.dec t c d) => MiniML_Sem.dec t c d)
  (P0:= fun v c d (H : MiniML_REF_SEM.decctx v c d) => MiniML_Sem.decctx v c d); intros; simpl in *; auto;
  try (constructor; fail);
  try (destruct t; inversion DT; subst; constructor; auto);
  destruct ec; inversion DC; subst; constructor; auto.
Qed.
Hint Resolve dec_ref_sem.

Lemma iter_sem_ref : forall d v, MiniML_Sem.iter d v <-> MiniML_REF_SEM.RS.iter d v.
Proof with eauto with miniml.
destruct d; split; intros H; induction H; subst; simpl in *; auto; try constructor;
inversion_clear D_EM; econstructor 2; simpl in *; eauto; constructor; unfold MiniML_REF_SEM.RS.dec...
Qed.

Lemma eval_sem_ref : forall t v, MiniML_Sem.eval t v <-> MiniML_REF_SEM.RS.eval t v.
Proof with auto.
split; intro H; inversion_clear H; econstructor; inversion_clear D_EM; [ constructor |
rewrite <- iter_sem_ref | constructor | rewrite iter_sem_ref]; unfold MiniML_REF_SEM.RS.dec in *; eauto.
Qed.

Module MiniML_Machine <: ABSTRACT_MACHINE.

Definition term := MiniML.term.
Definition value := MiniML.value.

Definition configuration := MiniML_EAM.configuration.
Definition c_init := MiniML_EAM.c_init.
Definition c_final := MiniML_EAM.c_final.
Definition c_eval := MiniML_EAM.c_eval.
Definition c_apply := MiniML_EAM.c_apply.

Notation " [ a ] " := (c_init a) (at level 60, no associativity).
Notation " [: a :] " := (c_final a) (at level 60).
Notation " [ a , b ] " := (c_eval a b) (at level 60).
Notation " [: a , b :] " := (c_apply a b) (at level 60).

Reserved Notation " a → b " (at level 40).

Inductive trans : configuration -> configuration -> Prop :=
| t_init : forall t,           [ t ] →  [t, MiniML.empty]
| t_final: forall v,           [: MiniML.empty, v :] → [: v :]
| t_ez   : forall c,           [MiniML.Z, c] → [: c, MiniML.vZ :]
| t_es   : forall t c,         [MiniML.S t, c] → [t, MiniML.s_c :: c]
| t_evar : forall x c,         [MiniML.Var x, c] → [: c, MiniML.vVar x :]
| t_elam : forall x t c,       [MiniML.Lam x t, c] → [: c, MiniML.vLam x t :]
| t_eapp : forall t1 t2 c,     [MiniML.App t1 t2, c] → [t1, MiniML.ap_r t2 :: c]
| t_ecas : forall t ez x es c, [MiniML.Case t ez x es, c] → [t, MiniML.case_c ez x es :: c]
| t_efix : forall x t t0 c
             (CTR : MiniML.contract (MiniML.rFix x t) = Some t0),
             [MiniML.Fix x t, c] → [t0, c]
| t_elet : forall x t e c,     [MiniML.Letv x t e, c] → [t, MiniML.let_c x e :: c]
| t_epar : forall t1 t2 c,     [MiniML.Pair t1 t2, c] → [t1, MiniML.pair_r t2 :: c]
| t_efst : forall t c,         [MiniML.Fst t, c] → [t, MiniML.fst_c :: c]
| t_esnd : forall t c,         [MiniML.Snd t, c] → [t, MiniML.snd_c :: c]
| t_as   : forall v c,         [: MiniML.s_c :: c, v :] → [: c, MiniML.vS v :]
| t_aa_r : forall v t c,       [: MiniML.ap_r t :: c, v :] → [t, MiniML.ap_l v :: c]
| t_aa_l : forall v v0 t c
             (CTR : MiniML.contract (MiniML.rApp v0 v) = Some t),
             [: MiniML.ap_l v0 :: c, v :] → [t, c]
| t_acas : forall v ez x es c t
             (CTR : MiniML.contract (MiniML.rCase v ez x es) = Some t),
             [: MiniML.case_c ez x es :: c, v :] → [t, c]
| t_alet : forall v x e c t
             (CTR : MiniML.contract (MiniML.rLet x v e) = Some t),
             [: MiniML.let_c x e :: c, v :] → [t, c]
| t_ap_r : forall v t c,       [: MiniML.pair_r t :: c, v :] → [t, MiniML.pair_l v :: c]
| t_ap_l : forall v v0 c,      [: MiniML.pair_l v0 :: c, v :] → [: c, MiniML.vPair v0 v :]
| t_afst : forall v c t
             (CTR : MiniML.contract (MiniML.rFst v) = Some t),
             [: MiniML.fst_c :: c, v :] → [t, c]
| t_asnd : forall v c t
             (CTR : MiniML.contract (MiniML.rSnd v) = Some t),
             [: MiniML.snd_c :: c, v :] → [t, c]
where " a → b " := (trans a b).
Definition transition := trans.

Notation " a >> b " := (MiniML_EAM.transition a b) (at level 40).
Notation " a >>+ b " := (MiniML_EAM.AM.trans_close a b) (at level 40).

Reserved Notation " a →+ b " (at level 40, no associativity).

Inductive trans_close : configuration -> configuration -> Prop :=
| one_step   : forall c0 c1 (STEP : c0 → c1), c0 →+ c1
| multi_step : forall c0 c1 c2 (STEP : c0 → c1) (REC : c1 →+ c2), c0 →+ c2
where " a →+ b " := (trans_close a b).

Inductive eval : term -> value -> Prop :=
| e_intro : forall t v (TC : [ t ] →+ [: v :]), eval t v.

Lemma trans_eam_mlm : forall c0 c1, c0 >> c1 -> c0 → c1.
Proof with auto.
  intros c0 c1 T; inversion T; subst; match goal with
  | [ DT : MiniML_EAM.dec_term ?t = ?int |- _ ] => destruct t; inversion DT
  | [ DC : MiniML_EAM.dec_context ?ec ?v = ?int |- _ ] => destruct ec; inversion DC
  | [ |- _ ] => idtac
  end; subst; constructor...
Qed.
Hint Resolve trans_eam_mlm.

Lemma tcl_eam_mlm : forall c0 c1, c0 >>+ c1 -> c0 →+ c1.
Proof with eauto.
  intros c0 c1 TC; induction TC; subst; unfold MiniML_EAM.AM.transition in *;
  [econstructor | econstructor 2]...
Qed.

Lemma eval_eam_mlm : forall t v, MiniML_EAM.AM.eval t v -> eval t v.
Proof.
  intros t v E; inversion_clear E; constructor; apply tcl_eam_mlm; auto.
Qed.

Lemma trans_mlm_eam : forall c0 c1, c0 → c1 -> c0 >> c1.
Proof with auto.
  intros w w' H; inversion H; subst; econstructor; simpl...
Qed.
Hint Resolve trans_mlm_eam.

Lemma tcl_mlm_eam : forall c0 c1, c0 →+ c1 -> c0 >>+ c1.
Proof with eauto.
  induction 1; subst; [econstructor | econstructor 2]; unfold MiniML_EAM.AM.transition...
Qed.

Lemma eval_mlm_eam : forall t v, eval t v -> MiniML_EAM.AM.eval t v.
Proof.
  intros t v E; inversion_clear E; constructor; apply tcl_mlm_eam; auto.
Qed.

Theorem MiniML_Machine_correct : forall t v, MiniML_Sem.eval t v <-> eval t v.
Proof.
  intros; rewrite eval_sem_ref; rewrite MiniML_EAM.eval_apply_correct;
  split; [apply eval_eam_mlm | apply eval_mlm_eam].
Qed.

End MiniML_Machine.


Require Export Reals.
Require Import Bool.
Require Import Lra.

Local Open Scope R_scope.

Lemma Rminus_diag_le :
  forall r1 r2, r1 <= r2 -> 0 <= r2 - r1.
Proof.
  intros; lra.
Qed.

Lemma Req_dec (a b : R) : {a = b} + {a <> b}.
Proof.
  case (Rle_dec a b); [intros Hle | intros Hnle; right ; nra].
  case (Rle_dec b a); [intros Hle'; left; nra | intros Hnle; right; nra].
Qed.

Lemma INR_S_n_pos : forall n, 0 < INR (S n).
Proof.
  intros n; rewrite S_INR; apply Rle_lt_0_plus_1.
  apply pos_INR.
Qed.

Lemma INR_inj : forall n m,
    INR n = INR m ->
    n = m.
Proof.
  induction n ; destruct m; intros Heq; try (now inversion Heq);
    [ exfalso; assert (H := INR_S_n_pos m); change (INR 0) with 0 in Heq; lra
    | exfalso; assert (H := INR_S_n_pos n); change (INR 0) with 0 in Heq; lra | ].
  apply eq_S.
  apply IHn.
  rewrite S_O_plus_INR in Heq; change (S m) with (1 + m)%nat in Heq; rewrite (S_O_plus_INR m) in Heq.
  lra.
Qed.

(* Boolean version of Lt for real *)
Definition R_lt_dec (a b : R) : bool.
  case (Rlt_dec a b).
  - intros _; exact true.
  - intros _; exact false.
Defined.

Notation "a <? b" := (R_lt_dec a b) : R_scope.

Inductive R_order (a : R) :=
| R_is_gt : (0 <? a) = true -> R_order a
| R_is_lt : (0 <? - a) = true -> R_order a
| R_is_null : a = 0 -> R_order a.

Lemma R_blt_lt : forall a b, a <? b = true <-> a < b.
Proof.
  intros a b.
  unfold R_lt_dec.
  split; case (Rlt_dec a b); intros Hlt Hblt; try (now inversion Hblt); auto.
Qed.

Lemma R_blt_nlt : forall a b, a <? b = false <-> ~ (a < b).
Proof.
  intros a b.
  unfold R_lt_dec.
  split; case (Rlt_dec a b); intros Hlt Hblt; try (now inversion Hblt); auto.
  exfalso; apply Hblt; apply Hlt.
Qed.

Lemma R_order_dec : forall a, R_order a.
Proof.
  intros a.
  case_eq (0 <? a); [ | case_eq (0 <? - a) ]; intros.
  - apply R_is_gt; assumption.
  - apply R_is_lt; assumption.
  - apply R_is_null.
    apply R_blt_nlt in H; apply R_blt_nlt in H0; lra.
Qed.

Lemma INR_S_n_pos_b : forall n, 0 <? INR (S n) = true.
Proof.
  intros n; apply R_blt_lt; apply INR_S_n_pos.
Qed.

(* Strictly postive real numbers *)
Definition Rpos := {r : R & 0 <? r = true}.

Definition One : Rpos.
split with 1.
apply R_blt_lt; lra.
Defined.

Definition plus_pos (a b : Rpos) : Rpos.
  destruct a as [a Ha]; destruct b as [b Hb].
  split with (a + b).
  rewrite ? R_blt_lt in *; lra.
Defined.

Definition time_pos (a b : Rpos) : Rpos.
  destruct a as [a Ha]; destruct b as [b Hb].
  split with (a * b).
  rewrite ? R_blt_lt in *.
  apply Rmult_lt_0_compat; assumption.
Defined.

Definition minus_pos {a b : Rpos} (Rlt: projT1 b < projT1 a) : Rpos.
  destruct a as [a Ha]; destruct b as [b Hb].
  split with (a - b).
  simpl in Rlt; apply R_blt_lt; nra.
Defined.

Definition inv_pos (a : Rpos) : Rpos.
  destruct a as [a  Ha].
  split with (/ a).
  rewrite R_blt_lt in *.
  now apply Rinv_0_lt_compat.
Defined.

Lemma eq_refl_bool_ext : forall b1 b2 : bool, b1 = b2 -> b1 = b2.
Proof.
intros b1 b2 Heq.
destruct b1 ; destruct b2 ; intros ;
  try (apply eq_refl) ;
  subst ; rewrite Heq ; now apply eq_refl.
Defined.

Lemma Rpos_eq : forall (a b : Rpos),
    projT1 a = projT1 b -> a = b.
Proof.
  intros [a Ha] [b Hb]; simpl; intros Heq.
  revert Ha; rewrite Heq; clear a Heq; intros Hb'.
  assert (forall f, f = eq_refl_bool_ext _ _ Hb) as Heq.
  { destruct f.
    revert Hb.
    destruct (0 <? b) ; reflexivity. }
  rewrite (Heq Hb); now rewrite (Heq Hb').
Qed.

Lemma inv_pos_l : forall a,
    time_pos (inv_pos a) a = One.
Proof.
  destruct a as [a Ha].
  apply Rpos_eq; simpl.
  apply R_blt_lt in Ha.
  apply Rinv_l; intros H; nra.
Qed.

Lemma inv_pos_r : forall a,
    time_pos a (inv_pos a) = One.
Proof.
  destruct a as [a Ha].
  apply Rpos_eq; simpl.
  apply R_blt_lt in Ha.
  apply Rinv_r; intros H; nra.
Qed.

Definition le_pos (a b : Rpos) : Prop.
  destruct a as [a Ha]; destruct b as [b Hb].
  now apply ((a <= b)%R).
Defined.

Definition ble_pos (a b : Rpos) : bool.
  destruct a as [a Ha]; destruct b as [b Hb].
  case (Rle_dec a b); intros _; [ apply true | apply false].
Defined.

(* Natural numbers to Rpos
   INRpos n = (n+1) *)
Definition INRpos (n : nat) : Rpos := existT (fun x => 0 <? x = true) (INR (S n)) (INR_S_n_pos_b n).

(* Properties on strictly positive real numbers *)