(*
 * Module: IC
 *
 * Description:
 *  This module defines the Interrupt Context that is used in the small-step
 *  semantics.
 *)

(* Load Coq Standard Library modules *)
Require Import Arith.
Require Import List.

(*
 * Define the interrupt context.  It is a subset of the configuration and
 * includes the following fields in the following order:
 *
 *  o The machine's register
 *  o The program counter (a virtual address)
 *  o The stack pointer (a virtual address)
 *  o The privilege level
 *)
Inductive InterruptContext : Type :=
  | IC : nat ->
         nat ->
         nat ->
         nat ->
         InterruptContext.

(*
 * Define a stack of Interrupt Contexts.
 *)
Definition ICStack := list InterruptContext.
Definition emptyICStack := nil : list InterruptContext.
Definition itop (ics : ICStack) : InterruptContext := nth 0 ics (IC 0 0 0 0).
Definition push (ic : InterruptContext) (ics : ICStack) := (ic :: ics).
Definition pop  (ics : ICStack) :=
  match ics with
  | nil => nil
  | h :: t => t
end.

(*
 * Function: getICPC
 *
 * Description:
 *  Fetch the program counter value saved within an interrupt context.
 *)
Definition getICPC (ic : InterruptContext) :=
  match ic with
  | IC Reg PC SP Priv => PC
end.


(*
 * Thoughts on definitional equality
 *)

Require Import List Vector.
Require Import Ornamental.Ornaments.

(*
 * The first place we ever encountered definitional equality problems
 * was in lifting proofs about app. Let's give that a try for context.
 *)
Preprocess Module List as List' { opaque (* ignore these: *)
  RelationClasses
  Nat
  Coq.Init.Nat
}.
Set DEVOID lift type.
Lift list Vector.t in List'.Coq_Init_Datatypes_app as appV.

(*
 * Here is the term this generates:
 *)
Definition appV_term (A : Type) (l m : {H : nat & t A H}) : {H : nat & t A H} :=
existT (fun H : nat => t A H)
  (projT1
     (VectorDef.t_rect A
        (fun (n : nat) (_ : VectorDef.t A n) =>
         {H : nat & t A H} -> {H : nat & t A H})
        (fun m0 : {H : nat & t A H} =>
         existT (fun H : nat => t A H) (projT1 m0) (projT2 m0))
        (fun (h : A) (n : nat) (_ : VectorDef.t A n)
           (H : {H : nat & t A H} -> {H : nat & t A H})
           (m0 : {H0 : nat & t A H0}) =>
         existT (fun H0 : nat => VectorDef.t A H0)
           (S
              (projT1
                 (H (existT (fun H0 : nat => t A H0) (projT1 m0) (projT2 m0)))))
           (VectorDef.cons A h
              (projT1
                 (H (existT (fun H0 : nat => t A H0) (projT1 m0) (projT2 m0))))
              (projT2
                 (H (existT (fun H0 : nat => t A H0) (projT1 m0) (projT2 m0))))))
        (projT1 l) (projT2 l)
        (existT (fun H : nat => t A H) (projT1 m) (projT2 m))))
  (projT2
     (VectorDef.t_rect A
        (fun (n : nat) (_ : VectorDef.t A n) =>
         {H : nat & t A H} -> {H : nat & t A H})
        (fun m0 : {H : nat & t A H} =>
         existT (fun H : nat => t A H) (projT1 m0) (projT2 m0))
        (fun (h : A) (n : nat) (_ : VectorDef.t A n)
           (H : {H : nat & t A H} -> {H : nat & t A H})
           (m0 : {H0 : nat & t A H0}) =>
         existT (fun H0 : nat => VectorDef.t A H0)
           (S
              (projT1
                 (H (existT (fun H0 : nat => t A H0) (projT1 m0) (projT2 m0)))))
           (VectorDef.cons A h
              (projT1
                 (H (existT (fun H0 : nat => t A H0) (projT1 m0) (projT2 m0))))
              (projT2
                 (H (existT (fun H0 : nat => t A H0) (projT1 m0) (projT2 m0))))))
        (projT1 l) (projT2 l)
        (existT (fun H : nat => t A H) (projT1 m) (projT2 m)))).

(*
 * Note the explicit eta of packed vectors s to (existT _ (projT1 s) (projT2 s)).
 * There is a reason for this. Consider the alternative term that we get
 * when we disable the identity rule:
 *)
Definition appV_bad (A : Type) (l m : {H : nat & t A H}) : {H : nat & t A H} :=
VectorDef.t_rect A
  (fun (n : nat) (_ : VectorDef.t A n) =>
   {H : nat & t A H} -> {H : nat & t A H}) (fun m0 : {H : nat & t A H} => m0)
  (fun (h : A) (n : nat) (_ : VectorDef.t A n)
     (H : {H : nat & t A H} -> {H : nat & t A H})
     (m0 : {H0 : nat & t A H0}) =>
   existT (fun H0 : nat => VectorDef.t A H0) (S (projT1 (H m0)))
     (VectorDef.cons A h (projT1 (H m0)) (projT2 (H m0))))
  (projT1 l) (projT2 l) m.

(*
 * Indeed, this behaves the same way. But the problem happens when we look at
 * lifting definitional equalities. For example, with the identity rule we can lift
 * app_nil_r without issue:
 *)
Lift list Vector.t in List'.app_nil_r as appV_nil_r { opaque f_equal }.

(*
 * That gives us this term:
 *)
Definition appV_nil_r_term (A : Type) (l : {H : nat & t A H}) : existT (fun H : nat => t A H)
         (projT1
            (appV A (existT (fun H : nat => t A H) (projT1 l) (projT2 l))
               (existT (fun H : nat => t A H) 0 (VectorDef.nil A))))
         (projT2
            (appV A (existT (fun H : nat => t A H) (projT1 l) (projT2 l))
               (existT (fun H : nat => t A H) 0 (VectorDef.nil A)))) =
       existT (fun H : nat => t A H) (projT1 l) (projT2 l) :=
VectorDef.t_rect A
  (fun (n : nat) (t0 : VectorDef.t A n) =>
   existT (fun H : nat => t A H)
     (projT1
        (appV A
           (existT (fun H : nat => t A H) n t0)
           (existT (fun H : nat => t A H) 0 (VectorDef.nil A))))
     (projT2
        (appV A
           (existT (fun H : nat => t A H) n t0)
           (existT (fun H : nat => t A H) 0 (VectorDef.nil A)))) =
   existT (fun H : nat => t A H) n t0) eq_refl
  (fun (h : A) (n : nat) (t0 : VectorDef.t A n)
     (H : existT (fun H : nat => t A H)
            (projT1
               (appV A
                  (existT (fun H : nat => t A H) n t0)
                  (existT (fun H : nat => t A H) 0 (VectorDef.nil A))))
            (projT2
               (appV A
                  (existT (fun H : nat => t A H) n t0)
                  (existT (fun H : nat => t A H) 0 (VectorDef.nil A)))) =
          existT (fun H : nat => t A H) n t0) =>
   eq_ind
     (existT (fun H0 : nat => VectorDef.t A H0)
        (S
           (projT1
              (appV A
                 (existT (fun H0 : nat => t A H0) n t0)
                 (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A)))))
        (VectorDef.cons A h
           (projT1
              (appV A
                 (existT (fun H0 : nat => t A H0) n t0)
                 (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A))))
           (projT2
              (appV A
                 (existT (fun H0 : nat => t A H0) n t0)
                 (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A))))))
     (fun y : {H0 : nat & t A H0} =>
      existT (fun H0 : nat => VectorDef.t A H0)
        (S
           (projT1
              (appV A
                 (existT (fun H0 : nat => t A H0) n t0)
                 (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A)))))
        (VectorDef.cons A h
           (projT1
              (appV A
                 (existT (fun H0 : nat => t A H0) n t0)
                 (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A))))
           (projT2
              (appV A
                 (existT (fun H0 : nat => t A H0) n t0)
                 (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A))))) =
      existT (fun H0 : nat => t A H0) (projT1 y) (projT2 y))
     (eq_ind
        (fun l0 : {H0 : nat & t A H0} =>
         existT (fun H0 : nat => VectorDef.t A H0) (S (projT1 l0))
           (VectorDef.cons A h (projT1 l0) (projT2 l0)))
        (fun y : {H0 : nat & t A H0} -> {H0 : nat & t A H0} =>
         existT (fun H0 : nat => VectorDef.t A H0)
           (S
              (projT1
                 (appV A
                    (existT (fun H0 : nat => t A H0) n t0)
                    (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A)))))
           (VectorDef.cons A h
              (projT1
                 (appV A
                    (existT (fun H0 : nat => t A H0) n t0)
                    (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A))))
              (projT2
                 (appV A
                    (existT (fun H0 : nat => t A H0) n t0)
                    (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A))))) =
         existT (fun H0 : nat => t A H0)
           (projT1
              (y
                 (existT (fun H0 : nat => t A H0)
                    (projT1
                       (appV A
                          (existT (fun H0 : nat => t A H0) n t0)
                          (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A))))
                    (projT2
                       (appV A
                          (existT (fun H0 : nat => t A H0) n t0)
                          (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A)))))))
           (projT2
              (y
                 (existT (fun H0 : nat => t A H0)
                    (projT1
                       (appV A
                          (existT (fun H0 : nat => t A H0) n t0)
                          (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A))))
                    (projT2
                       (appV A
                          (existT (fun H0 : nat => t A H0) n t0)
                          (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A))))))))
        eq_refl
        (fun l0 : {H0 : nat & t A H0} =>
         existT (fun H0 : nat => VectorDef.t A H0) (S (projT1 l0))
           (VectorDef.cons A h (projT1 l0) (projT2 l0))) eq_refl)
     (existT (fun H0 : nat => VectorDef.t A H0)
        (S n)
        (VectorDef.cons A h n t0))
     (eq_ind
        (existT (fun H0 : nat => t A H0)
           (projT1
              (appV A
                 (existT (fun H0 : nat => t A H0) n t0)
                 (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A))))
           (projT2
              (appV A
                 (existT (fun H0 : nat => t A H0) n t0)
                 (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A)))))
        (fun y : {H0 : nat & t A H0} =>
         existT (fun H0 : nat => VectorDef.t A H0)
           (S
              (projT1
                 (appV A
                    (existT (fun H0 : nat => t A H0) n t0)
                    (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A)))))
           (VectorDef.cons A h
              (projT1
                 (appV A
                    (existT (fun H0 : nat => t A H0) n t0)
                    (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A))))
              (projT2
                 (appV A
                    (existT (fun H0 : nat => t A H0) n t0)
                    (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A))))) =
         existT (fun H0 : nat => VectorDef.t A H0) (S (projT1 y))
           (VectorDef.cons A h (projT1 y) (projT2 y))) eq_refl
        (existT (fun H0 : nat => t A H0) n t0) H))
  (projT1 l)
  (projT2 l).

(*
 * In contrast, without identity, we get this:
 *)
Fail Definition appV_nil_r_bad (A : Type) (l : {H : nat & t A H}) : appV_bad A l (existT (fun H : nat => t A H) 0 (VectorDef.nil A)) = l :=
  VectorDef.t_rect A
    (fun (n : nat) (t0 : VectorDef.t A n) =>
     appV_bad A (existT (fun H : nat => VectorDef.t A H) n t0)
       (existT (fun H : nat => t A H) 0 (VectorDef.nil A)) =
     existT (fun H : nat => VectorDef.t A H) n t0) eq_refl
    (fun (h : A) (n : nat) (t0 : VectorDef.t A n)
       (H : appV_bad A (existT (fun H : nat => VectorDef.t A H) n t0)
              (existT (fun H : nat => t A H) 0 (VectorDef.nil A)) =
            existT (fun H : nat => VectorDef.t A H) n t0) =>
     eq_ind
       (existT (fun H0 : nat => VectorDef.t A H0)
          (S
             (projT1
                (appV_bad A (existT (fun H0 : nat => VectorDef.t A H0) n t0)
                   (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A)))))
          (VectorDef.cons A h
             (projT1
                (appV_bad A (existT (fun H0 : nat => VectorDef.t A H0) n t0)
                   (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A))))
             (projT2
                (appV_bad A (existT (fun H0 : nat => VectorDef.t A H0) n t0)
                   (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A))))))
       (fun y : {H0 : nat & t A H0} =>
        existT (fun H0 : nat => VectorDef.t A H0)
          (S
             (projT1
                (appV_bad A (existT (fun H0 : nat => VectorDef.t A H0) n t0)
                   (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A)))))
          (VectorDef.cons A h
             (projT1
                (appV_bad A (existT (fun H0 : nat => VectorDef.t A H0) n t0)
                   (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A))))
             (projT2
                (appV_bad A (existT (fun H0 : nat => VectorDef.t A H0) n t0)
                   (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A))))) =
        y)
       (eq_ind
          (fun l0 : {H0 : nat & t A H0} =>
           existT (fun H0 : nat => VectorDef.t A H0)
             (S (projT1 l0)) (VectorDef.cons A h (projT1 l0) (projT2 l0)))
          (fun y : {H0 : nat & t A H0} -> {H0 : nat & t A H0} =>
           existT (fun H0 : nat => VectorDef.t A H0)
             (S
                (projT1
                   (appV_bad A (existT (fun H0 : nat => VectorDef.t A H0) n t0)
                      (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A)))))
             (VectorDef.cons A h
                (projT1
                   (appV_bad A (existT (fun H0 : nat => VectorDef.t A H0) n t0)
                      (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A))))
                (projT2
                   (appV_bad A (existT (fun H0 : nat => VectorDef.t A H0) n t0)
                      (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A))))) =
           y
             (appV_bad A (existT (fun H0 : nat => VectorDef.t A H0) n t0)
                (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A))))
          eq_refl
          (fun l0 : {H0 : nat & t A H0} =>
           existT (fun H0 : nat => VectorDef.t A H0)
             (S (projT1 l0)) (VectorDef.cons A h (projT1 l0) (projT2 l0)))
          eq_refl)
       (existT (fun H0 : nat => VectorDef.t A H0)
          (S (projT1 (existT (fun H0 : nat => VectorDef.t A H0) n t0)))
          (VectorDef.cons A h
             (projT1 (existT (fun H0 : nat => VectorDef.t A H0) n t0))
             (projT2 (existT (fun H0 : nat => VectorDef.t A H0) n t0))))
       (List'.Coq_Init_Logic_f_equal {H0 : nat & t A H0}
          {H0 : nat & t A H0}
          (fun l0 : {H0 : nat & t A H0} =>
           existT (fun H0 : nat => VectorDef.t A H0)
             (S (projT1 l0)) (VectorDef.cons A h (projT1 l0) (projT2 l0)))
          (appV_bad A (existT (fun H0 : nat => VectorDef.t A H0) n t0)
             (existT (fun H0 : nat => t A H0) 0 (VectorDef.nil A)))
          (existT (fun H0 : nat => VectorDef.t A H0) n t0) H))
    (projT1 l) (projT2 l).

(* Let's break these down to find the error. *)

Definition id_eta {A : Type} (s : { H : nat & t A H }) : { H : nat & t A H} :=
  existT (fun H : nat => t A H) (projT1 s) (projT2 s).

Definition nil {A : Type} :=
  existT (fun H : nat => t A H) 0 (VectorDef.nil A).

Definition cons {A : Type} (a : A) (s : { H : nat & t A H }) : { H : nat & t A H} :=
  existT _
    (S (projT1 s))
    (VectorDef.cons A a (projT1 s) (projT2 s)).

(*
 * That gives us this term:
 *)
Definition appV_nil_r_term_2 (A : Type) (l : {H : nat & t A H}) : id_eta (appV A (id_eta l) nil) = id_eta l :=
VectorDef.t_rect
  A
  (fun (n : nat) (t0 : VectorDef.t A n) =>
     id_eta (appV A (existT _ n t0) nil) = existT _ n t0)
  eq_refl
  (fun (h : A) (n : nat) (t0 : VectorDef.t A n)
       (H : id_eta (appV A (existT _ n t0) nil) = existT _ n t0) =>
   eq_ind
     (cons h (appV A (existT _ n t0) nil))
     (fun y : {H0 : nat & t A H0} =>
        cons h (appV A (existT _ n t0) nil) = id_eta y)
     eq_refl
     (cons h (existT _ n t0))
     (eq_ind
        (id_eta (appV A (existT _ n t0) nil))
        (fun y : {H0 : nat & t A H0} => cons h (appV A (existT _ n t0) nil) = cons h y)
        eq_refl
        (existT _ n t0)
        H))
  (projT1 l)
  (projT2 l).

(*
 * Phew.
 * In contrast, without identity, we get this:
 *)
Fail Definition appV_nil_r_bad_2 (A : Type) (l : {H : nat & t A H}) : appV_bad A l nil = l :=
  VectorDef.t_rect A
    (fun (n : nat) (t0 : VectorDef.t A n) =>
      appV_bad A (existT _ n t0) nil =
      existT _ n t0)
    eq_refl
    (fun (h : A) (n : nat) (t0 : VectorDef.t A n)
         (H : appV_bad A (existT _ n t0) nil = existT _ n t0) =>
     eq_ind
       (cons h (appV_bad A (existT _ n t0) nil))
       (fun y : {H0 : nat & t A H0} =>
         cons h (appV_bad A (existT _ n t0) nil) = y)
       eq_refl
       (cons h (existT _ n t0))
       (eq_ind
         (appV_bad A (existT _ n t0) nil)
         (fun y0 : {H0 : nat & t A H0}  => cons h (appV_bad A (existT _ n t0) nil) = cons h y0)
         eq_refl
         (existT _ n t0)
         H))
    (projT1 l)
    (projT2 l).

(* But the actual type is this: *)
Definition appV_nil_r_bad_2 (A : Type) (l : {H : nat & t A H}) : appV_bad A (id_eta l) nil = id_eta l :=
  VectorDef.t_rect A
    (fun (n : nat) (t0 : VectorDef.t A n) =>
      appV_bad A (existT _ n t0) nil =
      existT _ n t0)
    eq_refl
    (fun (h : A) (n : nat) (t0 : VectorDef.t A n)
         (H : appV_bad A (existT _ n t0) nil = existT _ n t0) =>
     eq_ind
       (cons h (appV_bad A (existT _ n t0) nil))
       (fun y : {H0 : nat & t A H0} =>
         cons h (appV_bad A (existT _ n t0) nil) = y)
       eq_refl
       (cons h (existT _ n t0))
       (eq_ind
         (appV_bad A (existT _ n t0) nil)
         (fun y0 : {H0 : nat & t A H0}  => cons h (appV_bad A (existT _ n t0) nil) = cons h y0)
         eq_refl
         (existT _ n t0)
         H))
    (projT1 l)
    (projT2 l).

(*
 * So in other words, without the id rule, the type of app_nil_r lifts to:
 *
 *   appV_bad A l nil = l
 *
 * but the term of app_nil_r lifts to a term of type:
 *
 *   appV_bad A (id_eta l) nil = id_eta l
 *)

(*
 * Why is this? It has to do with the type of our lifted eliminator:
 *)
Definition vect_dep_elim (A: Type) (P : sigT (Vector.t A) -> Type) pnil (pcons : forall h s, P s -> P (cons h s)) s :=
  Vector.t_rect
    A
    (fun n v => P (existT _ n v))
    pnil
    (fun t n (v : Vector.t A n) (IH : P (existT _ n v)) => pcons t (existT _ n v) IH)
    (projT1 s)
    (projT2 s).

(*
 * So we have (P (projT1 s) (projT2 s)).
 * When our motive is:
 *)
Definition bad_motive (A : Type) (n : nat) (v : Vector.t A n) :=
  appV_bad A (existT _ n v) nil =
  existT _ n v.
(*
 * applied to (projT1 l) (projT2 l), we get:
 *)
Definition bad_motive_app (A : Type) (l : sigT (Vector.t A)) :=
  appV_bad A (existT _ (projT1 l) (projT2 l)) nil =
  existT _ (projT1 l) (projT2 l).

Print VectorDef.t_rect.

(* So: *)

(*
 * P l                     := app A l nil = l
 * Q n v                   := appV A (existT _ n v) nilV = existT _ n v
 * Q (projT1 l) (projT2 l) := appV A (existT _ (projT1 l) (projT2 l)) nilV = existT _ (projT1 l) (projT2 l)
 *)

(*
 * Need that the type (P l) lifts to a type definitionally equal to (Q (projT1 l) (projT2 l)).
 *)

(*
 * We could succeed this way, though:
 *)
Program Definition vect_dep_elim_2 (A : Type)
  (P : sigT (Vector.t A) -> Type)
  (f : P nil)
  (f0 : forall (h : A) (s : sigT (Vector.t A)),
        P s ->
        P (existT _ (S (projT1 s)) (Vector.cons A h (projT1 s) (projT2 s))))
  : forall (s : sigT (Vector.t A)), P s.
Proof.
  intros. induction s. induction p.
  - apply f.
  - specialize (f0 h (existT _ n p)). apply f0. apply IHp.
Defined.

Definition appV_bad_2 (A : Type) (l m : {H : nat & t A H}) : { H : nat & t A H} :=
  vect_dep_elim_2 A
  (fun _ => {H : nat & t A H} -> {H : nat & t A H})
  (fun m0 : {H : nat & t A H} => m0)
  (fun (h : A) _ (H : {H : nat & t A H} -> {H : nat & t A H}) (m0 : {H0 : nat & t A H0}) =>
    cons h (H m0))
  l
  m.

(* But then we get a problem here in a different place, notably since cons doesn't preserve the equality: *)
Fail Definition appV_nil_r_bad_3 (A : Type) (l : {H : nat & t A H}) : appV_bad_2 A l nil = l :=
  vect_dep_elim_2 A
    (fun (s : sigT (Vector.t A)) =>
      appV_bad_2 A s nil = s)
    eq_refl
    (fun (h : A) (s : sigT (Vector.t A))
         (H : appV_bad_2 A s nil = s) =>
     eq_ind
       (cons h (appV_bad_2 A s nil))
       (fun y : {H0 : nat & t A H0} =>
         cons h (appV_bad_2 A s nil) = y)
       eq_refl
       (cons h s)
       (eq_ind
         (appV_bad_2 A s nil)
         (fun y0 : {H0 : nat & t A H0}  => cons h (appV_bad_2 A s nil) = cons h y0)
         eq_refl
         s
         H))
    l.

Definition elim_id (A : Type) (s : {H : nat & t A H}) :=
  vect_dep_elim
    A
    (fun _ => {H : nat & t A H})
    nil
    (fun (h : A) _ IH =>
      cons h IH)
    s.

Definition elim_id_2 (A : Type) (s : {H : nat & t A H}) :=
  vect_dep_elim_2
   A
   (fun _ => {H : nat & t A H})
   nil
   (fun (h : A) _ IH =>
     cons h IH)
   s.

Fail Lemma foo:
  forall A h s,
    exists (H : cons h (elim_id_2 A s) = elim_id_2 A (cons h s)),
      H = eq_refl.

Lemma bar:
  forall A h s,
    exists (H : cons h (elim_id A s) = elim_id A (cons h s)),
      H = eq_refl.
Proof.
  intros. exists (eq_refl (cons h (elim_id A s))). auto.
Defined.

Lemma elim_id_good_1 :
  forall A l (f : forall (l : sigT (Vector.t A)), l = l),
    vect_dep_elim A (fun l => l = l) (f nil) (fun t s _ => f (cons t s)) l = f (id_eta l).
Proof.
  intros A l f. unfold vect_dep_elim. unfold id_eta. induction l. simpl.
  induction p; reflexivity.
Defined.

Lemma elim_id_bad_good_1 :
  forall A l (f : forall (l : sigT (Vector.t A)), l = l),
    vect_dep_elim_2 A (fun l => l = l) (f nil) (fun t s _ => f (cons t s)) l = f l.
Proof.
  intros A l f. unfold vect_dep_elim_2. induction l. simpl.
  induction p; reflexivity.
Defined.

Lemma elim_id_good_2 :
  forall A l (f : forall (l : sigT (Vector.t A)), l = l),
    vect_dep_elim A (fun l => l = l) (f nil) (fun t s _ => f (cons t s)) l = f (id_eta l).
Proof.
  intros A l f. unfold vect_dep_elim. unfold id_eta. induction l. simpl.
  induction p; reflexivity.
Defined.

(* Failed to lift List'.app_nil_end
Failed to lift List'.app_eq_nil
Failed to lift List'.app_eq_unit
Failed to lift List'.app_inj_tail
Failed to lift List'.app_inv_head
Failed to lift List'.app_inv_tail
Failed to lift List'.app_removelast_last
Failed to lift List'.removelast_app*)


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.Eqdep.

Require Export CatSem.PCF_o_c.RPCF_rep_comp.
Require Export CatSem.PCF_o_c.RPCF_rep_id.
Require Export CatSem.PCF_o_c.RPCF_rep_eq.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Obligation Tactic := idtac.

Program Instance REP_s :
     Cat_struct (obj := PCFPO_rep) (PCFPO_rep_Hom) := {
  mor_oid P R := eq_Rep_oid P R ;
  id R := PCFPO_id R ;
  comp a b c f g := Rep_comp f g
}.
Next Obligation.
Proof.
  intros a b c.
  unfold Proper; do 2 red.
  intros M N H.
  induction H.
  simpl in *.
  intros S T H'.
  induction H'.
  simpl in *.

  assert (He : (forall t, tcomp (Rep_comp c0 c1) t =
                          tcomp (Rep_comp a0 a1) t)).
    simpl.
    intro t.
    rewrite H;
    rewrite H1; auto.
  apply (eq_rep (H:=He)).

  destruct c1.
  destruct a1.
  destruct c0.
  destruct a0.

  simpl in *.
  intros V t y.
  assert (K1 : tcomp = tcomp0).
    apply functional_extensionality. auto.
  assert (K2 : tcomp1 = tcomp2).
    apply functional_extensionality. auto.

  generalize dependent He.
  subst.

  intro He.

  assert (Hl := rlift_transp_id).
  assert (Hl':= Hl _ _ _ c He).
  assert (Hll := Hl' _ _
  (RMon_car (f:=tcomp2) (f':=tcomp0)
          rep_Hom_monad2 rep_Hom_monad0 V t y)).

  simpl in *.
  rewrite Hll.
  simpl.

  assert (Hk := transp_id He).
  simpl in Hk.
  rewrite Hk.
  simpl.

  clear Hk Hll Hl' Hl.

  destruct y as [t y].
  simpl in *.
  apply f_equal.

  assert (H0spec := H0 _ _ (ctype _ y)).
  assert (H0r := rlift_transp_id (Q:=b) H
               (rep_Hom_monad2 V (tcomp2 t)
        (ctype (fun t : type_type a => tcomp2 t)
                (V:=a V) (t:=t) y))).
  simpl in *.

  rewrite H0r in H0spec. simpl in *.
  rewrite (UIP_refl _ _ (H t)) in H0spec.
  simpl in *.
  rewrite H0spec.
  simpl.

  clear H0r.
  clear H0spec.
  clear H0.

  assert (H2spec := H2 _ _
  ((ctype (fun t0 : type_type b => tcomp0 t0)
   (V:=b (retype (fun t0 : type_type a => tcomp2 t0) V))
          (t:=tcomp2 t)
     (rep_Hom_monad1 V (tcomp2 t)
        (ctype (fun t0 : type_type a => tcomp2 t0)
   (V:=a V) (t:=t) y))))).
   simpl.

  assert (H2r := rlift_transp_id (Q:=c) H1).
  simpl in H2r.
  rewrite H2r in H2spec.
  simpl in *.
  rewrite H2spec.

  apply f_equal.
  rewrite (UIP_refl _ _ (H1 (tcomp2 t))).
  simpl.
  auto.
Qed.

Next Obligation.
Proof.
  simpl.
  intros a b f.
  assert (H : forall t, tcomp f t =
    tcomp (Rep_comp f (PCFPO_id b)) t)
    by (simpl; auto).

  apply (eq_rep (H:=H)); simpl.

  intros V t y.
  destruct y as [t y].
  simpl.

  destruct f.
  simpl in *.

  rewrite (UIP_refl _ _ (H t)).
  simpl.

  assert (HH:=rlift_transp_id (Q:=b) H).
  simpl in *.
  rewrite HH.
  simpl.

  assert (Hl := rlift_rlift b).
  simpl in Hl.
  rewrite Hl.
  simpl.
  assert (He := rlift_eq_id b).
  simpl in He.
  apply He.

  clear t y.
  intros t y.
  destruct y as [t y];
  simpl; auto.
Qed.
Next Obligation.
  simpl.
  intros a b f.
  assert (H : forall t, tcomp f t =
    tcomp (Rep_comp (PCFPO_id a) f) t)
    by (simpl; auto).

  apply (eq_rep (H:=H)); simpl.

  intros V t y.
  destruct y as [t y].
  simpl.

  destruct f.
  simpl in *.

  rewrite (UIP_refl _ _ (H t)).
  simpl.

  assert (HH:=rlift_transp_id (Q:=b) H).
  simpl in *.
  rewrite HH.
  simpl.

  assert (H3:=gen_rh_rlift rep_Hom_monad).
  simpl in *.
  assert (H4 :=H3 _ _ (id_retype(V:=V))).
  simpl in H4.
  rewrite <- H4.
  clear H4.

  assert (Hl := rlift_rlift b).
  simpl in Hl.
  rewrite Hl.
  simpl.
  assert (He := rlift_eq_id b).
  simpl in He.
  apply He.

  clear t y.
  intros t y.
  destruct y as [t y];
  simpl; auto.
Qed.
Next Obligation.
Proof.
  intros a b c c' f g h.
  assert (H : forall t,
    tcomp (Rep_comp f (Rep_comp g h)) t =
    tcomp (Rep_comp (Rep_comp f g) h) t) by
          (simpl; auto).
  apply (eq_rep (H:=H)).
  simpl.
  intros V t y.
  destruct h.
  destruct g.
  destruct f.
  simpl in *.

  assert (Hl:=rlift_transp_id (Q:=c') H).
  simpl in Hl.
  rewrite Hl.

  assert (Ht := transp_id H).
  simpl in Ht.
  rewrite Ht.

  destruct y as [t y].
  simpl in *.

  assert (Hc' := rlift_rlift c').
  simpl in Hc'.
  rewrite Hc'.

  assert (H3:=gen_rh_rlift rep_Hom_monad).
  rewrite <- (H3 _ _ (double_retype_1 (f:=tcomp1)
                             (f':=tcomp0)(V:= V))).

  rewrite Hc'.

  apply (rlift_eq c').
  simpl.

  clear t y.
  intros t y.
  destruct y as [t y].
  simpl.
  destruct y as [t y].
  simpl.
  destruct y as [t y].
  simpl;
  auto.
Qed.

Canonical Structure REP : Cat := Build_Cat REP_s.


(*|
#####################################################
Multiple successes in Coq branching and backtracking?
#####################################################

:Link: https://stackoverflow.com/q/38256705
|*)

(*|
Question
********

I am having trouble understanding the concept of ``multiple
successes`` in Coq's (8.5p1, ch9.2) branching and backtracking
behavior. For example, from the documentation:

    **Backtracking branching**

    We can branch with the following structure:

    .. code-block::

        expr1 + expr2

    Tactics can be seen as having several successes. When a tactic
    fails it asks for more successes of the prior tactics. ``expr1 +
    expr2`` has all the successes of ``v1`` followed by all the
    successes of ``v2``.

What I don't understand, is why do we need multiple successes in the
first place? Isn't one success good enough to finish a proof?

Also from the documentation, it seems that there are less costly
branching rules that are somehow "biased", including

.. code-block:: coq

    first [ expr1 | ::: | exprn ]

and

.. code-block:: coq

    expr1 || expr2

Why do we need the more costly option ``+`` and not always use the
latter, more efficient tacticals?
|*)

(*|
Answer
******

The problem is that you are sometimes trying to discharge a goal but
further subgoals might lead to a solution you thought would work to be
rejected. If you accumulate all the successes then you can backtrack
to wherever you made a wrong choice and explore another branch of the
search tree.

Here is a silly example. let's say I want to prove this goal:
|*)

Goal exists m, m = 1.
Abort. (* .none *)

(*|
Now, it's a fairly simple goal so I could do it manually but let's
not. Let's write a tactic that, when confronted with an ``exists``,
tries all the possible natural numbers. If I write:
|*)

Ltac existNatFrom n :=
  exists n || existNatFrom (S n).

Ltac existNat := existNatFrom O.

(*|
then as soon as I have run ``existNat``, the system commits to the
first successful choice. In particular this means that despite the
recursive definition of ``existNatFrom``, when calling ``existNat``
I'll always get ``O`` and only ``O``.

The goal cannot be solved:
|*)

Goal exists m, m = 1.
  Fail (existNat; reflexivity).
Abort.

(*|
On the other hand, if I use ``(+)`` instead of ``(||)``, I'll go
through all possible natural numbers (in a lazy manner, by using
backtracking). So writing:
|*)

Ltac existNatFrom' n :=
  exists n + existNatFrom' (S n).

Ltac existNat' := existNatFrom' O.

(*| means that I can now prove the goal: |*)

Goal exists m, m = 1.
  existNat'; reflexivity.
Qed.


From Hammer Require Import Hammer.

Require Export Ascii.
Require Export String.
Require Export List.
Require Export Relation_Definitions.

Definition bool_eq (a a':bool) : Prop := a = a'.

Lemma bool_eq_equiv : equiv bool bool_eq.
Proof. hammer_hook "Utility" "Utility.bool_eq_equiv".
unfold equiv. split.
unfold reflexive. intro. unfold bool_eq. auto. split.
unfold transitive. intros. unfold bool_eq in *. transitivity y; auto.
unfold symmetric. intros. unfold bool_eq in *. auto.
Qed.

Definition ascii_eq (a a':ascii) : Prop := a = a'.
Lemma ascii_eq_equiv : equiv ascii ascii_eq.
Proof. hammer_hook "Utility" "Utility.ascii_eq_equiv".
unfold equiv. split.
unfold reflexive. intros. unfold ascii_eq. auto. split.
unfold transitive. intros. unfold ascii_eq in *. transitivity y; auto.
unfold symmetric. intros. unfold ascii_eq in *. auto.
Qed.

Definition string_eq (a a':string) : Prop := a = a'.
Lemma string_eq_equiv : equiv string string_eq.
Proof. hammer_hook "Utility" "Utility.string_eq_equiv".
unfold equiv. split.
unfold reflexive. intros. unfold string_eq. auto. split.
unfold transitive. intros. unfold string_eq in *. transitivity y; auto.
unfold symmetric. intros. unfold string_eq in *. auto.
Qed.

Lemma string_assoc : forall s s' s'':string,
((s ++ s') ++ s'')%string = (s ++ (s' ++ s''))%string.
Proof. hammer_hook "Utility" "Utility.string_assoc".
induction s; simpl.
auto.
intros s' s''. erewrite IHs. auto.
Qed.

Fixpoint str_length (s:string) : nat :=
match s with
| ""%string => O
| String _ s' => S (str_length s')
end.

Lemma str_length_append : forall s s',
str_length (s ++ s')%string = str_length s + str_length s'.
Proof. hammer_hook "Utility" "Utility.str_length_append".
induction s.
simpl.  reflexivity.
simpl.  intros. erewrite IHs.  reflexivity.
Qed.

Lemma string_right_id : forall s, (s ++ "")%string = s.
Proof. hammer_hook "Utility" "Utility.string_right_id".
induction s.
auto.
simpl.  erewrite IHs.  auto.
Qed.

Definition bneq_empty_string(s:string):bool :=
match (string_dec s ""%string) with
| left _ => false
| right _ => true
end.

Definition concat_list_string(xs:list string) :=
fold_right (fun s s' : string => (s ++ s')%string) ""%string xs.

Lemma concat_list_string_x_xs : forall (x:string)(xs:list string),
concat_list_string (x :: xs) = (x ++ (concat_list_string xs))%string.
Proof. hammer_hook "Utility" "Utility.concat_list_string_x_xs".
induction xs; auto.
Qed.

Lemma concat_list_string_xs_x : forall (xs:list string)(x:string),
concat_list_string (xs ++ x::nil) = ((concat_list_string xs) ++ x)%string.
Proof. hammer_hook "Utility" "Utility.concat_list_string_xs_x".
induction xs; simpl; intro x.
erewrite string_right_id.  auto.
erewrite IHxs.  erewrite string_assoc.  auto.
Qed.

Lemma In_list_append_left : forall A (a:A) l l', In a l -> In a (l ++ l')%list.
Proof. hammer_hook "Utility" "Utility.In_list_append_left".
induction l; simpl.
intros l' H.  elim H.
intros l' H.  destruct H as [H1 | H2].
left; auto.
right; eapply IHl; auto.
Qed.

Lemma In_list_append_right : forall A (a:A) l l', In a l' -> In a (l ++ l')%list.
Proof. hammer_hook "Utility" "Utility.In_list_append_right".
induction l; simpl.
intros l' H.  auto.
intros l' H.  right.  eapply IHl.  auto.
Qed.

Lemma In_snoc : forall A (a:A) l, In a (l ++ a::nil)%list.
Proof. hammer_hook "Utility" "Utility.In_snoc".
induction l; simpl.
left; auto.
right; auto.
Qed.

Lemma forallb_divide_left : forall (A:Type)(f:A -> bool) (l l':list A),
forallb f (l ++ l') = true -> forallb f l = true.
Proof. hammer_hook "Utility" "Utility.forallb_divide_left".
intros A f l l' H.  erewrite forallb_app in H.
destruct(forallb f l).
auto.
destruct(forallb f l'); simpl in H; discriminate H.
Qed.

Lemma forallb_divide_right : forall (A:Type)(f:A -> bool) (l l':list A),
forallb f (l ++ l') = true -> forallb f l' = true.
Proof. hammer_hook "Utility" "Utility.forallb_divide_right".
intros A f l l' H.  erewrite forallb_app in H.
destruct(forallb f l').
reflexivity.
destruct(forallb f l); simpl in H; discriminate H.
Qed.

Lemma forallb_list_x_xs : forall A (f:A -> bool)(x:A)(xs:list A),
f x = true -> forallb f xs = true -> forallb f (x::xs) = true.
Proof. hammer_hook "Utility" "Utility.forallb_list_x_xs".
intros A f x xs Hx Hxs.
replace (x :: xs) with ((x :: nil) ++ xs).
erewrite forallb_app.  simpl.  rewrite Hx; rewrite Hxs.  auto.
simpl.  auto.
Qed.

Lemma forallb_list_xs_x : forall A (f:A -> bool)(xs:list A)(x:A),
forallb f xs = true -> f x = true -> forallb f (xs ++ x::nil)%list = true.
Proof. hammer_hook "Utility" "Utility.forallb_list_xs_x".
intros A f xs x Hxs Hx.
erewrite forallb_app.  simpl.  rewrite Hx; rewrite Hxs.  auto.
Qed.


Require Import CoqPerformanceTests.typeclass_reification_common.
Time Definition foo110 : goal 110. Time solve_P. Time Qed.


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

(*i $Id: DecBool.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Set Implicit Arguments.

Definition ifdec (A B:Prop) (C:Type) (H:{A} + {B}) (x y:C) : C :=
  if H then x else y.

Theorem ifdec_left :
  forall (A B:Prop) (C:Set) (H:{A} + {B}),
    ~ B -> forall x y:C, ifdec H x y = x.
Proof.
  intros; case H; auto.
  intro; absurd B; trivial.
Qed.

Theorem ifdec_right :
  forall (A B:Prop) (C:Set) (H:{A} + {B}),
    ~ A -> forall x y:C, ifdec H x y = y.
Proof.
  intros; case H; auto.
  intro; absurd A; trivial.
Qed.

Unset Implicit Arguments.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2018 Sylvie Boldo
#<br />#
Copyright (C) 2010-2018 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Locations: where a real number is positioned with respect to its rounded-down value in an arbitrary format. *)

Require Import Raux Defs Float_prop.

Section Fcalc_bracket.

Variable d u : R.
Hypothesis Hdu : (d < u)%R.

Inductive location := loc_Exact | loc_Inexact : comparison -> location.

Variable x : R.

Definition inbetween_loc :=
  match Rcompare x d with
  | Gt => loc_Inexact (Rcompare x ((d + u) / 2))
  | _ => loc_Exact
  end.

(** Locates a real number with respect to the middle of two other numbers. *)

Inductive inbetween : location -> Prop :=
  | inbetween_Exact : x = d -> inbetween loc_Exact
  | inbetween_Inexact l : (d < x < u)%R -> Rcompare x ((d + u) / 2)%R = l -> inbetween (loc_Inexact l).

Theorem inbetween_spec :
  (d <= x < u)%R -> inbetween inbetween_loc.
Proof.
intros Hx.
unfold inbetween_loc.
destruct (Rcompare_spec x d) as [H|H|H].
now elim Rle_not_lt with (1 := proj1 Hx).
now constructor.
constructor.
now split.
easy.
Qed.

Theorem inbetween_unique :
  forall l l',
  inbetween l -> inbetween l' -> l = l'.
Proof.
intros l l' Hl Hl'.
inversion_clear Hl ; inversion_clear Hl'.
apply refl_equal.
rewrite H in H0.
elim Rlt_irrefl with (1 := proj1 H0).
rewrite H1 in H.
elim Rlt_irrefl with (1 := proj1 H).
apply f_equal.
now rewrite <- H0.
Qed.

Section Fcalc_bracket_any.

Variable l : location.

Theorem inbetween_bounds :
  inbetween l ->
  (d <= x < u)%R.
Proof.
intros [Hx|l' Hx Hl] ; clear l.
rewrite Hx.
split.
apply Rle_refl.
exact Hdu.
now split ; try apply Rlt_le.
Qed.

Theorem inbetween_bounds_not_Eq :
  inbetween l ->
  l <> loc_Exact ->
  (d < x < u)%R.
Proof.
intros [Hx|l' Hx Hl] H.
now elim H.
exact Hx.
Qed.

End Fcalc_bracket_any.

Theorem inbetween_distance_inexact :
  forall l,
  inbetween (loc_Inexact l) ->
  Rcompare (x - d) (u - x) = l.
Proof.
intros l Hl.
inversion_clear Hl as [|l' Hl' Hx].
now rewrite Rcompare_middle.
Qed.

Theorem inbetween_distance_inexact_abs :
  forall l,
  inbetween (loc_Inexact l) ->
  Rcompare (Rabs (d - x)) (Rabs (u - x)) = l.
Proof.
intros l Hl.
rewrite Rabs_left1.
rewrite Rabs_pos_eq.
rewrite Ropp_minus_distr.
now apply inbetween_distance_inexact.
apply Rle_0_minus.
apply Rlt_le.
apply (inbetween_bounds _ Hl).
apply Rle_minus.
apply (inbetween_bounds _ Hl).
Qed.

End Fcalc_bracket.

Theorem inbetween_ex :
  forall d u l,
  (d < u)%R ->
  exists x,
  inbetween d u x l.
Proof.
intros d u [|l] Hdu.
exists d.
now constructor.
exists (d + match l with Lt => 1 | Eq => 2 | Gt => 3 end / 4 * (u - d))%R.
constructor.
(* *)
set (v := (match l with Lt => 1 | Eq => 2 | Gt => 3 end / 4)%R).
assert (0 < v < 1)%R.
split.
unfold v, Rdiv.
apply Rmult_lt_0_compat.
case l ; now apply IZR_lt.
apply Rinv_0_lt_compat.
now apply IZR_lt.
unfold v, Rdiv.
apply Rmult_lt_reg_r with 4%R.
now apply IZR_lt.
rewrite Rmult_assoc, Rinv_l.
rewrite Rmult_1_r, Rmult_1_l.
case l ; now apply IZR_lt.
apply Rgt_not_eq.
now apply IZR_lt.
split.
apply Rplus_lt_reg_r with (d * (v - 1))%R.
ring_simplify.
rewrite Rmult_comm.
now apply Rmult_lt_compat_l.
apply Rplus_lt_reg_l with (-u * v)%R.
replace (- u * v + (d + v * (u - d)))%R with (d * (1 - v))%R by ring.
replace (- u * v + u)%R with (u * (1 - v))%R by ring.
apply Rmult_lt_compat_r.
apply Rplus_lt_reg_r with v.
now ring_simplify.
exact Hdu.
(* *)
set (v := (match l with Lt => 1 | Eq => 2 | Gt => 3 end)%R).
rewrite <- (Rcompare_plus_r (- (d + u) / 2)).
rewrite <- (Rcompare_mult_r 4).
2: now apply IZR_lt.
replace (((d + u) / 2 + - (d + u) / 2) * 4)%R with ((u - d) * 0)%R by field.
replace ((d + v / 4 * (u - d) + - (d + u) / 2) * 4)%R with ((u - d) * (v - 2))%R by field.
rewrite Rcompare_mult_l.
2: now apply Rlt_Rminus.
rewrite <- (Rcompare_plus_r 2).
ring_simplify (v - 2 + 2)%R (0 + 2)%R.
unfold v.
case l ; apply Rcompare_IZR.
Qed.

Section Fcalc_bracket_step.

Variable start step : R.
Variable nb_steps : Z.
Variable Hstep : (0 < step)%R.

Lemma ordered_steps :
  forall k,
  (start + IZR k * step < start + IZR (k + 1) * step)%R.
Proof.
intros k.
apply Rplus_lt_compat_l.
apply Rmult_lt_compat_r.
exact Hstep.
apply IZR_lt.
apply Zlt_succ.
Qed.

Lemma middle_range :
  forall k,
  ((start + (start + IZR k * step)) / 2 = start + (IZR k / 2 * step))%R.
Proof.
intros k.
field.
Qed.

Hypothesis (Hnb_steps : (1 < nb_steps)%Z).

Lemma inbetween_step_not_Eq :
  forall x k l l',
  inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l ->
  (0 < k < nb_steps)%Z ->
  Rcompare x (start + (IZR nb_steps / 2 * step))%R = l' ->
  inbetween start (start + IZR nb_steps * step) x (loc_Inexact l').
Proof.
intros x k l l' Hx Hk Hl'.
constructor.
(* . *)
assert (Hx' := inbetween_bounds _ _ (ordered_steps _) _ _ Hx).
split.
apply Rlt_le_trans with (2 := proj1 Hx').
rewrite <- (Rplus_0_r start) at 1.
apply Rplus_lt_compat_l.
apply Rmult_lt_0_compat.
now apply IZR_lt.
exact Hstep.
apply Rlt_le_trans with (1 := proj2 Hx').
apply Rplus_le_compat_l.
apply Rmult_le_compat_r.
now apply Rlt_le.
apply IZR_le.
omega.
(* . *)
now rewrite middle_range.
Qed.

Theorem inbetween_step_Lo :
  forall x k l,
  inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l ->
  (0 < k)%Z -> (2 * k + 1 < nb_steps)%Z ->
  inbetween start (start + IZR nb_steps * step) x (loc_Inexact Lt).
Proof.
intros x k l Hx Hk1 Hk2.
apply inbetween_step_not_Eq with (1 := Hx).
omega.
apply Rcompare_Lt.
assert (Hx' := inbetween_bounds _ _ (ordered_steps _) _ _ Hx).
apply Rlt_le_trans with (1 := proj2 Hx').
apply Rcompare_not_Lt_inv.
rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_l.
apply Rcompare_not_Lt.
rewrite <- mult_IZR.
apply IZR_le.
omega.
exact Hstep.
Qed.

Theorem inbetween_step_Hi :
  forall x k l,
  inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l ->
  (nb_steps < 2 * k)%Z -> (k < nb_steps)%Z ->
  inbetween start (start + IZR nb_steps * step) x (loc_Inexact Gt).
Proof.
intros x k l Hx Hk1 Hk2.
apply inbetween_step_not_Eq with (1 := Hx).
omega.
apply Rcompare_Gt.
assert (Hx' := inbetween_bounds _ _ (ordered_steps _) _ _ Hx).
apply Rlt_le_trans with (2 := proj1 Hx').
apply Rcompare_Lt_inv.
rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_l.
apply Rcompare_Lt.
rewrite <- mult_IZR.
apply IZR_lt.
omega.
exact Hstep.
Qed.

Theorem inbetween_step_Lo_not_Eq :
  forall x l,
  inbetween start (start + step) x l ->
  l <> loc_Exact ->
  inbetween start (start + IZR nb_steps * step) x (loc_Inexact Lt).
Proof.
intros x l Hx Hl.
assert (Hx' := inbetween_bounds_not_Eq _ _ _ _ Hx Hl).
constructor.
(* . *)
split.
apply Hx'.
apply Rlt_trans with (1 := proj2 Hx').
apply Rplus_lt_compat_l.
rewrite <- (Rmult_1_l step) at 1.
apply Rmult_lt_compat_r.
exact Hstep.
now apply IZR_lt.
(* . *)
apply Rcompare_Lt.
apply Rlt_le_trans with (1 := proj2 Hx').
rewrite middle_range.
apply Rcompare_not_Lt_inv.
rewrite <- (Rmult_1_l step) at 2.
rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_l.
rewrite Rmult_1_r.
apply Rcompare_not_Lt.
apply IZR_le.
now apply (Zlt_le_succ 1).
exact Hstep.
Qed.

Lemma middle_odd :
  forall k,
  (2 * k + 1 = nb_steps)%Z ->
  (((start + IZR k * step) + (start + IZR (k + 1) * step))/2 = start + IZR nb_steps /2 * step)%R.
Proof.
intros k Hk.
rewrite <- Hk.
rewrite 2!plus_IZR, mult_IZR.
simpl. field.
Qed.

Theorem inbetween_step_any_Mi_odd :
  forall x k l,
  inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x (loc_Inexact l) ->
  (2 * k + 1 = nb_steps)%Z ->
  inbetween start (start + IZR nb_steps * step) x (loc_Inexact l).
Proof.
intros x k l Hx Hk.
apply inbetween_step_not_Eq with (1 := Hx).
omega.
inversion_clear Hx as [|l' _ Hl].
now rewrite (middle_odd _ Hk) in Hl.
Qed.

Theorem inbetween_step_Lo_Mi_Eq_odd :
  forall x k,
  inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x loc_Exact ->
  (2 * k + 1 = nb_steps)%Z ->
  inbetween start (start + IZR nb_steps * step) x (loc_Inexact Lt).
Proof.
intros x k Hx Hk.
apply inbetween_step_not_Eq with (1 := Hx).
omega.
inversion_clear Hx as [Hl|].
rewrite Hl.
rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_r.
apply Rcompare_Lt.
rewrite <- mult_IZR.
apply IZR_lt.
rewrite <- Hk.
apply Zlt_succ.
exact Hstep.
Qed.

Theorem inbetween_step_Hi_Mi_even :
  forall x k l,
  inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l ->
  l <> loc_Exact ->
  (2 * k = nb_steps)%Z ->
  inbetween start (start + IZR nb_steps * step) x (loc_Inexact Gt).
Proof.
intros x k l Hx Hl Hk.
apply inbetween_step_not_Eq with (1 := Hx).
omega.
apply Rcompare_Gt.
assert (Hx' := inbetween_bounds_not_Eq _ _ _ _ Hx Hl).
apply Rle_lt_trans with (2 := proj1 Hx').
apply Rcompare_not_Lt_inv.
rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_r.
rewrite <- mult_IZR.
apply Rcompare_not_Lt.
apply IZR_le.
rewrite Hk.
apply Z.le_refl.
exact Hstep.
Qed.

Theorem inbetween_step_Mi_Mi_even :
  forall x k,
  inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x loc_Exact ->
  (2 * k = nb_steps)%Z ->
  inbetween start (start + IZR nb_steps * step) x (loc_Inexact Eq).
Proof.
intros x k Hx Hk.
apply inbetween_step_not_Eq with (1 := Hx).
omega.
apply Rcompare_Eq.
inversion_clear Hx as [Hx'|].
rewrite Hx', <- Hk, mult_IZR.
field.
Qed.

(** Computes a new location when the interval containing a real
    number is split into nb_steps subintervals and the real is
    in the k-th one. (Even radix.) *)

Definition new_location_even k l :=
  if Zeq_bool k 0 then
    match l with loc_Exact => l | _ => loc_Inexact Lt end
  else
    loc_Inexact
    match Z.compare (2 * k) nb_steps with
    | Lt => Lt
    | Eq => match l with loc_Exact => Eq | _ => Gt end
    | Gt => Gt
    end.

Theorem new_location_even_correct :
  Z.even nb_steps = true ->
  forall x k l, (0 <= k < nb_steps)%Z ->
  inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l ->
  inbetween start (start + IZR nb_steps * step) x (new_location_even k l).
Proof.
intros He x k l Hk Hx.
unfold new_location_even.
destruct (Zeq_bool_spec k 0) as [Hk0|Hk0].
(* k = 0 *)
rewrite Hk0 in Hx.
rewrite Rmult_0_l, Rplus_0_r, Rmult_1_l in Hx.
set (l' := match l with loc_Exact => l | _ => loc_Inexact Lt end).
assert ((l = loc_Exact /\ l' = loc_Exact) \/ (l <> loc_Exact /\ l' = loc_Inexact Lt)).
unfold l' ; case l ; try (now left) ; right ; now split.
destruct H as [(H1,H2)|(H1,H2)] ; rewrite H2.
constructor.
rewrite H1 in Hx.
now inversion_clear Hx.
now apply inbetween_step_Lo_not_Eq with (2 := H1).
(* k <> 0 *)
destruct (Zcompare_spec (2 * k) nb_steps) as [Hk1|Hk1|Hk1].
(* . 2 * k < nb_steps *)
apply inbetween_step_Lo with (1 := Hx).
omega.
destruct (Zeven_ex nb_steps).
rewrite He in H.
omega.
(* . 2 * k = nb_steps *)
set (l' := match l with loc_Exact => Eq | _ => Gt end).
assert ((l = loc_Exact /\ l' = Eq) \/ (l <> loc_Exact /\ l' = Gt)).
unfold l' ; case l ; try (now left) ; right ; now split.
destruct H as [(H1,H2)|(H1,H2)] ; rewrite H2.
rewrite H1 in Hx.
now apply inbetween_step_Mi_Mi_even with (1 := Hx).
now apply inbetween_step_Hi_Mi_even with (1 := Hx).
(* . 2 * k > nb_steps *)
apply inbetween_step_Hi with (1 := Hx).
exact Hk1.
apply Hk.
Qed.

(** Computes a new location when the interval containing a real
    number is split into nb_steps subintervals and the real is
    in the k-th one. (Odd radix.) *)

Definition new_location_odd k l :=
  if Zeq_bool k 0 then
    match l with loc_Exact => l | _ => loc_Inexact Lt end
  else
    loc_Inexact
    match Z.compare (2 * k + 1) nb_steps with
    | Lt => Lt
    | Eq => match l with loc_Inexact l => l | loc_Exact => Lt end
    | Gt => Gt
    end.

Theorem new_location_odd_correct :
  Z.even nb_steps = false ->
  forall x k l, (0 <= k < nb_steps)%Z ->
  inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l ->
  inbetween start (start + IZR nb_steps * step) x (new_location_odd k l).
Proof.
intros Ho x k l Hk Hx.
unfold new_location_odd.
destruct (Zeq_bool_spec k 0) as [Hk0|Hk0].
(* k = 0 *)
rewrite Hk0 in Hx.
rewrite Rmult_0_l, Rplus_0_r, Rmult_1_l in Hx.
set (l' := match l with loc_Exact => l | _ => loc_Inexact Lt end).
assert ((l = loc_Exact /\ l' = loc_Exact) \/ (l <> loc_Exact /\ l' = loc_Inexact Lt)).
unfold l' ; case l ; try (now left) ; right ; now split.
destruct H as [(H1,H2)|(H1,H2)] ; rewrite H2.
constructor.
rewrite H1 in Hx.
now inversion_clear Hx.
now apply inbetween_step_Lo_not_Eq with (2 := H1).
(* k <> 0 *)
destruct (Zcompare_spec (2 * k + 1) nb_steps) as [Hk1|Hk1|Hk1].
(* . 2 * k + 1 < nb_steps *)
apply inbetween_step_Lo with (1 := Hx) (3 := Hk1).
omega.
(* . 2 * k + 1 = nb_steps *)
destruct l.
apply inbetween_step_Lo_Mi_Eq_odd with (1 := Hx) (2 := Hk1).
apply inbetween_step_any_Mi_odd with (1 := Hx) (2 := Hk1).
(* . 2 * k + 1 > nb_steps *)
apply inbetween_step_Hi with (1 := Hx).
destruct (Zeven_ex nb_steps).
rewrite Ho in H.
omega.
apply Hk.
Qed.

Definition new_location :=
  if Z.even nb_steps then new_location_even else new_location_odd.

Theorem new_location_correct :
  forall x k l, (0 <= k < nb_steps)%Z ->
  inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l ->
  inbetween start (start + IZR nb_steps * step) x (new_location k l).
Proof.
intros x k l Hk Hx.
unfold new_location.
generalize (refl_equal nb_steps) (Z.le_lt_trans _ _ _ (proj1 Hk) (proj2 Hk)).
pattern nb_steps at 2 3 5 ; case nb_steps.
now intros _.
(* . *)
intros [p|p|] Hp _.
apply new_location_odd_correct with (2 := Hk) (3 := Hx).
now rewrite Hp.
apply new_location_even_correct with (2 := Hk) (3 := Hx).
now rewrite Hp.
now rewrite Hp in Hnb_steps.
(* . *)
now intros p _.
Qed.

End Fcalc_bracket_step.

Section Fcalc_bracket_scale.

Lemma inbetween_mult_aux :
  forall x d s,
  ((x * s + d * s) / 2 = (x + d) / 2 * s)%R.
Proof.
intros x d s.
field.
Qed.

Theorem inbetween_mult_compat :
  forall x d u l s,
  (0 < s)%R ->
  inbetween x d u l ->
  inbetween (x * s) (d * s) (u * s) l.
Proof.
intros x d u l s Hs [Hx|l' Hx Hl] ; constructor.
now rewrite Hx.
now split ; apply Rmult_lt_compat_r.
rewrite inbetween_mult_aux.
now rewrite Rcompare_mult_r.
Qed.

Theorem inbetween_mult_reg :
  forall x d u l s,
  (0 < s)%R ->
  inbetween (x * s) (d * s) (u * s) l ->
  inbetween x d u l.
Proof.
intros x d u l s Hs [Hx|l' Hx Hl] ; constructor.
apply Rmult_eq_reg_r with (1 := Hx).
now apply Rgt_not_eq.
now split ; apply Rmult_lt_reg_r with s.
rewrite <- Rcompare_mult_r with (1 := Hs).
now rewrite inbetween_mult_aux in Hl.
Qed.

End Fcalc_bracket_scale.

Section Fcalc_bracket_generic.

Variable beta : radix.
Notation bpow e := (bpow beta e).

(** Specialization of inbetween for two consecutive floating-point numbers. *)

Definition inbetween_float m e x l :=
  inbetween (F2R (Float beta m e)) (F2R (Float beta (m + 1) e)) x l.

Theorem inbetween_float_bounds :
  forall x m e l,
  inbetween_float m e x l ->
  (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R.
Proof.
intros x m e l [Hx|l' Hx Hl].
rewrite Hx.
split.
apply Rle_refl.
apply F2R_lt.
apply Zlt_succ.
split.
now apply Rlt_le.
apply Hx.
Qed.

(** Specialization of inbetween for two consecutive integers. *)

Definition inbetween_int m x l :=
  inbetween (IZR m) (IZR (m + 1)) x l.

Theorem inbetween_float_new_location :
  forall x m e l k,
  (0 < k)%Z ->
  inbetween_float m e x l ->
  inbetween_float (Z.div m (Zpower beta k)) (e + k) x (new_location (Zpower beta k) (Zmod m (Zpower beta k)) l).
Proof.
intros x m e l k Hk Hx.
unfold inbetween_float in *.
assert (Hr: forall m, F2R (Float beta m (e + k)) = F2R (Float beta (m * Zpower beta k) e)).
clear -Hk. intros m.
rewrite (F2R_change_exp beta e).
apply (f_equal (fun r => F2R (Float beta (m * Zpower _ r) e))).
ring.
omega.
assert (Hp: (Zpower beta k > 0)%Z).
apply Z.lt_gt.
apply Zpower_gt_0.
now apply Zlt_le_weak.
(* . *)
rewrite 2!Hr.
rewrite Zmult_plus_distr_l, Zmult_1_l.
unfold F2R at 2. simpl.
rewrite plus_IZR, Rmult_plus_distr_r.
apply new_location_correct.
apply bpow_gt_0.
now apply Zpower_gt_1.
now apply Z_mod_lt.
rewrite <- 2!Rmult_plus_distr_r, <- 2!plus_IZR.
rewrite Zmult_comm, Zplus_assoc.
now rewrite <- Z_div_mod_eq.
Qed.

Theorem inbetween_float_new_location_single :
  forall x m e l,
  inbetween_float m e x l ->
  inbetween_float (Z.div m beta) (e + 1) x (new_location beta (Zmod m beta) l).
Proof.
intros x m e l Hx.
replace (radix_val beta) with (Zpower beta 1).
now apply inbetween_float_new_location.
apply Zmult_1_r.
Qed.

Theorem inbetween_float_ex :
  forall m e l,
  exists x,
  inbetween_float m e x l.
Proof.
intros m e l.
apply inbetween_ex.
apply F2R_lt.
apply Zlt_succ.
Qed.

Theorem inbetween_float_unique :
  forall x e m l m' l',
  inbetween_float m e x l ->
  inbetween_float m' e x l' ->
  m = m' /\ l = l'.
Proof.
intros x e m l m' l' H H'.
refine ((fun Hm => conj Hm _) _).
rewrite <- Hm in H'. clear -H H'.
apply inbetween_unique with (1 := H) (2 := H').
destruct (inbetween_float_bounds x m e l H) as (H1,H2).
destruct (inbetween_float_bounds x m' e l' H') as (H3,H4).
cut (m < m' + 1 /\ m' < m + 1)%Z. clear ; omega.
now split ; apply lt_F2R with beta e ; apply Rle_lt_trans with x.
Qed.

End Fcalc_bracket_generic.


Require Import Ascii String Decidable HoTT PartialOrder.
Require Import ExtrOcamlString.

Set Universe Polymorphism.

Set Implicit Arguments.

(** * The [TError] monad *)

(** ** Datatype *)

(* =_Cast= *)
Inductive TError A (info: HProp) :=
  | Some: A -> TError A info
  | Fail: info -> TError A info.
(* =end= *)

Arguments Some {_ _} _.
Arguments Fail {_ _} _.

(** We need to assume that the string message is irrelevant.  We would
    not need prositional truncation as an axiom if we were using the
    simpler version with [None] (and no [info]). *)

(* =Cast= *)
Definition info_str := hprop (Trunc string).
(* =end= *)

Unset Implicit Arguments.

Notation "A ⇀ B" := (A -> TError B info_str) (at level 50).

(** ** Transport maps *)

Definition transport_TError (A : Type) (B : A -> Type) {info} a a' (e:a=a') x:
  transport (fun a =>  TError (B a) info) e (Some x) = Some (e # x).
    destruct e. reflexivity.
Defined.

Definition transport_TError_Fail (A : Type) (B : A -> Type) a a' (e:a=a') {info} i:
  transport (fun a => TError (B a) info) e (Fail i) = Fail i.
    destruct e. reflexivity.
Defined.

Definition path_TError {A} {info} {x y : TError A info}
           (xy : match x,y with
                   Some x0, Some y0 => x0 = y0
                 | Fail _ , Fail _ => True
                 | _, _ => False end) : x = y.
Proof.
  destruct x, y. all: try apply ap, xy.
  all: try elim xy. apply ap.
  apply is_hprop.
Defined.

Definition path_TError_inv {A} {info} {x y : TError A info} :
           x = y ->
           match x,y with
                   Some x0, Some y0 => x0 = y0
                 | Fail _ , Fail _ => True
                 | _, _ => False end.
Proof.
  destruct 1, x; reflexivity.
Defined.

Definition Some_inj {A} {info} {x y : A} : @Some _ info x = @Some _ info y -> x = y :=
  fun e => path_TError_inv e.

Definition Some_inj_sect {A} {info} {x y :A} (e:x=y) : Some_inj (ap (@Some _ info) e) = e.
Proof.
  destruct e; reflexivity.
Defined.

Definition Some_inj_retr {A} info {x y : TError A info} (e: x = y) :
  path_TError (path_TError_inv e) = e.
Proof.
  destruct e, x as [x|i]. reflexivity.
  simpl. assert (is_hprop i i = eq_refl).
  etransitivity. symmetry. apply contr.  apply contr.
  refine (transport (fun X => ap _ X =_ ) H^ _). reflexivity.
Defined.

Definition Some_inj_eq {A} {x y :A} info (e:Some x= Some y) : ap (@Some _ _) (Some_inj e) = e :=
  Some_inj_retr info e.

(** ** Monadic operations *)

(* =creturn= *)
Definition creturn {A} : A ⇀ A := Some.
(* =end= *)

(* =clift= *)
Definition clift A B: (A -> B) -> (A ⇀ B) :=
  fun f a => creturn (f a).
(* =end= *)

Arguments clift {_ _} _ _.

(* =cbind= *)
Definition cbind A B {info}:
  TError A info -> (A -> TError B info) -> TError B info :=
  fun a f => match a with
               Some a => f a
             | Fail i => Fail i
             end.
Notation "x <- e1 ; e2" := (cbind _ _ e1 (fun x => e2))
(* =end= *)
                            (right associativity, at level 60).

Notation "x >>= f" := (cbind _ _ x f) (at level 50).

(* =kleisliComp= *)
Definition kleisliComp {A B C: Type}: (A ⇀ B) -> (B ⇀ C) -> (A ⇀ C) :=
  fun f g a => b <- f a ; g b.
Notation "g °° f" := (kleisliComp f g)
(* =end= *)
 (at level 1).

Definition cbind_Some {A B} x (f:A ⇀ B) b :
  x >>= f = Some b -> {a:A & ((x = Some a) * (f a = Some b))%type}.
  intro e. destruct x.
  - exists a. split. reflexivity. exact e.
  - simpl in e. inversion e.
Defined.

Definition cbind_Some' {A B} x (f:A ⇀ B) b :
   {a:A & ((x = Some a) * (f a = Some b))%type} ->
  x >>= f = Some b.
  intros [a (Hx, Hfa)]. unfold cbind. destruct x.
  - inversion Hx. exact Hfa.
  - inversion Hx.
Defined.

Lemma cbind_right_id {A} (x : TError A _):
  (x >>= creturn) = x.
    destruct x; reflexivity.
Defined.

Lemma cbind_assoc {A B C} x (f: A ⇀ B) (g: B ⇀ C):
  (x >>= f) >>= g = x >>= (fun x => f x >>= g).
    destruct x; reflexivity.
Defined.

(** ** Extraction *)

Extraction Language Ocaml.

(* =extract_cast= *)
Extract Inductive TError =>
(* Transparent extraction of TError:
   - if Some t, then extract plain t
   - if Fail, then fail with a runtime coercion exception *)
     "" [ "" "(let f s = failwith
                (String.concat """" ([""Coercion failure: ""]@
                  (List.map (String.make 1) s))) in f)" ]
     "(let new_pattern some none = some in new_pattern)".
(* =end= *)

(** ** Example *)

Example coercion_some : unit ⇀ bool := fun _ => Some true.

Definition _with (s:string) : info_str := (tr s).

(* =cast_bool= *)
Example err: TError bool info_str := Fail (_with "coercion to bool").
(* =end= *)

Example use_bool (cb: TError bool info_str)  := cb >>= (fun b => creturn (andb b b)).

Example use_some := fun x => use_bool (coercion_some x).
Example use_fail := fun x:unit => use_bool err.

Extraction "test_coercion_extr.ml" use_some use_fail.
(* Expected result: it should compile (first..) and then trigger a [failwith] *)

(** ** Decidable instances *)

Definition Decidable_eq_TError : forall A (HA: DecidablePaths A)
  (x y: TError A info_str), (x = y) + not (x = y).
intros. destruct x as [a |]; destruct y as [a0 |].
- case (dec_paths a a0); intro H.
  + left. exact (ap _ H).
  + right. intro Hc. exact (H (Some_inj Hc)).
- right. unfold not. intro Hc. inversion Hc.
- right. unfold not. intro Hc. inversion Hc.
- left. apply ap. apply is_hprop.
Defined.

Instance IsHSet_TError (A:HSet) HA : IsHSet (TError A info_str) := Hedberg (@Decidable_eq_TError A HA).

Instance DecidablePaths_TError :
  forall A (HA: DecidablePaths A), DecidablePaths (hset (TError A info_str)) :=
  { dec_paths := Decidable_eq_TError A HA }.

(** ** Preorder instance *)

(** We define a notion of preorder on [TError A], for any [A]. The least
element is bottom while successful computations are compared by
equality. *)

(* =preordercast= *)
Instance IsPartialOrderTError (A: HSet): IsPartialOrder_pp (TError A info_str) :=
  {| rel := fun a a' => @hprop (match a with
                     | Some _ => a = a'
                     | Fail _ => True
                     end) _;
     bot := Fail (_with "bot") |}.
(* =end= *)
Proof.
  - intros e e'. cbn in *. destruct a as [a|], a' as [a'|]; cbn in *.
    + assert (path_TError_inv e = path_TError_inv e') by apply is_hprop.
      apply (ap (@path_TError A info_str (Some a) (Some a'))) in H.
      repeat rewrite Some_inj_retr in H. assumption.
    + inversion e.
    + destruct e, e'. reflexivity.
    + destruct e, e'. reflexivity.
  - destruct x. reflexivity. exact I.
  - intros x y z. destruct x, y; intros e e'; auto.
    exact (e @ e').
    discriminate.
  - intros x y H H'. destruct x, y; eauto.
    apply ap. apply is_hprop.
  - intro; exact I.
Defined.

(** To avoid failure of evaluation of bot in ocaml code *)

Extract Constant IsPartialOrderTError => "0".

Instance TError_HSet A `{IsHSet A} : IsHSet (TError A info_str).
intros.
intros a b e e'.
destruct a as [a|]; destruct b as [b|];
  try now inversion e.
+ pose proof (Some_inj_eq info_str e)^.
  pose proof (Some_inj_eq info_str e').
  etransitivity; eauto.
  etransitivity; [| eauto].
  destruct (is_hset a b (Some_inj e) (Some_inj e')).
  reflexivity.
+ pose proof (Some_inj_retr info_str e).
  pose proof (Some_inj_retr info_str e').
  etransitivity; [symmetry; eauto|].
  etransitivity; [|eauto].
  assert (e'': path_TError_inv e = path_TError_inv e') by apply is_hprop.
  destruct e''. reflexivity.
Defined.

Definition TError_HSet_preorder (A:HSet) : forall (x y : TError A info_str) (e e' : x ≼ y), e = e'.
Proof.
  intros x y e e'; destruct x as [x|], y as [y|]; simpl in *.
  apply TError_HSet; typeclasses eauto.
  inversion e.
  destruct e, e'; reflexivity.
  destruct e, e'; reflexivity.
Defined.

Definition transport_bind A (x y : A) (e:y=x)  B (f : A -> B) :
  transport (λ X : TError A info_str, Some (f x) = b <- X; clift f b)
            (ap creturn e)^ eq_refl
  = ap creturn (ap f e^).
    destruct e. reflexivity.
Defined.


Require Import Lib DeciTer Arith Omega NArith PArith ZArith.

Lemma rev_rev d1 d2 :
 rev (rev d1 d2) Stop = rev d2 d1.
Proof.
 revert d2.
 induction d1; simpl; auto; intros; now rewrite IHd1.
Qed.

Definition tl d :=
 match d with
 | Stop => d
 | D0 d => d
 | D1 d => d
 | D2 d => d
 | D3 d => d
 | D4 d => d
 | D5 d => d
 | D6 d => d
 | D7 d => d
 | D8 d => d
 | D9 d => d
end.

(** Normalization on little-endian numbers *)
Fixpoint lnorm d :=
 match d with
 | Stop => Stop
 | D0 d => match lnorm d with Stop => Stop | d' => D0 d' end
 | D1 d => D1 (lnorm d)
 | D2 d => D2 (lnorm d)
 | D3 d => D3 (lnorm d)
 | D4 d => D4 (lnorm d)
 | D5 d => D5 (lnorm d)
 | D6 d => D6 (lnorm d)
 | D7 d => D7 (lnorm d)
 | D8 d => D8 (lnorm d)
 | D9 d => D9 (lnorm d)
 end.

Lemma norm_rev_0 d d' : lnorm d = Stop -> norm (rev d d') = norm d'.
Proof.
 revert d'.
 induction d; intros; auto; try discriminate.
 simpl in *.
 destruct (lnorm d) eqn:Eq; try discriminate.
 now rewrite IHd.
Qed.

Lemma dec_stop d : { d = Stop } + { d <> Stop }.
Proof.
 destruct d; (now left) || (now right).
Qed.

Lemma norm_rev d d' : lnorm d <> Stop ->
 norm (rev d d') = rev (lnorm d) d'.
Proof.
 revert d'.
 induction d; intros d' H; simpl in *.
 - now destruct H.
 - destruct (lnorm d) eqn:Eq;
    (now destruct H) || (now rewrite IHd).
 - destruct (lnorm d) eqn:Eq;
    (now rewrite norm_rev_0) || (now rewrite IHd).
 - destruct (lnorm d) eqn:Eq;
    (now rewrite norm_rev_0) || (now rewrite IHd).
 - destruct (lnorm d) eqn:Eq;
    (now rewrite norm_rev_0) || (now rewrite IHd).
 - destruct (lnorm d) eqn:Eq;
    (now rewrite norm_rev_0) || (now rewrite IHd).
 - destruct (lnorm d) eqn:Eq;
    (now rewrite norm_rev_0) || (now rewrite IHd).
 - destruct (lnorm d) eqn:Eq;
    (now rewrite norm_rev_0) || (now rewrite IHd).
 - destruct (lnorm d) eqn:Eq;
    (now rewrite norm_rev_0) || (now rewrite IHd).
 - destruct (lnorm d) eqn:Eq;
    (now rewrite norm_rev_0) || (now rewrite IHd).
 - destruct (lnorm d) eqn:Eq;
    (now rewrite norm_rev_0) || (now rewrite IHd).
Qed.

Lemma lnorm_rev d :
  rev (lnorm (rev d Stop)) Stop = norm d.
Proof.
 generalize (rev_rev d Stop). simpl.
 intros Eq. rewrite <- Eq at 2.
 destruct (dec_stop (lnorm (rev d Stop))) as [H|H].
 - rewrite H. simpl. rewrite norm_rev_0; auto.
 - rewrite norm_rev; auto.
Qed.

Module NatProofs.

Import DecNat.

(** A few helper functions used during proofs *)

Definition hd d :=
 match d with
 | Stop => 0
 | D0 _ => 0
 | D1 _ => 1
 | D2 _ => 2
 | D3 _ => 3
 | D4 _ => 4
 | D5 _ => 5
 | D6 _ => 6
 | D7 _ => 7
 | D8 _ => 8
 | D9 _ => 9
end.

Fixpoint dec_size (d:dec) : nat :=
  match d with
  | Stop => 0
  | D0 d => S (dec_size d)
  | D1 d => S (dec_size d)
  | D2 d => S (dec_size d)
  | D3 d => S (dec_size d)
  | D4 d => S (dec_size d)
  | D5 d => S (dec_size d)
  | D6 d => S (dec_size d)
  | D7 d => S (dec_size d)
  | D8 d => S (dec_size d)
  | D9 d => S (dec_size d)
  end.

(** A direct definition of [to_little_dec], non tail-recursive *)
Fixpoint to_ldec n :=
 match n with
 | 0 => Stop
 | S n => Little.succ (to_ldec n)
 end.

(** A direct definition of little-endian [of_dec] *)
Fixpoint of_ldec (d:dec) : nat :=
  match d with
  | Stop => 0
  | D0 d => 10 * of_ldec d
  | D1 d => 1 + 10 * of_ldec d
  | D2 d => 2 + 10 * of_ldec d
  | D3 d => 3 + 10 * of_ldec d
  | D4 d => 4 + 10 * of_ldec d
  | D5 d => 5 + 10 * of_ldec d
  | D6 d => 6 + 10 * of_ldec d
  | D7 d => 7 + 10 * of_ldec d
  | D8 d => 8 + 10 * of_ldec d
  | D9 d => 9 + 10 * of_ldec d
  end.

(** Properties of [to_ldec] *)

Lemma to_little_dec_succ_r n d :
 to_little_dec n (Little.succ d) = Little.succ (to_little_dec n d).
Proof.
 revert d; induction n; simpl; auto.
Qed.

Lemma to_little_dec_alt n :
  to_little_dec n Stop = to_ldec n.
Proof.
 induction n; simpl; auto.
 change (D1 Stop) with (Little.succ Stop).
 rewrite to_little_dec_succ_r. now f_equal.
Qed.

Lemma to_dec_alt n :
 to_dec n = rev (to_ldec n) Stop.
Proof.
 unfold to_dec. f_equal. apply to_little_dec_alt.
Qed.

Lemma to_ldec_succ n : to_ldec (S n) = Little.succ (to_ldec n).
Proof.
 reflexivity.
Qed.

(** Properties of [of_ldec] *)

Lemma of_ldec_eqn d :
 of_ldec d = hd d + 10 * of_ldec (tl d).
Proof.
 induction d; simpl; auto.
Qed.

Lemma little_succ d :
 of_ldec (Little.succ d) = S (of_ldec d).
Proof.
 induction d; simpl; trivial. omega.
Qed.

Lemma of_to_little n :
 of_ldec (to_ldec n) = n.
Proof.
 induction n; simpl; trivial. rewrite little_succ. now f_equal.
Qed.

Ltac helper IH t :=
  rewrite IH;
  rewrite (of_ldec_eqn t); simpl hd; simpl tl;
  rewrite Nat.mul_add_distr_r, Nat.add_assoc; f_equal; [|ring];
  symmetry; apply IH.

Lemma of_ldec_rev d d' :
of_ldec (rev d d') =
 of_ldec (rev d Stop) + of_ldec d' * 10^dec_size d.
Proof.
 revert d'.
 induction d; intros; simpl dec_size; rewrite ?Nat.pow_succ_r'; simpl rev.
 - simpl. omega.
 - helper IHd (D0 d').
 - helper IHd (D1 d').
 - helper IHd (D2 d').
 - helper IHd (D3 d').
 - helper IHd (D4 d').
 - helper IHd (D5 d').
 - helper IHd (D6 d').
 - helper IHd (D7 d').
 - helper IHd (D8 d').
 - helper IHd (D9 d').
Qed.

Lemma of_dec_acc_spec n d :
of_dec_acc d n = of_ldec (rev d Stop) + n * 10^dec_size d.
Proof.
 revert n. induction d; intros;
  simpl of_dec_acc; rewrite ?TailNat.mul_spec, ?IHd;
  simpl rev; simpl dec_size; rewrite ?Nat.pow_succ_r'.
 - simpl. omega.
 - rewrite (of_ldec_rev d (D0 Stop)). simpl of_ldec. ring.
 - rewrite (of_ldec_rev d (D1 Stop)). simpl of_ldec. ring.
 - rewrite (of_ldec_rev d (D2 Stop)). simpl of_ldec. ring.
 - rewrite (of_ldec_rev d (D3 Stop)). simpl of_ldec. ring.
 - rewrite (of_ldec_rev d (D4 Stop)). simpl of_ldec. ring.
 - rewrite (of_ldec_rev d (D5 Stop)). simpl of_ldec. ring.
 - rewrite (of_ldec_rev d (D6 Stop)). simpl of_ldec. ring.
 - rewrite (of_ldec_rev d (D7 Stop)). simpl of_ldec. ring.
 - rewrite (of_ldec_rev d (D8 Stop)). simpl of_ldec. ring.
 - rewrite (of_ldec_rev d (D9 Stop)). simpl of_ldec. ring.
Qed.

Lemma of_dec_alt d : of_dec d = of_ldec (rev d Stop).
Proof.
 unfold of_dec.
 rewrite of_dec_acc_spec. auto.
Qed.

(** First main bijection result *)

Lemma of_to (n:nat) : of_dec (to_dec n) = n.
Proof.
 rewrite to_dec_alt, of_dec_alt, rev_rev. simpl.
 apply of_to_little.
Qed.

(** The other direction *)

Lemma to_ldec_tenfold n : n<>0 ->
 to_ldec (10 * n) = D0 (to_ldec n).
Proof.
 induction n.
 - simpl. now destruct 1.
 - intros _.
   destruct (Nat.eq_dec n 0) as [->|H]; simpl; auto.
   rewrite !Nat.add_succ_r.
   simpl.
   change (Nat.iter 10 Little.succ (to_ldec (10*n))
           = D0 (Little.succ (to_ldec n))).
   rewrite (IHn H).
   destruct (to_ldec n); simpl; auto.
Qed.

Lemma of_ldec_0 d : of_ldec d = 0 <-> lnorm d = Stop.
Proof.
 induction d; rewrite of_ldec_eqn; simpl hd; simpl tl; try easy.
 rewrite Nat.add_0_l.
 split; intros.
 - apply Nat.eq_mul_0_r in H; auto. rewrite IHd in H. simpl.
   now rewrite H.
 - simpl in H. destruct (lnorm d); try discriminate.
   destruct IHd as [_ ->]; auto.
Qed.

Lemma to_of_little_tenfold d :
 to_ldec (of_ldec d) = lnorm d ->
 to_ldec (10 * of_ldec d) = lnorm (D0 d).
Proof.
 intro IH.
 destruct (Nat.eq_dec (of_ldec d) 0) as [H|H].
 - rewrite H. simpl. rewrite of_ldec_0 in H. now rewrite H.
 - rewrite to_ldec_tenfold; auto. rewrite IH. simpl.
   rewrite of_ldec_0 in H.
   destruct (lnorm d); now simpl.
Qed.

Ltac helper2 :=
 rewrite of_ldec_eqn; simpl hd; simpl tl;
 rewrite ?Nat.add_succ_l, Nat.add_0_l, ?to_ldec_succ,
  to_of_little_tenfold by assumption;
 simpl; destruct lnorm; auto.

Lemma to_of_little d : to_ldec (of_ldec d) = lnorm d.
Proof.
 induction d; try helper2. simpl; auto.
Qed.

(** Second bijection results *)

Lemma to_of (d:dec) : to_dec (of_dec d) = norm d.
Proof.
 rewrite to_dec_alt, of_dec_alt.
 rewrite to_of_little.
 apply lnorm_rev.
Qed.

(** Usual consequences *)

Lemma to_dec_inj n n' : to_dec n = to_dec n' -> n = n'.
Proof.
 intro EQ.
 now rewrite <- (of_to n), <- (of_to n'), EQ.
Qed.

Lemma to_dec_surj d : exists n, to_dec n = norm d.
Proof.
 exists (of_dec d). apply to_of.
Qed.

Lemma of_dec_norm d : of_dec (norm d) = of_dec d.
Proof.
 unfold of_dec.
 induction d; simpl; auto.
Qed.

Lemma of_inj d d' :
 of_dec d = of_dec d' -> norm d = norm d'.
Proof.
 intros. rewrite <- !to_of. now f_equal.
Qed.

Lemma of_iff d d' : of_dec d = of_dec d' <-> norm d = norm d'.
Proof.
 split. apply of_inj. intros E. rewrite <- of_dec_norm, E.
 apply of_dec_norm.
Qed.

End NatProofs.

(** Conversion results with respect to positive and N *)

Module PosProofs.
Import DecPos.
Local Open Scope positive.

(** A direct definition of little-endian [of_dec] *)

Fixpoint of_ldec (d:dec) : N :=
  match d with
  | Stop => 0
  | D0 d => 10 * of_ldec d
  | D1 d => 1 + 10 * of_ldec d
  | D2 d => 2 + 10 * of_ldec d
  | D3 d => 3 + 10 * of_ldec d
  | D4 d => 4 + 10 * of_ldec d
  | D5 d => 5 + 10 * of_ldec d
  | D6 d => 6 + 10 * of_ldec d
  | D7 d => 7 + 10 * of_ldec d
  | D8 d => 8 + 10 * of_ldec d
  | D9 d => 9 + 10 * of_ldec d
  end.

Definition hd d :=
match d with
 | Stop => 0
 | D0 _ => 0
 | D1 _ => 1
 | D2 _ => 2
 | D3 _ => 3
 | D4 _ => 4
 | D5 _ => 5
 | D6 _ => 6
 | D7 _ => 7
 | D8 _ => 8
 | D9 _ => 9
end%N.

Lemma of_ldec_eqn d :
 (of_ldec d = hd d + 10 * (of_ldec (tl d)))%N.
Proof.
 induction d; simpl; auto.
Qed.

Fixpoint dec_size (d:dec) : N :=
  match d with
  | Stop => 0
  | D0 d => N.succ (dec_size d)
  | D1 d => N.succ (dec_size d)
  | D2 d => N.succ (dec_size d)
  | D3 d => N.succ (dec_size d)
  | D4 d => N.succ (dec_size d)
  | D5 d => N.succ (dec_size d)
  | D6 d => N.succ (dec_size d)
  | D7 d => N.succ (dec_size d)
  | D8 d => N.succ (dec_size d)
  | D9 d => N.succ (dec_size d)
  end.

Ltac helper IH f d n :=
  rewrite 2 (IH (f _));
  change (of_ldec (f d)) with (n + 10 * (of_ldec d))%N;
  simpl (of_ldec (f _)); ring.

Lemma of_ldec_rev d d' :
(of_ldec (rev d d') =
  of_ldec (rev d Stop) + of_ldec d' * 10^dec_size d)%N.
Proof.
 revert d'.
 induction d; simpl; intros; rewrite ?N.pow_succ_r'.
 - ring.
 - helper IHd D0 d' (0%N).
 - helper IHd D1 d' (1%N).
 - helper IHd D2 d' (2%N).
 - helper IHd D3 d' (3%N).
 - helper IHd D4 d' (4%N).
 - helper IHd D5 d' (5%N).
 - helper IHd D6 d' (6%N).
 - helper IHd D7 d' (7%N).
 - helper IHd D8 d' (8%N).
 - helper IHd D9 d' (9%N).
Qed.

Ltac helper2 IH n d acc :=
  change (of_dec_acc _ _) with (of_dec_acc d (n + 10 * acc));
  rewrite IH;
  change (N.pos (n + 10*acc)) with (Npos n + 10 * N.pos acc)%N; ring.

Lemma of_dec_acc_rev d acc :
 (Npos (of_dec_acc d acc) =
   of_ldec (rev d Stop) + (Npos acc) * 10^dec_size d)%N.
Proof.
 revert acc.
 induction d; intros; simpl dec_size; rewrite ?N.pow_succ_r';
  simpl rev; try rewrite of_ldec_rev; simpl of_ldec.
 - simpl. f_equal. symmetry. apply Pos.mul_1_r.
 - change (of_dec_acc _ _) with (of_dec_acc d (10 * acc)).
   rewrite IHd.
   change (N.pos (10*acc)) with (10 * N.pos acc)%N. ring.
 - helper2 IHd 1 d acc.
 - helper2 IHd 2 d acc.
 - helper2 IHd 3 d acc.
 - helper2 IHd 4 d acc.
 - helper2 IHd 5 d acc.
 - helper2 IHd 6 d acc.
 - helper2 IHd 7 d acc.
 - helper2 IHd 8 d acc.
 - helper2 IHd 9 d acc.
Qed.

Lemma of_dec_rev d : of_dec d = of_ldec (rev d Stop).
Proof.
 induction d; simpl; auto; rewrite of_ldec_rev; simpl of_ldec;
  try (rewrite of_dec_acc_rev); auto.
 simpl. rewrite IHd. ring.
Qed.

Lemma of_dec_rev' d : of_dec (rev d Stop) = of_ldec d.
Proof.
 rewrite of_dec_rev. now rewrite rev_rev.
Qed.

Ltac helper3 IH :=
 simpl Little.double; simpl Little.succ_double;
 do 3 (rewrite (of_ldec_eqn (_ _)); simpl hd; simpl tl; rewrite ?IH);
 split;ring.

Lemma of_double_gen d :
  of_ldec (Little.double d) = N.double (of_ldec d) /\
  of_ldec (Little.succ_double d) = N.succ_double (of_ldec d).
Proof.
 rewrite N.double_spec, N.succ_double_spec.
 induction d; try destruct IHd as (IH1,IH2).
 - simpl; auto.
 - simpl. rewrite IH1. destruct (of_ldec d); simpl; auto.
 - simpl. rewrite IH1. destruct (of_ldec d); simpl; auto.
 - simpl. rewrite IH1. destruct (of_ldec d); simpl; auto.
 - simpl. rewrite IH1. destruct (of_ldec d); simpl; auto.
 - simpl. rewrite IH1. destruct (of_ldec d); simpl; auto.
 - helper3 IH2.
 - helper3 IH2.
 - helper3 IH2.
 - helper3 IH2.
 - helper3 IH2.
Qed.

Lemma of_double d :
  of_ldec (Little.double d) = N.double (of_ldec d).
Proof.
 apply of_double_gen.
Qed.

Lemma of_succ_double d :
  of_ldec (Little.succ_double d) = N.succ_double (of_ldec d).
Proof.
 apply of_double_gen.
Qed.

Lemma of_to (p:positive) : of_dec (to_dec p) = Npos p.
Proof.
 unfold to_dec.
 rewrite of_dec_rev'.
 induction p; simpl; auto.
 - now rewrite of_succ_double, IHp.
 - now rewrite of_double, IHp.
Qed.

(** The other direction *)

Definition to_ldec n :=
  match n with
  | N0 => Stop
  | Npos p => to_dec_rev p
  end.

Lemma succ_double_alt d :
  Little.succ_double d = Little.succ (Little.double d).
Proof.
 induction d; simpl; auto.
Qed.

Lemma double_succ d :
  Little.double (Little.succ d) =
  Little.succ (Little.succ_double d).
Proof.
 induction d; simpl; f_equal; auto using succ_double_alt.
Qed.

Lemma to_ldec_succ n :
 to_ldec (N.succ n) = Little.succ (to_ldec n).
Proof.
 destruct n; simpl; auto.
 induction p; simpl; rewrite ?IHp;
  auto using succ_double_alt, double_succ.
Qed.

Ltac tac_iter n f i :=
 match eval compute in n with
 | N0 => let x:=i in x
 | _ => tac_iter (N.pred n) f (f i)
 end.

Lemma to_ldec_tenfold p :
 to_ldec (10 * (Npos p)) = D0 (to_ldec (Npos p)).
Proof.
 induction p using Pos.peano_rect.
 - simpl; auto.
 - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)).
   rewrite N.mul_succ_r.
   let n := tac_iter 10%N N.succ N0 in
   change 10%N at 2 with n.
   rewrite !N.add_succ_r, N.add_0_r.
   rewrite !to_ldec_succ.
   rewrite IHp.
   destruct (to_ldec (N.pos p)); simpl; auto.
Qed.

Lemma of_ldec_0 d : of_ldec d = 0%N <-> lnorm d = Stop.
Proof.
 induction d; rewrite of_ldec_eqn; simpl hd; simpl tl; try easy.
 - rewrite N.add_0_l.
   split; intros.
   + apply N.eq_mul_0_r in H. rewrite IHd in H. simpl.
     now rewrite H. easy.
   + simpl in H. destruct (lnorm d); try discriminate.
     destruct IHd as [_ ->]; auto.
 - split. omega with *. easy.
 - split. omega with *. easy.
 - split. omega with *. easy.
 - split. omega with *. easy.
 - split. omega with *. easy.
 - split. omega with *. easy.
 - split. omega with *. easy.
 - split. omega with *. easy.
 - split. omega with *. easy.
Qed.

Lemma to_of_little_tenfold d :
 to_ldec (of_ldec d) = lnorm d ->
 to_ldec (10 * of_ldec d) = lnorm (D0 d).
Proof.
 intro IH.
 destruct (N.eq_dec (of_ldec d) 0) as [H|H].
 - rewrite H. simpl. rewrite of_ldec_0 in H. now rewrite H.
 - destruct (of_ldec d) eqn:Eq; [easy| ].
   rewrite to_ldec_tenfold; auto. rewrite IH. simpl.
   rewrite <- Eq in H. rewrite of_ldec_0 in H.
   destruct (lnorm d); now simpl.
Qed.

Ltac helper4 n :=
 rewrite of_ldec_eqn; simpl hd; simpl tl;
 let n' := tac_iter n N.succ N0 in
 change n with n';
 rewrite ?N.add_succ_l, N.add_0_l, ?to_ldec_succ,
  to_of_little_tenfold by assumption;
 simpl; destruct lnorm; auto.

Lemma to_of_little d : to_ldec (of_ldec d) = lnorm d.
Proof.
 induction d.
 - simpl; auto.
 - helper4 0%N.
 - helper4 1%N.
 - helper4 2%N.
 - helper4 3%N.
 - helper4 4%N.
 - helper4 5%N.
 - helper4 6%N.
 - helper4 7%N.
 - helper4 8%N.
 - helper4 9%N.
Qed.

(** Second bijection results *)

Lemma to_of (d:dec) : DecN.to_dec (of_dec d) = norm d.
Proof.
 rewrite of_dec_rev.
 unfold DecN.to_dec, to_dec.
 destruct (of_ldec (rev d Stop)) eqn:H.
 - rewrite of_ldec_0 in H. rewrite <- lnorm_rev. now rewrite H.
 - change (to_dec_rev p) with (to_ldec (N.pos p)).
   rewrite <- H. rewrite to_of_little. apply lnorm_rev.
Qed.

End PosProofs.

Module NProofs.

Import DecN.

Lemma of_to (n:N) : of_dec (to_dec n) = n.
Proof.
 destruct n.
 - simpl; auto.
 - apply PosProofs.of_to.
Qed.

Lemma to_of (d:dec) : to_dec (of_dec d) = norm d.
Proof.
 exact (PosProofs.to_of d).
Qed.

End NProofs.

(** Proofs about [Deci.succ] *)

Import DecNat NatProofs.

Lemma succ_to n :
 succ (to_dec n) = to_dec (S n).
Proof.
 unfold to_dec.
 unfold succ. f_equal. rewrite rev_rev. simpl rev.
 rewrite !to_little_dec_alt.
 apply to_ldec_succ.
Qed.

Lemma lsucc_lnorm d :
 lnorm (Little.succ d) = Little.succ (lnorm d).
Proof.
 induction d; simpl; auto.
 - destruct (lnorm d); simpl; auto.
 - rewrite IHd. destruct (lnorm d); simpl; auto.
Qed.

Lemma succ_norm d :
 norm (succ d) = succ (norm d).
Proof.
 unfold succ. rewrite <- !lnorm_rev, !rev_rev; simpl.
 f_equal. apply lsucc_lnorm.
Qed.

Lemma of_succ d :
  of_dec (succ d) = S (of_dec d).
Proof.
 apply to_dec_inj.
 rewrite <- succ_to. rewrite !to_of.
 apply succ_norm.
Qed.

Lemma succ_inj d d' :
 succ d = succ d' -> norm d = norm d'.
Proof.
 intros. apply of_inj.
 assert (E : S (of_dec d) = S (of_dec d')).
 { rewrite <- !of_succ. now f_equal. }
 now injection E.
Qed.

(** Proofs about [Deci.lt] *)

Lemma to_lt n n' : n < n' -> lt (to_dec n) (to_dec n').
Proof.
 induction 1.
 + rewrite <- succ_to. apply Succ.
 + apply Trans with (to_dec m); trivial.
   rewrite <- succ_to. apply Succ.
Qed.

Lemma of_lt d d' : lt d d' -> of_dec d < of_dec d'.
Proof.
 induction 1.
 + rewrite of_succ. auto.
 + omega.
Qed.

Lemma to_lt_iff n n' :  n < n' <-> lt (to_dec n) (to_dec n').
Proof.
 split; [apply to_lt|].
 intros H. apply of_lt in H. now rewrite !of_to in H.
Qed.

Lemma of_lt_iff d d' :
  of_dec d < of_dec d' <-> lt (norm d) (norm d').
Proof.
 rewrite to_lt_iff. now rewrite !to_of.
Qed.

Lemma lt_norm d d' : lt d d' -> lt (norm d) (norm d').
Proof.
 rewrite <- of_lt_iff. apply of_lt.
Qed.

Lemma lt_irrefl d d' : lt d d' -> norm d <> norm d'.
Proof.
 intros L E.
 apply of_lt in L.
 rewrite <- of_iff in E.
 omega.
Qed.

Lemma lt_antisym d d' : lt d d' -> ~lt d' d.
Proof.
 intros L L'. apply of_lt in L. apply of_lt in L'. omega.
Qed.

Lemma lt_trans d1 d2 d3 : lt d1 d2 -> lt d2 d3 -> lt d1 d3.
Proof.
 apply Trans.
Qed.

Lemma lt_norm_total d d' :
 { lt (norm d) (norm d') } + { norm d = norm d' } + { lt (norm d') (norm d) }.
Proof.
 destruct (CompareSpec2Type (Nat.compare_spec (of_dec d) (of_dec d'))).
 - left; right. now apply of_inj.
 - left; left. now apply of_lt_iff.
 - right; now apply of_lt_iff.
Qed.


Require Export Term.

Section Church_Rosser.

  Definition str_confluent R := commut _ R (transp term R).

  Lemma str_confluence_par_red1 : str_confluent par_red1.
red in |- *; red in |- *.
simple induction 1; intros.
inversion_clear H4.
elim H1 with M'0; auto with coc; intros.
elim H3 with N'0; auto with coc; intros.
exists (subst x1 x0); unfold subst in |- *; auto with coc.

inversion_clear H5.
elim H1 with M'1; auto with coc; intros.
elim H3 with N'0; auto with coc; intros.
exists (subst x1 x0); auto with coc; unfold subst in |- *; auto with coc.

inversion_clear H0.
exists (Srt s); auto with coc.

inversion_clear H0.
exists (Ref n); auto with coc.

inversion_clear H4.
elim H1 with M'0; auto with coc; intros.
elim H3 with T'0; auto with coc; intros.
exists (Abs x1 x0); auto with coc.

generalize H0 H1.
clear H0 H1.
inversion_clear H4.
intro.
inversion_clear H4.
intros.
elim H4 with (Abs T M'0); auto with coc; intros.
elim H3 with N'0; auto with coc; intros.
apply inv_par_red_abs with T' M'1 x0; intros; auto with coc.
generalize H7 H8.
rewrite H11.
clear H7 H8; intros.
inversion_clear H7.
inversion_clear H8.
exists (subst x1 U'); auto with coc.
unfold subst in |- *; auto with coc.

intros.
elim H5 with M'0; auto with coc; intros.
elim H3 with N'0; auto with coc; intros.
exists (App x0 x1); auto with coc.

intros.
inversion_clear H4.
elim H1 with M'0; auto with coc; intros.
elim H3 with N'0; auto with coc; intros.
exists (Prod x0 x1); auto with coc.
Qed.

  Lemma strip_lemma : commut _ par_red (transp _ par_red1).
unfold commut, par_red in |- *; simple induction 1; intros.
elim str_confluence_par_red1 with z x0 y0; auto with coc; intros.
exists x1; auto with coc.

elim H1 with z0; auto with coc; intros.
elim H3 with x1; intros; auto with coc.
exists x2; auto with coc.
apply t_trans with x1; auto with coc.
Qed.

  Lemma confluence_par_red : str_confluent par_red.
red in |- *; red in |- *.
simple induction 1; intros.
elim strip_lemma with z x0 y0; intros; auto with coc.
exists x1; auto with coc.

elim H1 with z0; intros; auto with coc.
elim H3 with x1; intros; auto with coc.
exists x2; auto with coc.
red in |- *.
apply t_trans with x1; auto with coc.
Qed.

  Lemma confluence_red : str_confluent red.
red in |- *; red in |- *.
intros.
elim confluence_par_red with x y z; auto with coc; intros.
exists x0; auto with coc.
Qed.

  Theorem church_rosser :
   forall u v, conv u v -> exists2 t, red u t & red v t.
simple induction 1; intros.
exists u; auto with coc.

elim H1; intros.
elim confluence_red with x P N; auto with coc; intros.
exists x0; auto with coc.
apply trans_red_red with x; auto with coc.

elim H1; intros.
exists x; auto with coc.
apply trans_red_red with P; auto with coc.
Qed.

  Lemma inv_conv_prod_l :
   forall a b c d, conv (Prod a c) (Prod b d) -> conv a b.
intros.
elim church_rosser with (Prod a c) (Prod b d); intros; auto with coc.
apply red_prod_prod with a c x; intros; auto with coc.
apply red_prod_prod with b d x; intros; auto with coc.
apply trans_conv_conv with a0; auto with coc.
apply sym_conv.
generalize H2.
rewrite H5; intro.
injection H8.
simple induction 2; auto with coc.
Qed.

  Lemma inv_conv_prod_r :
   forall a b c d, conv (Prod a c) (Prod b d) -> conv c d.
intros.
elim church_rosser with (Prod a c) (Prod b d); intros; auto with coc.
apply red_prod_prod with a c x; intros; auto with coc.
apply red_prod_prod with b d x; intros; auto with coc.
apply trans_conv_conv with b0; auto with coc.
apply sym_conv.
generalize H2.
rewrite H5; intro.
injection H8.
simple induction 1; auto with coc.
Qed.

  Lemma nf_uniqueness : forall u v, conv u v -> normal u -> normal v -> u = v.
intros.
elim church_rosser with u v; intros; auto with coc.
rewrite (red_normal u x); auto with coc.
elim red_normal with v x; auto with coc.
Qed.

  Lemma conv_sort : forall s1 s2, conv (Srt s1) (Srt s2) -> s1 = s2.
intros.
cut (Srt s1 = Srt s2); intros.
injection H0; auto with coc.

apply nf_uniqueness; auto with coc.
red in |- *; red in |- *; intros.
inversion_clear H0.

red in |- *; red in |- *; intros.
inversion_clear H0.
Qed.

  Lemma conv_kind_prop : ~ conv (Srt kind) (Srt prop).
red in |- *; intro.
absurd (kind = prop).
discriminate.

apply conv_sort; auto with coc.
Qed.

  Lemma conv_sort_prod : forall s t u, ~ conv (Srt s) (Prod t u).
red in |- *; intros.
elim church_rosser with (Srt s) (Prod t u); auto with coc.
do 2 intro.
elim red_normal with (Srt s) x; auto with coc.
intro.
apply red_prod_prod with t u (Srt s); auto with coc; intros.
discriminate H2.

red in |- *; red in |- *; intros.
inversion_clear H1.
Qed.

End Church_Rosser.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C G Aprime Aprimeprime Bprime Cprime Bprimeprime : Universe, ((wd_ G Bprimeprime /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Bprime A /\ (wd_ Bprime C /\ (wd_ Aprime B /\ (wd_ Aprime C /\ (wd_ Cprime A /\ (wd_ Cprime B /\ (wd_ Aprimeprime Bprimeprime /\ (wd_ Aprime Bprime /\ (wd_ Bprimeprime Bprime /\ (wd_ G Bprime /\ (wd_ B G /\ (wd_ Bprimeprime B /\ (col_ G Bprimeprime Bprime /\ (col_ Bprimeprime B G /\ (col_ Cprime A B /\ (col_ Bprime A C /\ (col_ G Aprime Aprimeprime /\ (col_ Aprimeprime A G /\ col_ Aprime B C)))))))))))))))))))))) -> col_ G B Bprime)).
Proof.
  time tac.
Qed.

End FOFProblem.