(* Copyright (c) 2006, 2011-2012, 2015, Adam Chlipala
 *
 * This work is licensed under a
 * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
 * Unported License.
 * The license text is available at:
 *   http://creativecommons.org/licenses/by-nc-nd/3.0/
 *)

(* begin hide *)
Require Import Arith List Omega.

Require Import Cpdt.CpdtTactics Cpdt.Coinductive.

Require Extraction.

Set Implicit Arguments.
Set Asymmetric Patterns.
(* end hide *)

(** * Well-Founded Recursion *)

(** The essence of terminating recursion is that there are no infinite chains of nested recursive calls.  This intuition is commonly mapped to the mathematical idea of a%\index{well-founded relation}% _well-founded relation_, and the associated standard technique in Coq is%\index{well-founded recursion}% _well-founded recursion_.  The syntactic-subterm relation that Coq applies by default is well-founded, but many cases demand alternate well-founded relations.  To demonstrate, let us see where we get stuck on attempting a standard merge sort implementation. *)

Section mergeSort.
  Variable A : Type.
  Variable le : A -> A -> bool.

  (** We have a set equipped with some "less-than-or-equal-to" test. *)

  (** A standard function inserts an element into a sorted list, preserving sortedness. *)

  Fixpoint insert (x : A) (ls : list A) : list A :=
    match ls with
      | nil => x :: nil
      | h :: ls' =>
	if le x h
	  then x :: ls
	  else h :: insert x ls'
    end.

  (** We will also need a function to merge two sorted lists.  (We use a less efficient implementation than usual, because the more efficient implementation already forces us to think about well-founded recursion, while here we are only interested in setting up the example of merge sort.) *)

  Fixpoint merge (ls1 ls2 : list A) : list A :=
    match ls1 with
      | nil => ls2
      | h :: ls' => insert h (merge ls' ls2)
    end.

  (** The last helper function for classic merge sort is the one that follows, to split a list arbitrarily into two pieces of approximately equal length. *)

  Fixpoint split (ls : list A) : list A * list A :=
    match ls with
      | nil => (nil, nil)
      | h :: nil => (h :: nil, nil)
      | h1 :: h2 :: ls' =>
	let (ls1, ls2) := split ls' in
	  (h1 :: ls1, h2 :: ls2)
    end.

  (** Now, let us try to write the final sorting function, using a natural number "[<=]" test [leb] from the standard library.
[[
  Fixpoint mergeSort (ls : list A) : list A :=
    if leb (length ls) 1
      then ls
      else let lss := split ls in
	merge (mergeSort (fst lss)) (mergeSort (snd lss)).
]]
<<
Recursive call to mergeSort has principal argument equal to
"fst (split ls)" instead of a subterm of "ls".
>>
The definition is rejected for not following the simple primitive recursion criterion.  In particular, it is not apparent that recursive calls to [mergeSort] are syntactic subterms of the original argument [ls]; indeed, they are not, yet we know this is a well-founded recursive definition.
To produce an acceptable definition, we need to choose a well-founded relation and prove that [mergeSort] respects it.  A good starting point is an examination of how well-foundedness is formalized in the Coq standard library. *)

  Print well_founded.
  (** %\vspace{-.15in}% [[
well_founded =
fun (A : Type) (R : A -> A -> Prop) => forall a : A, Acc R a
]]
The bulk of the definitional work devolves to the%\index{accessibility relation}\index{Gallina terms!Acc}% _accessibility_ relation [Acc], whose definition we may also examine. *)

(* begin hide *)
(* begin thide *)
Definition Acc_intro' := Acc_intro.
(* end thide *)
(* end hide *)

  Print Acc.
(** %\vspace{-.15in}% [[
Inductive Acc (A : Type) (R : A -> A -> Prop) (x : A) : Prop :=
    Acc_intro : (forall y : A, R y x -> Acc R y) -> Acc R x
]]
In prose, an element [x] is accessible for a relation [R] if every element "less than" [x] according to [R] is also accessible.  Since [Acc] is defined inductively, we know that any accessibility proof involves a finite chain of invocations, in a certain sense that we can make formal.  Building on Chapter 5's examples, let us define a co-inductive relation that is closer to the usual informal notion of "absence of infinite decreasing chains." *)

  CoInductive infiniteDecreasingChain A (R : A -> A -> Prop) : stream A -> Prop :=
  | ChainCons : forall x y s, infiniteDecreasingChain R (Cons y s)
    -> R y x
    -> infiniteDecreasingChain R (Cons x (Cons y s)).

(** We can now prove that any accessible element cannot be the beginning of any infinite decreasing chain. *)

(* begin thide *)
  Lemma noBadChains' : forall A (R : A -> A -> Prop) x, Acc R x
    -> forall s, ~infiniteDecreasingChain R (Cons x s).
    induction 1; crush;
      match goal with
        | [ H : infiniteDecreasingChain _ _ |- _ ] => inversion H; eauto
      end.
  Qed.

(** From here, the absence of infinite decreasing chains in well-founded sets is immediate. *)

  Theorem noBadChains : forall A (R : A -> A -> Prop), well_founded R
    -> forall s, ~infiniteDecreasingChain R s.
    destruct s; apply noBadChains'; auto.
  Qed.
(* end thide *)

(** Absence of infinite decreasing chains implies absence of infinitely nested recursive calls, for any recursive definition that respects the well-founded relation.  The [Fix] combinator from the standard library formalizes that intuition: *)

  Check Fix.

(*
forall (A : Type) (R : A -> A -> Prop) (P : A -> Prop),
(forall x : A, (forall y : A, R y x -> Acc R y) -> (forall y : A, R y x -> P y) -> P x) ->
(forall x : A, Acc R x -> P x)
 *)

(** %\vspace{-.15in}%[[
Fix
     : forall (A : Type) (R : A -> A -> Prop),
       well_founded R ->
       forall P : A -> Type,
       (forall x : A, (forall y : A, R y x -> P y) -> P x) ->
       forall x : A, P x
]]
A call to %\index{Gallina terms!Fix}%[Fix] must present a relation [R] and a proof of its well-foundedness.  The next argument, [P], is the possibly dependent range type of the function we build; the domain [A] of [R] is the function's domain.  The following argument has this type:
[[
       forall x : A, (forall y : A, R y x -> P y) -> P x
]]
This is an encoding of the function body.  The input [x] stands for the function argument, and the next input stands for the function we are defining.  Recursive calls are encoded as calls to the second argument, whose type tells us it expects a value [y] and a proof that [y] is "less than" [x], according to [R].  In this way, we enforce the well-foundedness restriction on recursive calls.
The rest of [Fix]'s type tells us that it returns a function of exactly the type we expect, so we are now ready to use it to implement [mergeSort].  Careful readers may have noticed that [Fix] has a dependent type of the sort we met in the previous chapter.
Before writing [mergeSort], we need to settle on a well-founded relation.  The right one for this example is based on lengths of lists. *)

(*  Fix_F =  *)
(* fun (A : Type) (R : A -> A -> Prop) (P : A -> Type) *)
(*   (F : forall x : A, (forall y : A, R y x -> P y) -> P x) => *)
(* fix Fix_F (x : A) (a : Acc R x) {struct a} : P x := *)
(*   F x (fun (y : A) (h : R y x) => Fix_F y (Acc_inv a h)) *)
(*      : forall (A : Type) (R : A -> A -> Prop) (P : A -> Type), *)
(*        (forall x : A, (forall y : A, R y x -> P y) -> P x) -> forall x : A, Acc R x -> P x *)
(* Fix_F P F (Rwf x) *)

  Definition lengthOrder (ls1 ls2 : list A) :=
    length ls1 < length ls2.

  (** We must prove that the relation is truly well-founded.  To save some space in the rest of this chapter, we skip right to nice, automated proof scripts, though we postpone introducing the principles behind such scripts to Part III of the book.  Curious readers may still replace semicolons with periods and newlines to step through these scripts interactively. *)

  Hint Constructors Acc.

  Lemma lengthOrder_wf' : forall len, forall ls, length ls <= len -> Acc lengthOrder ls.
    unfold lengthOrder; induction len; crush.
  Defined.

  Theorem lengthOrder_wf : well_founded lengthOrder.
    red. intro. eapply lengthOrder_wf'. eauto.
  Defined.

  (** Notice that we end these proofs with %\index{Vernacular commands!Defined}%[Defined], not [Qed].  Recall that [Defined] marks the theorems as %\emph{%#<i>#transparent#</i>#%}%, so that the details of their proofs may be used during program execution.  Why could such details possibly matter for computation?  It turns out that [Fix] satisfies the primitive recursion restriction by declaring itself as _recursive in the structure of [Acc] proofs_.  This is possible because [Acc] proofs follow a predictable inductive structure.  We must do work, as in the last theorem's proof, to establish that all elements of a type belong to [Acc], but the automatic unwinding of those proofs during recursion is straightforward.  If we ended the proof with [Qed], the proof details would be hidden from computation, in which case the unwinding process would get stuck.
     To justify our two recursive [mergeSort] calls, we will also need to prove that [split] respects the [lengthOrder] relation.  These proofs, too, must be kept transparent, to avoid stuckness of [Fix] evaluation.  We use the syntax [@foo] to reference identifier [foo] with its implicit argument behavior turned off.  (The proof details below use Ltac features not introduced yet, and they are safe to skip for now.) *)

  Lemma split_wf : forall len ls, 2 <= length ls <= len
    -> let (ls1, ls2) := split ls in
      lengthOrder ls1 ls /\ lengthOrder ls2 ls.
    unfold lengthOrder; induction len; crush; do 2 (destruct ls; crush);
      destruct (le_lt_dec 2 (length ls));
        repeat (match goal with
                  | [ _ : length ?E < 2 |- _ ] => destruct E
                  | [ _ : S (length ?E) < 2 |- _ ] => destruct E
                  | [ IH : _ |- context[split ?L] ] =>
                    specialize (IH L); destruct (split L); destruct IH
                end; crush).
  Defined.

  Ltac split_wf := intros ls ?; intros; generalize (@split_wf (length ls) ls);
    destruct (split ls); destruct 1; crush.

  Lemma split_wf1 : forall ls, 2 <= length ls
    -> lengthOrder (fst (split ls)) ls.
    split_wf.
  Defined.

  Lemma split_wf2 : forall ls, 2 <= length ls
    -> lengthOrder (snd (split ls)) ls.
    split_wf.
  Defined.

  Hint Resolve split_wf1 split_wf2.

  (** To write the function definition itself, we use the %\index{tactics!refine}%[refine] tactic as a convenient way to write a program that needs to manipulate proofs, without writing out those proofs manually.  We also use a replacement [le_lt_dec] for [leb] that has a more interesting dependent type.  (Note that we would not be able to complete the definition without this change, since [refine] will generate subgoals for the [if] branches based only on the _type_ of the test expression, not its _value_.) *)

  Definition mergeSort : list A -> list A.
(* begin thide *)
    refine (Fix lengthOrder_wf (fun _ => list A)
      (fun (ls : list A)
        (mergeSort : forall ls' : list A, lengthOrder ls' ls -> list A) =>
        if le_lt_dec 2 (length ls)
	  then let lss := split ls in
            merge (mergeSort (fst lss) _) (mergeSort (snd lss) _)
	else ls)).
    -
      subst lss. apply split_wf1. assumption.
    -
      subst lss. apply split_wf2. assumption.
  Defined.

  Definition mergeSort'_1 : list A -> list A.
    refine ( fun (ls : list A) =>
               Fix_F (fun _ => list A)
                     (fun (ls : list A)
                          (realRecur : forall ls' : list A, lengthOrder ls' ls -> list A) =>
                        if le_lt_dec 2 (length ls)
                        then
                          let lss := split ls in
                          merge (realRecur (fst lss) _) (realRecur (snd lss) _)
                        else
                          ls) _
           ).
    -
      subst lss. apply split_wf1. assumption.
    -
      subst lss. apply split_wf2. assumption.
    -
      apply (lengthOrder_wf ls).
  Defined.

  Definition mergeSort'' : list A -> list A.
    refine (fun ls : list A =>
              (fix outer (ls : list A) (HAcc : Acc lengthOrder ls) : list A :=
                 (fun (ls : list A) (inner : forall ls', lengthOrder ls' ls -> list A) =>
                    if le_lt_dec 2 (length ls)
                    then
                      let lss := split ls in
                      merge (inner (fst lss) _) (inner (snd lss) _)
                    else
                      ls
                 )
                   ls
                   (fun (ls' : list A) (HR : lengthOrder ls' ls) => outer ls' (Acc_inv HAcc HR))
              ) ls _).
    -
      subst lss. apply split_wf1. assumption.
    -
      subst lss. apply split_wf2. assumption.
    -
      apply (lengthOrder_wf ls).
  Defined.

  (* Definition mergeSort''' : list A -> list A. *)
  (*   refine (fun ls : list A => *)
  (*             (fix outer (ls : list A) : list A := *)
  (*                (fun (ls : list A) (inner : list A -> list A) => *)
  (*                   if leb (length ls) 1 *)
  (*                   then ls *)
  (*                   else *)
  (*                     let lss := split ls in *)
  (*                     merge (inner (fst lss)) (inner (snd lss)) *)
  (*                ) *)
  (*                  ls *)
  (*                  (fun (ls' : list A) => outer ls')                                         *)
  (*             ) *)
  (*               ls).             *)

  Definition mergeSortManual1 : list A -> list A :=
    fun ls : list A =>
      (fix outer (ls0 : list A) (HAcc : Acc lengthOrder ls0) {struct HAcc} :
         list A :=
         (fun (ls1 : list A) (inner : forall ls' : list A, lengthOrder ls' ls1 -> list A) =>
            match le_lt_dec 2 (length ls1) with
            | left x =>
              let lss := split ls1 in
              merge (inner (fst lss) (split_wf1 ls1 x)) (inner (snd lss) (split_wf2 ls1 x))
            | right _ => ls1
            end) ls0 (fun (ls' : list A) (HR : lengthOrder ls' ls0) => outer ls' (Acc_inv HAcc HR))) ls
                                                                                (lengthOrder_wf ls).

  (* Definition mergeSortManual2 : list A -> list A := *)
  (*   fun ls : list A => *)
  (*     (fix outer (ls0 : list A) : list A := *)
  (*        (fun (ls1 : list A) (inner : forall ls' : list A, list A) => *)
  (*           match leb (length ls1) 1 with *)
  (*           | false => *)
  (*             let lss := split ls1 in *)
  (*             merge (inner (fst lss)) (inner (snd lss)) *)
  (*           | true => ls1 *)
  (*           end) ls0 (fun (ls' : list A) => outer ls')) ls. *)

(* end thide *)
End mergeSort.

(** The important thing is that it is now easy to evaluate calls to [mergeSort]. *)

Eval compute in mergeSort leb (1 :: 2 :: 36 :: 8 :: 19 :: nil).
(** [= 1 :: 2 :: 8 :: 19 :: 36 :: nil] *)

(** %\smallskip{}%Since the subject of this chapter is merely how to define functions with unusual recursion structure, we will not prove any further correctness theorems about [mergeSort]. Instead, we stop at proving that [mergeSort] has the expected computational behavior, for all inputs, not merely the one we just tested. *)

(* begin thide *)
Theorem mergeSort_eq : forall A (le : A -> A -> bool) ls,
  mergeSort le ls = if le_lt_dec 2 (length ls)
    then let lss := split ls in
      merge le (mergeSort le (fst lss)) (mergeSort le (snd lss))
    else ls.
  intros; apply (Fix_eq (@lengthOrder_wf A) (fun _ => list A)); intros.

  (** The library theorem [Fix_eq] imposes one more strange subgoal upon us.  We must prove that the function body is unable to distinguish between "self" arguments that map equal inputs to equal outputs.  One might think this should be true of any Gallina code, but in fact this general%\index{extensionality}% _function extensionality_ property is neither provable nor disprovable within Coq.  The type of [Fix_eq] makes clear what we must show manually: *)

  Check Fix_eq.
(** %\vspace{-.15in}%[[
Fix_eq
     : forall (A : Type) (R : A -> A -> Prop) (Rwf : well_founded R)
         (P : A -> Type)
         (F : forall x : A, (forall y : A, R y x -> P y) -> P x),
       (forall (x : A) (f g : forall y : A, R y x -> P y),
        (forall (y : A) (p : R y x), f y p = g y p) -> F x f = F x g) ->
       forall x : A,
       Fix Rwf P F x = F x (fun (y : A) (_ : R y x) => Fix Rwf P F y)
]]
  Most such obligations are dischargeable with straightforward proof automation, and this example is no exception. *)

  match goal with
    | [ |- context[match ?E with left _ => _ | right _ => _ end] ] => destruct E
  end; simpl; f_equal; auto.
Qed.
(* end thide *)

(** As a final test of our definition's suitability, we can extract to OCaml. *)

Extraction mergeSort.

(** <<
let rec mergeSort le x =
  match le_lt_dec (S (S O)) (length x) with
  | Left ->
    let lss = split x in
    merge le (mergeSort le (fst lss)) (mergeSort le (snd lss))
  | Right -> x
>>
  We see almost precisely the same definition we would have written manually in OCaml!  It might be a good exercise for the reader to use the commands we saw in the previous chapter to clean up some remaining differences from idiomatic OCaml.
  One more piece of the full picture is missing.  To go on and prove correctness of [mergeSort], we would need more than a way of unfolding its definition.  We also need an appropriate induction principle matched to the well-founded relation.  Such a principle is available in the standard library, though we will say no more about its details here. *)

Check well_founded_induction.
(** %\vspace{-.15in}%[[
well_founded_induction
     : forall (A : Type) (R : A -> A -> Prop),
       well_founded R ->
       forall P : A -> Set,
       (forall x : A, (forall y : A, R y x -> P y) -> P x) ->
       forall a : A, P a
]]
  Some more recent Coq features provide more convenient syntax for defining recursive functions.  Interested readers can consult the Coq manual about the commands %\index{Function}%[Function] and %\index{Program Fixpoint}%[Program Fixpoint]. *)

Definition Fix_F_manual : forall (A : Type) (R : A -> A -> Prop) (P : A -> Type),
    (forall x : A, (forall y : A, R y x -> P y) -> P x) ->
    forall x : A, Acc R x -> P x :=
  fun (A : Type) (R : A -> A -> Prop) (P : A -> Type)
      (F : forall x : A, (forall y : A, R y x -> P y) -> P x) =>
    fix recur (x : A ) (a : Acc R x) {struct a} : P x :=
    F x (fun (y : A) (h : R y x) => recur y (Acc_inv a h)).

(* Definition Fix_F_manual' : forall (A : Type) (P : A -> Type), *)
(*     (forall x : A, (forall y : A, P y) -> P x) -> *)
(*     forall x : A, P x := *)
(*   fun (A : Type) (P : A -> Type) *)
(*       (F : forall x : A, (forall y : A, P y) -> P x) => *)
(*     fix recur (x : A) : P x := *)
(*     F x (fun (y : A) => recur y). *)

(* Definition Fix_F_manual'' : *)
(*     (forall x : list nat, (forall y : list nat,  list nat) -> list nat) -> *)
(*     forall x : list nat, list nat := *)
(*   fun  (F : forall x : list nat, (forall y : list nat, list nat) -> list nat) => *)
(*     fix recur (x : list nat) : list nat := *)
(*     F x (fun (y : list nat) => recur y). *)

(** * A Non-Termination Monad Inspired by Domain Theory *)

(** The key insights of %\index{domain theory}%domain theory%~\cite{WinskelDomains}% inspire the next approach to modeling non-termination.  Domain theory is based on _information orders_ that relate values representing computation results, according to how much information these values convey.  For instance, a simple domain might include values "the program does not terminate" and "the program terminates with the answer 5."  The former is considered to be an _approximation_ of the latter, while the latter is _not_ an approximation of "the program terminates with the answer 6."  The details of domain theory will not be important in what follows; we merely borrow the notion of an approximation ordering on computation results.
   Consider this definition of a type of computations. *)

Section computation.
  Variable A : Type.
  (** The type [A] describes the result a computation will yield, if it terminates.
     We give a rich dependent type to computations themselves: *)

  Definition computation :=
    {f : nat -> option A
      | forall (n : nat) (v : A),
	f n = Some v
	-> forall (n' : nat), n' >= n
	  -> f n' = Some v}.

  (** A computation is fundamentally a function [f] from an _approximation level_ [n] to an optional result.  Intuitively, higher [n] values enable termination in more cases than lower values.  A call to [f] may return [None] to indicate that [n] was not high enough to run the computation to completion; higher [n] values may yield [Some].  Further, the proof obligation within the subset type asserts that [f] is _monotone_ in an appropriate sense: when some [n] is sufficient to produce termination, so are all higher [n] values, and they all yield the same program result [v].
  It is easy to define a relation characterizing when a computation runs to a particular result at a particular approximation level. *)

  Definition runTo (m : computation) (n : nat) (v : A) :=
    proj1_sig m n = Some v.

  (** On top of [runTo], we also define [run], which is the most abstract notion of when a computation runs to a value. *)

  Definition run (m : computation) (v : A) :=
    exists n, runTo m n v.
End computation.

(** The book source code contains at this point some tactics, lemma proofs, and hint commands, to be used in proving facts about computations.  Since their details are orthogonal to the message of this chapter, I have omitted them in the rendered version. *)
(* begin hide *)

Hint Unfold runTo.

Ltac run' := unfold run, runTo in *; try red; crush;
  repeat (match goal with
            | [ _ : proj1_sig ?E _ = _ |- _ ] =>
              match goal with
                | [ x : _ |- _ ] =>
                  match x with
                    | E => destruct E
                  end
              end
            | [ |- context[match ?M with exist _ _ => _ end] ] => let Heq := fresh "Heq" in
              case_eq M; intros ? ? Heq; try rewrite Heq in *; try subst
            | [ _ : context[match ?M with exist _ _ => _ end] |- _ ] => let Heq := fresh "Heq" in
              case_eq M; intros ? ? Heq; try rewrite Heq in *; subst
            | [ H : forall n v, ?E n = Some v -> _,
                _ : context[match ?E ?N with Some _ => _ | None => _ end] |- _ ] =>
              specialize (H N); destruct (E N); try rewrite (H _ (eq_refl _)) by auto; try discriminate
            | [ H : forall n v, ?E n = Some v -> _, H' : ?E _ = Some _ |- _ ] => rewrite (H _ _ H') by auto
          end; simpl in *); eauto 7.

Ltac run := run'; repeat (match goal with
                            | [ H : forall n v, ?E n = Some v -> _
                                |- context[match ?E ?N with Some _ => _ | None => _ end] ] =>
                              specialize (H N); destruct (E N); try rewrite (H _ (eq_refl _)) by auto; try discriminate
                          end; run').

Lemma ex_irrelevant : forall P : Prop, P -> exists n : nat, P.
  exists 0; auto.
Qed.

Hint Resolve ex_irrelevant.

Require Import Max.

Theorem max_spec_le : forall n m, n <= m /\ max n m = m \/ m <= n /\ max n m = n.
  induction n; destruct m; simpl; intuition;
    specialize (IHn m); intuition.
Qed.

Ltac max := intros n m; generalize (max_spec_le n m); crush.

Lemma max_1 : forall n m, max n m >= n.
  max.
Qed.

Lemma max_2 : forall n m, max n m >= m.
  max.
Qed.

Hint Resolve max_1 max_2.

Lemma ge_refl : forall n, n >= n.
  crush.
Qed.

Hint Resolve ge_refl.

Hint Extern 1 => match goal with
                   | [ H : _ = exist _ _ _ |- _ ] => rewrite H
                 end.
(* end hide *)
(** remove printing exists *)

(** Now, as a simple first example of a computation, we can define [Bottom], which corresponds to an infinite loop.  For any approximation level, it fails to terminate (returns [None]).  Note the use of [abstract] to create a new opaque lemma for the proof found by the #<tt>#%\coqdocvar{%run%}%#</tt># tactic.  In contrast to the previous section, opaque proofs are fine here, since the proof components of computations do not influence evaluation behavior.  It is generally preferable to make proofs opaque when possible, as this enforces a kind of modularity in the code to follow, preventing it from depending on any details of the proof. *)

Section Bottom.
  Variable A : Type.

  Definition Bottom : computation A.
    exists (fun _ : nat => @None A); abstract run.
  Defined.

  Definition Bottom_manual : computation A.
    refine (exist _ (fun _ : nat => @None A) _).
    intros. assumption.
  Qed.

  Theorem run_Bottom : forall v, ~run Bottom v.
    run.
  Qed.

  Theorem run_Bottom_manual : forall v, run Bottom v -> False.
    unfold run. unfold runTo. intros.
    destruct H. simpl in H. inversion H.
  Qed.

End Bottom.

(** A slightly more complicated example is [Return], which gives the same terminating answer at every approximation level. *)

Section Return.
  Variable A : Type.
  Variable v : A.

  Definition Return : computation A.
    intros; exists (fun _ : nat => Some v); abstract run.
  Defined.

  Definition Return_manual : computation A.
    refine (exist _ (fun _ : nat => Some v) _).
    intros. assumption.
  Qed.

  Theorem run_Return : run Return v.
    run.
  Qed.

  Theorem run_Return_manualo : run Return v.
    unfold run. exists 0. unfold runTo. reflexivity.
  Qed.

End Return.

(** The name [Return] was meant to be suggestive of the standard operations of %\index{monad}%monads%~\cite{Monads}%.  The other standard operation is [Bind], which lets us run one computation and, if it terminates, pass its result off to another computation.  We implement bind using the notation [let (x, y) := e1 in e2], for pulling apart the value [e1] which may be thought of as a pair.  The second component of a [computation] is a proof, which we do not need to mention directly in the definition of [Bind]. *)

Section Bind.
  Variables A B : Type.
  Variable m1 : computation A.
  Variable m2 : A -> computation B.

  Definition Bind : computation B.
    exists (fun n =>
      let (f1, _) := m1 in
      match f1 n with
	| None => None
	| Some v =>
	  let (f2, _) := m2 v in
	    f2 n
      end); abstract run.
  Defined.

  Definition Bind_manual : computation B.
    refine (exist _ (fun n =>
                       let (f1, _) := m1 in
                       match f1 n with
                       | Some v =>
                         let (f2, _) := m2 v in
                         f2 n
                       | None => None
                       end
                    ) _ ).
    destruct m1.
    intros.
    destruct (x n) eqn:Heq.
    -
      assert (H' : x n' = Some a). eauto.
      rewrite H'.
      destruct (m2 a).
      eauto.
    -
      inversion H.
  Defined.

  Theorem run_Bind : forall (v1 : A) (v2 : B),
    run m1 v1
    -> run (m2 v1) v2
    -> run Bind v2.
    run; match goal with
           | [ x : nat, y : nat |- _ ] => exists (max x y)
         end; run.
  Qed.

  Theorem run_Bind_manual : forall (v1 : A) (v2 : B),
      run m1 v1 ->
      run (m2 v1) v2 ->
      run Bind v2.
    intros.
    destruct H as [x1 H1]. destruct H0 as [x2 H2].
    exists (x1 + x2).
    unfold runTo. unfold Bind. simpl.
    destruct m1 as [f1 e1].
    unfold runTo in H1; simpl in H1.
    assert (H1' : f1 (x1 + x2) = Some v1).
    apply e1 with x1. assumption. omega.
    rewrite H1'.
    destruct (m2 v1) as [f2 e2].
    unfold runTo in H2; simpl in H2.
    apply e2 with x2. assumption. omega.
  Qed.

End Bind.

(** A simple notation lets us write [Bind] calls the way they appear in Haskell. *)

Notation "x <- m1 ; m2" :=
  (Bind m1 (fun x => m2)) (right associativity, at level 70).

(** We can verify that we have indeed defined a monad, by proving the standard monad laws.  Part of the exercise is choosing an appropriate notion of equality between computations.  We use "equality at all approximation levels." *)

Definition meq A (m1 m2 : computation A) := forall n, proj1_sig m1 n = proj1_sig m2 n.

Theorem left_identity : forall A B (a : A) (f : A -> computation B),
  meq (Bind (Return a) f) (f a).
  run.
Qed.

Theorem left_identity_manual : forall A B (a : A) (f : A -> computation B),
    meq (Bind (Return a) f) (f a).
  intros. unfold meq. intros. simpl.
  destruct (f a) as [f' e'].
  reflexivity.
Qed.

Theorem right_identity : forall A (m : computation A),
  meq (Bind m (@Return _)) m.
  run.
Qed.

Theorem right_identity_manual : forall A (m : computation A),
    meq (Bind m (@Return A)) m.
  intros. unfold meq. intros. simpl.
  destruct m. simpl. destruct (x n).
  reflexivity. reflexivity.
Qed.

Theorem associativity : forall A B C (m : computation A)
  (f : A -> computation B) (g : B -> computation C),
  meq (Bind (Bind m f) g) (Bind m (fun x => Bind (f x) g)).
  run.
Qed.

Theorem associativity_manual : forall A B C (m : computation A)
                                      (f : A -> computation B) (g : B -> computation C),
    meq (Bind (Bind m f) g) (Bind m (fun x => Bind (f x) g)).
  intros.  unfold meq. intros. simpl.
  destruct m as [f_m H_m].
  destruct (f_m n) eqn:HEq.
  -
    destruct (f a) as [f_f H_f].
    reflexivity.
  -
    reflexivity.
Qed.

Section Lattice.
  Variables A : Type.

  Definition leq (x y : option A) :=
    forall v : A, x = Some v -> y = Some v.
End Lattice.

Section Fix.
  Variables A B : Type.

  Variable f : (A -> computation B) -> (A -> computation B).

  Hypothesis f_continuous :
    forall v1 n x v, runTo (f v1 x) n v ->
                     forall (v2 : A -> computation B), (forall x : A, leq (proj1_sig (v1 x) n) (proj1_sig (v2 x) n)) ->
                                runTo (f v2 x) n v.

  Fixpoint Fix' (n : nat) (x : A) : (computation B) :=
    match n with
    | 0 => Bottom _
    | S n' => f (Fix' n') x
    end.

  Lemma Fix'_ok : forall steps n x v,
      proj1_sig (Fix' n x) steps = Some v ->
      forall n', n' >= n -> proj1_sig (Fix' n' x) steps = Some v.
  Proof.
    induction n.
    -
      (* P 0 *)
      intros; inversion H.
    -
      (* P n -> P (S n) *)
      intros. destruct n'.
      +
        (* n' = 0 *)
        inversion H0.
      +
        (* n' = S n *)
        simpl.
        apply f_continuous with (Fix' n).  (* analyze with f_continous *)
        * simpl in H. assumption. (* trivial *)
        * unfold leq. intros. apply IHn. assumption. omega. (* trivial after proving leq *)
  Qed.

  Definition Fix : A -> computation B.
    refine (fun x : A => exist _ (fun n : nat => proj1_sig (Fix' n x) n) _).
    intros.
    assert(HCrit : proj1_sig (Fix' n' x) n = Some v).
    {
      apply (@Fix'_ok n n x v H) in H0.
      assumption.
    }
    destruct (Fix' n' x).
    eauto.
  Defined.

  Theorem Fix_ok : forall x v,
      run (f Fix x) v -> run (Fix x) v.
    intros. destruct H as [n].
    assert(HCrit : runTo (f (Fix' n) x) n v).
    {
      apply f_continuous with Fix.
      assumption.
      simpl. unfold leq. intros.
      destruct n.
      -
        inversion H0.
      -
        assumption.
    }
    exists (S n). unfold runTo. simpl.
    destruct (f (Fix' n) x).
    unfold runTo in HCrit; simpl in HCrit.
    simpl.
    apply e with n. assumption. omega.
  Qed.

End Fix.

Definition mergeSort' : forall (A : Type) (le : A -> A -> bool),  (list A) -> computation (list A).
  refine ( fun (A : Type) (le : A -> A -> bool) =>
      Fix (fun (mergeSortRec : (list A) -> computation (list A)) (ls : list A) =>
                 match le_lt_dec 2 (length ls) with
                 | left _ =>
                   let lss := split ls in
                   ls1 <- mergeSortRec (fst lss);
                   ls2 <- mergeSortRec (snd lss);
                   Return (merge le ls1 ls2)
                 | right _ =>
                   Return ls
                 end) _).
  intros.
  destruct (le_lt_dec 2 (length x)).
  -
    unfold runTo; simpl.
    unfold runTo in H; simpl in H.
    unfold leq in H0.
    assert(H1 : forall v : list A, proj1_sig (v1 (fst (split x))) n = Some v -> proj1_sig (v2 (fst (split x))) n = Some v). apply H0.
    assert(H2 : forall v : list A, proj1_sig (v1 (snd (split x))) n = Some v -> proj1_sig (v2 (snd (split x))) n = Some v). apply H0.
    destruct (v1 (fst (split x))) as [f1_1 e1_1].
    destruct (v1 (snd (split x))) as [f1_2 e1_2].
    destruct (v2 (fst (split x))) as [f2_1 e2_1].
    destruct (v2 (snd (split x))) as [f2_2 e2_2].
    destruct (f1_1 n) eqn:Eqn_f1_1.
    +
      simpl in H1.
      apply H1 in Eqn_f1_1.
      rewrite Eqn_f1_1.
      destruct (f1_2 n) eqn:Eqn_f2_2.
      *
        simpl in H2.
        apply H2 in Eqn_f2_2.
        rewrite Eqn_f2_2.
        assumption.
      *
        inversion H.
    +
      inversion H.
  -
    assumption.
Defined.

Lemma testMergeSort' : run (mergeSort' leb (1 :: 2 :: 36:: 8 :: 19 :: nil)) (1 :: 2 :: 8 :: 19 :: 36 :: nil).
  exists 4. reflexivity.
Qed.

Definition looper : bool -> computation unit.
  refine (Fix (fun looper (b:bool) =>
                 if b then Return tt else looper b) _).
  intros.
  destruct x.
  -
    assumption.
  -
    unfold leq in H0. unfold runTo in H.
    apply H0 in H.
    unfold runTo. assumption.
Defined.

Lemma test_looper : run (looper true) tt.
  exists 1; reflexivity.
Qed.

CoInductive thunk (A : Type) : Type :=
| Answer : A -> thunk A
| Think : thunk A -> thunk A.

CoFixpoint TBind A B (m1 : thunk A) (m2 : A -> thunk B) : thunk B :=
  match m1 with
    | Answer x => m2 x
    | Think m1' => Think (TBind m1' m2)
  end.

CoInductive thunk_eq A : thunk A -> thunk A -> Prop :=
| EqAnswer : forall x, thunk_eq (Answer x) (Answer x)
| EqThinkL : forall m1 m2, thunk_eq m1 m2 -> thunk_eq (Think m1) m2
| EqThinkR : forall m1 m2, thunk_eq m1 m2 -> thunk_eq m1 (Think m2).

Section thunk_eq_coind.
  Variable A : Type.
  Variable P : thunk A -> thunk A -> Prop.

  Hypothesis H : forall m1 m2, P m1 m2
    -> match m1, m2 with
         | Answer x1, Answer x2 => x1 = x2
         | Think m1', Think m2' => P m1' m2'
         | Think m1', _ => P m1' m2
         | _, Think m2' => P m1 m2'
       end.

  Theorem thunk_eq_coind : forall m1 m2, P m1 m2 -> thunk_eq m1 m2.
    cofix thunk_eq_coind; intros;
      match goal with
        | [ H' : P _ _ |- _ ] => specialize (H H'); clear H'
      end; destruct m1; destruct m2; subst; repeat constructor; auto.
  Qed.
End thunk_eq_coind.

Definition frob A (m : thunk A) : thunk A :=
  match m with
    | Answer x => Answer x
    | Think m' => Think m'
  end.

Theorem frob_eq : forall A (m : thunk A), frob m = m.
  destruct m; reflexivity.
Qed.

CoFixpoint fact (n acc : nat) : thunk nat :=
  match n with
  | 0 => Answer acc
  | S n' => Think (fact n' (n * acc))
  end.

Inductive eval A : thunk A -> A -> Prop :=
| EvalAnswer : forall x : A, eval (Answer x) x
| EvalThink : forall t x, eval t x -> eval (Think t) x.

Theorem eval_frob : forall A (t : thunk A) (x : A),
    eval (frob t) x -> eval t x.
  intros. rewrite (frob_eq t) in H. assumption.
Qed.

Theorem eval_fact : eval (fact 5 1) 120.
  repeat (apply eval_frob; simpl; constructor).
Qed.

Notation "x <- m1 ; m2" := (TBind m1 (fun x => m2)) (right associativity, at level 70).

(* This is unguarded *)
(* CoFixpoint fib (n : nat) : thunk nat := *)
(*   match n with *)
(*   | O => Answer 0 *)
(*   | S O => Answer 1 *)
(*   | _ => *)
(*     Think ( *)
(*         fst <- fib (n - 1); *)
(*       snd <- fib (n - 2); *)
(*       Answer (fst + snd) ) *)
(*   end. *)

CoFixpoint fib_sub (m n prevprev prev : nat) : thunk nat :=
  match n with
  | 0 => Answer 0
  | 1 => Answer 1
  | _ =>
    if beq_nat m n
    then Answer (prevprev + prev)
    else Think (fib_sub (m + 1) n (prev) (prevprev + prev))
  end.

Definition fib (n : nat) : thunk nat :=
  fib_sub 2 n 0 1.

Theorem fib_correct : eval (fib 5) 5.
  apply eval_frob.
  repeat (apply eval_frob; simpl; constructor).
Qed.

CoInductive comp A : Type :=
| Ret : A -> comp A
| Bnd : forall B, comp B -> (B -> comp A) -> comp A.

Inductive exec A : comp A -> A -> Prop :=
| ExecRet : forall x : A, exec (Ret x) x
| ExecBnd : forall (B : Type) (m1 : comp B) (x : B) (m2 : B -> comp A) (y : A),
    exec (A := B) m1 x -> exec (m2 x) y ->  exec (Bnd m1 m2) y.

Notation "x <- m1 ; m2" := (Bnd m1 (fun x => m2)) (right associativity, at level 70).

CoFixpoint mergeSort''' A (le : A -> A -> bool) (ls : list A) : comp (list A) :=
  if le_lt_dec 2 (length ls)
  then
    let lss := split ls in
    ls1 <- mergeSort''' le (fst lss);
    ls2 <- mergeSort''' le (snd lss);
    Ret (merge le ls1 ls2)
  else
    Ret ls.

Definition frob_comp A (m : comp A) : comp A :=
  match m with
  | Ret x => Ret x
  | Bnd B m1 m2 => Bnd m1 m2
  end.

Theorem frob_comp_eq : forall A (m : comp A), frob_comp m = m.
  destruct m; reflexivity.
Qed.

Theorem exec_equal : forall A (m : comp A) (x : A),
    exec (frob_comp m) x -> exec m x.
  intros. rewrite frob_comp_eq in H. assumption.
Qed.

Lemma testMergeSort''' : exec (mergeSort''' leb (1 :: 2 :: 36 :: 8 :: 19 :: nil)) (1 :: 2 :: 8 :: 19 :: 36 :: nil).
  repeat(apply exec_equal; simpl; econstructor).
Qed.

Definition curriedAdd (n : nat) := Ret (fun m : nat => Ret (n + m)).

Definition testCurriedAdd := Bnd (curriedAdd 2) (fun f => f 3).

Lemma testCurriedAdd' : exec testCurriedAdd 5.
  unfold testCurriedAdd.
  repeat (apply exec_equal; simpl; econstructor).
Qed.


From Coq Require Import ZArith ZifyClasses ZifyBool.
From Coq Require Export Lia.

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path.
From mathcomp Require Import div choice fintype tuple finfun bigop finset prime.
From mathcomp Require Import order binomial ssralg countalg ssrnum ssrint rat.
From mathcomp Require Import intdiv.
From mathcomp Require Import zify_ssreflect ssrZ.

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

Module AlgebraZifyInstances.

Local Delimit Scope Z_scope with Z.

Import Order.Theory GRing.Theory Num.Theory SsreflectZifyInstances.

(******************************************************************************)
(* ssrint                                                                     *)
(******************************************************************************)

#[global]
Instance Inj_int_Z : InjTyp int Z :=
  { inj := Z_of_int; pred _ := True; cstr _ := I }.
Add Zify InjTyp Inj_int_Z.

#[global]
Instance Op_Z_of_int : UnOp Z_of_int := { TUOp := id; TUOpInj _ := erefl }.
Add Zify UnOp Op_Z_of_int.

#[global]
Instance Op_int_of_Z : UnOp int_of_Z := { TUOp := id; TUOpInj := int_of_ZK }.
Add Zify UnOp Op_int_of_Z.

#[global]
Instance Op_Posz : UnOp Posz := { TUOp := id; TUOpInj _ := erefl }.
Add Zify UnOp Op_Posz.

#[global]
Instance Op_Negz : UnOp Negz :=
  { TUOp x := (- (x + 1))%Z; TUOpInj := ltac:(simpl; lia) }.
Add Zify UnOp Op_Negz.

#[global]
Instance Op_int_eq : BinRel (@eq int) :=
  { TR := @eq Z; TRInj := ltac:(by split=> [->|/(can_inj Z_of_intK)]) }.
Add Zify BinRel Op_int_eq.

#[global]
Instance Op_int_eq_op : BinOp (@eq_op int_eqType : int -> int -> bool) :=
  { TBOp := Z.eqb;
    TBOpInj := ltac:(move=> [] ? [] ?; do 2 rewrite eqE /=; lia) }.
Add Zify BinOp Op_int_eq_op.

#[global]
Instance Op_int_0 : CstOp (0%R : int) := { TCst := 0%Z; TCstInj := erefl }.
Add Zify CstOp Op_int_0.

#[global]
Instance Op_addz : BinOp intZmod.addz := { TBOp := Z.add; TBOpInj := raddfD _ }.
Add Zify BinOp Op_addz.

#[global]
Instance Op_int_add : BinOp +%R := Op_addz.
Add Zify BinOp Op_int_add.

#[global]
Instance Op_oppz : UnOp intZmod.oppz := { TUOp := Z.opp; TUOpInj := raddfN _ }.
Add Zify UnOp Op_oppz.

#[global]
Instance Op_int_opp : UnOp (@GRing.opp _) := Op_oppz.
Add Zify UnOp Op_int_opp.

#[global]
Instance Op_int_1 : CstOp (1%R : int) := { TCst := 1%Z; TCstInj := erefl }.
Add Zify CstOp Op_int_1.

#[global]
Instance Op_mulz : BinOp intRing.mulz :=
  { TBOp := Z.mul; TBOpInj := rmorphM _ }.
Add Zify BinOp Op_mulz.

#[global]
Instance Op_int_mulr : BinOp *%R := Op_mulz.
Add Zify BinOp Op_int_mulr.

#[global]
Instance Op_int_natmul : BinOp (@GRing.natmul _ : int -> nat -> int) :=
  { TBOp := Z.mul; TBOpInj _ _ := ltac:(rewrite /= pmulrn mulrzz; lia) }.
Add Zify BinOp Op_int_natmul.

#[global]
Instance Op_int_intmul : BinOp ( *~%R%R : int -> int -> int) :=
  { TBOp := Z.mul; TBOpInj _ _ := ltac:(rewrite /= mulrzz; lia) }.
Add Zify BinOp Op_int_intmul.

#[global]
Instance Op_int_scale : BinOp (@GRing.scale _ [lmodType int of int^o]) :=
  Op_mulz.
Add Zify BinOp Op_int_scale.

Fact Op_int_exp_subproof n m : Z_of_int (n ^+ m) = (Z_of_int n ^ Z.of_nat m)%Z.
Proof. rewrite -Zpower_nat_Z; elim: m => //= m <-; rewrite exprS; lia. Qed.

#[global]
Instance Op_int_exp : BinOp (@GRing.exp _ : int -> nat -> int) :=
  { TBOp := Z.pow; TBOpInj := Op_int_exp_subproof }.
Add Zify BinOp Op_int_exp.

#[global]
Instance Op_unitz : UnOp (has_quality 1 intUnitRing.unitz : int -> bool) :=
  { TUOp x := (x =? 1)%Z || (x =? - 1)%Z; TUOpInj := ltac:(simpl; lia) }.
Add Zify UnOp Op_unitz.

#[global]
Instance Op_int_unit : UnOp (has_quality 1 GRing.unit) := Op_unitz.
Add Zify UnOp Op_int_unit.

#[global]
Instance Op_invz : UnOp intUnitRing.invz :=
  { TUOp := id; TUOpInj _ := erefl }.
Add Zify UnOp Op_invz.

#[global]
Instance Op_int_inv : UnOp GRing.inv := Op_invz.
Add Zify UnOp Op_int_inv.

#[global]
Instance Op_absz : UnOp absz :=
  { TUOp := Z.abs; TUOpInj := ltac:(case=> ? /=; lia) }.
Add Zify UnOp Op_absz.

#[global]
Instance Op_int_normr : UnOp (Num.norm : int -> int) :=
  { TUOp := Z.abs; TUOpInj := ltac:(rewrite /Num.norm /=; lia) }.
Add Zify UnOp Op_int_normr.

#[global]
Instance Op_lez : BinOp intOrdered.lez :=
  { TBOp := Z.leb; TBOpInj := ltac:(case=> ? [] ? /=; lia) }.
Add Zify BinOp Op_lez.

#[global]
Instance Op_ltz : BinOp intOrdered.ltz :=
  { TBOp := Z.ltb; TBOpInj := ltac:(case=> ? [] ? /=; lia) }.
Add Zify BinOp Op_ltz.

#[global]
Instance Op_int_sgr : UnOp (Num.sg : int -> int) :=
  { TUOp := Z.sgn; TUOpInj := ltac:(case=> [[]|] //=; lia) }.
Add Zify UnOp Op_int_sgr.

#[global]
Instance Op_int_sgz : UnOp (@sgz _) := Op_int_sgr.
Add Zify UnOp Op_int_sgz.

#[global]
Instance Op_int_le : BinOp <=%O := Op_lez.
Add Zify BinOp Op_int_le.

#[global]
Instance Op_int_le' : BinOp (>=^d%O : rel int^d) := Op_lez.
Add Zify BinOp Op_int_le'.

#[global]
Instance Op_int_ge : BinOp (>=%O : int -> int -> bool) :=
  { TBOp := Z.geb; TBOpInj := ltac:(simpl; lia) }.
Add Zify BinOp Op_int_ge.

#[global]
Instance Op_int_ge' : BinOp (<=^d%O : rel int^d) := Op_int_ge.
Add Zify BinOp Op_int_ge'.

#[global]
Instance Op_int_lt : BinOp <%O := Op_ltz.
Add Zify BinOp Op_int_lt.

#[global]
Instance Op_int_lt' : BinOp (>^d%O : rel int^d) := Op_ltz.
Add Zify BinOp Op_int_lt'.

#[global]
Instance Op_int_gt : BinOp (>%O : int -> int -> bool) :=
  { TBOp := Z.gtb; TBOpInj := ltac:(simpl; lia) }.
Add Zify BinOp Op_int_gt.

#[global]
Instance Op_int_gt' : BinOp (<^d%O : rel int^d) := Op_int_gt.
Add Zify BinOp Op_int_gt'.

#[global]
Instance Op_int_min : BinOp (Order.min : int -> int -> int) :=
  { TBOp := Z.min; TBOpInj _ _ := ltac:(case: leP => /=; lia) }.
Add Zify BinOp Op_int_min.

#[global]
Instance Op_int_min' : BinOp ((Order.max : int^d -> _) : int -> int -> int) :=
  { TBOp := Z.min; TBOpInj _ _ := ltac:(case: leP => /=; lia) }.
Add Zify BinOp Op_int_min'.

#[global]
Instance Op_int_max : BinOp (Order.max : int -> int -> int) :=
  { TBOp := Z.max; TBOpInj _ _ := ltac:(case: leP => /=; lia) }.
Add Zify BinOp Op_int_max.

#[global]
Instance Op_int_max' : BinOp ((Order.min : int^d -> _) : int -> int -> int) :=
  { TBOp := Z.max; TBOpInj _ _ := ltac:(case: leP => /=; lia) }.
Add Zify BinOp Op_int_max'.

#[global]
Instance Op_int_meet : BinOp (Order.meet : int -> int -> int) :=
  { TBOp := Z.min; TBOpInj _ _ := ltac:(case: leP => /=; lia) }.
Add Zify BinOp Op_int_meet.

#[global]
Instance Op_int_meet' : BinOp (Order.join : int^d -> _) := Op_int_min.
Add Zify BinOp Op_int_meet'.

#[global]
Instance Op_int_join : BinOp (Order.join : int -> int -> int) :=
  { TBOp := Z.max; TBOpInj _ _ := ltac:(case: leP => /=; lia) }.
Add Zify BinOp Op_int_join.

#[global]
Instance Op_int_join' : BinOp (Order.meet : int^d -> _) := Op_int_max.
Add Zify BinOp Op_int_join'.

(******************************************************************************)
(* ssrZ                                                                       *)
(******************************************************************************)

#[global]
Instance Op_Z_eq_op : BinOp (eq_op : Z -> Z -> bool) := Op_Zeqb.
Add Zify BinOp Op_Z_eq_op.

#[global]
Instance Op_Z_0 : CstOp (0%R : Z) := { TCst := 0%Z; TCstInj := erefl }.
Add Zify CstOp Op_Z_0.

#[global]
Instance Op_Z_add : BinOp (+%R : Z -> Z -> Z) :=
  { TBOp := Z.add; TBOpInj _ _ := erefl }.
Add Zify BinOp Op_Z_add.

#[global]
Instance Op_Z_opp : UnOp (@GRing.opp _ : Z -> Z) :=
  { TUOp := Z.opp; TUOpInj _ := erefl }.
Add Zify UnOp Op_Z_opp.

#[global]
Instance Op_Z_1 : CstOp (1%R : Z) := { TCst := 1%Z; TCstInj := erefl }.
Add Zify CstOp Op_Z_1.

#[global]
Instance Op_Z_mulr : BinOp ( *%R : Z -> Z -> Z) :=
  { TBOp := Z.mul; TBOpInj _ _ := erefl }.
Add Zify BinOp Op_Z_mulr.

Fact Op_Z_natmul_subproof (n : Z) (m : nat) : (n *+ m)%R = (n * Z.of_nat m)%Z.
Proof. elim: m => [|m]; rewrite (mulr0n, mulrS); lia. Qed.

#[global]
Instance Op_Z_natmul : BinOp (@GRing.natmul _ : Z -> nat -> Z) :=
  { TBOp := Z.mul; TBOpInj := Op_Z_natmul_subproof }.
Add Zify BinOp Op_Z_natmul.

#[global]
Instance Op_Z_intmul : BinOp ( *~%R%R : Z -> int -> Z) :=
  { TBOp := Z.mul; TBOpInj := ltac:(move=> n [] m; rewrite /intmul /=; lia) }.
Add Zify BinOp Op_Z_intmul.

#[global]
Instance Op_Z_scale : BinOp (@GRing.scale _ [lmodType Z of Z^o]) := Op_Z_mulr.
Add Zify BinOp Op_Z_scale.

Fact Op_Z_exp_subproof n m : (n ^+ m)%R = (n ^ Z.of_nat m)%Z.
Proof. by rewrite -Zpower_nat_Z; elim: m => //= m <-; rewrite exprS. Qed.

#[global]
Instance Op_Z_exp : BinOp (@GRing.exp _ : Z -> nat -> Z) :=
  { TBOp := Z.pow; TBOpInj := Op_Z_exp_subproof }.
Add Zify BinOp Op_Z_exp.

#[global]
Instance Op_unitZ : UnOp (has_quality 1 ZInstances.unitZ : Z -> bool) :=
  { TUOp x := (x =? 1)%Z || (x =? - 1)%Z; TUOpInj _ := erefl }.
Add Zify UnOp Op_unitZ.

#[global]
Instance Op_Z_unit : UnOp (has_quality 1 GRing.unit : Z -> bool) := Op_unitZ.
Add Zify UnOp Op_Z_unit.

#[global]
Instance Op_invZ : UnOp ZInstances.invZ := { TUOp := id; TUOpInj _ := erefl }.
Add Zify UnOp Op_invZ.

#[global]
Instance Op_Z_inv : UnOp (GRing.inv : Z -> Z) :=
  { TUOp := id; TUOpInj _ := erefl }.
Add Zify UnOp Op_Z_inv.

#[global]
Instance Op_Z_normr : UnOp (Num.norm : Z -> Z) :=
  { TUOp := Z.abs; TUOpInj _ := erefl }.
Add Zify UnOp Op_Z_normr.

#[global]
Instance Op_Z_sgr : UnOp (Num.sg : Z -> Z) :=
  { TUOp := Z.sgn; TUOpInj := ltac:(case=> //=; lia) }.
Add Zify UnOp Op_Z_sgr.

#[global]
Instance Op_Z_le : BinOp (<=%O : Z -> Z -> bool) :=
  { TBOp := Z.leb; TBOpInj _ _ := erefl }.
Add Zify BinOp Op_Z_le.

#[global]
Instance Op_Z_le' : BinOp (>=^d%O : rel Z^d) := Op_Z_le.
Add Zify BinOp Op_Z_le'.

#[global]
Instance Op_Z_ge : BinOp (>=%O : Z -> Z -> bool) :=
  { TBOp := Z.geb; TBOpInj := ltac:(simpl; lia) }.
Add Zify BinOp Op_Z_ge.

#[global]
Instance Op_Z_ge' : BinOp (<=^d%O : rel Z^d) := Op_Z_ge.
Add Zify BinOp Op_Z_ge'.

#[global]
Instance Op_Z_lt : BinOp (<%O : Z -> Z -> bool) :=
  { TBOp := Z.ltb; TBOpInj _ _ := erefl }.
Add Zify BinOp Op_Z_lt.

#[global]
Instance Op_Z_lt' : BinOp (>^d%O : rel Z^d) := Op_Z_lt.
Add Zify BinOp Op_Z_lt'.

#[global]
Instance Op_Z_gt : BinOp (>%O : Z -> Z -> bool) :=
  { TBOp := Z.gtb; TBOpInj := ltac:(simpl; lia) }.
Add Zify BinOp Op_Z_gt.

#[global]
Instance Op_Z_gt' : BinOp (<^d%O : rel Z^d) := Op_Z_gt.
Add Zify BinOp Op_Z_gt'.

#[global]
Instance Op_Z_min : BinOp (Order.min : Z -> Z -> Z) :=
  { TBOp := Z.min; TBOpInj _ _ := ltac:(case: leP => /=; lia) }.
Add Zify BinOp Op_Z_min.

#[global]
Instance Op_Z_min' : BinOp ((Order.max : Z^d -> _) : Z -> Z -> Z) :=
  { TBOp := Z.min; TBOpInj _ _ := ltac:(case: leP => /=; lia) }.
Add Zify BinOp Op_Z_min'.

#[global]
Instance Op_Z_max : BinOp (Order.max : Z -> Z -> Z) :=
  { TBOp := Z.max; TBOpInj _ _ := ltac:(case: leP => /=; lia) }.
Add Zify BinOp Op_Z_max.

#[global]
Instance Op_Z_max' : BinOp ((Order.min : Z^d -> _) : Z -> Z -> Z) :=
  { TBOp := Z.max; TBOpInj _ _ := ltac:(case: leP => /=; lia) }.
Add Zify BinOp Op_Z_max'.

#[global]
Instance Op_Z_meet : BinOp (Order.meet : Z -> Z -> Z) :=
  { TBOp := Z.min; TBOpInj _ _ := ltac:(case: leP => /=; lia) }.
Add Zify BinOp Op_Z_meet.

#[global]
Instance Op_Z_meet' : BinOp (Order.join : Z^d -> _) := Op_Z_min.
Add Zify BinOp Op_Z_meet'.

#[global]
Instance Op_Z_join : BinOp (Order.join : Z -> Z -> Z) :=
  { TBOp := Z.max; TBOpInj _ _ := ltac:(case: leP => /=; lia) }.
Add Zify BinOp Op_Z_join.

#[global]
Instance Op_Z_join' : BinOp (Order.meet : Z^d -> _) := Op_Z_max.
Add Zify BinOp Op_Z_join'.

(******************************************************************************)
(* intdiv                                                                     *)
(******************************************************************************)

Fact Op_divz_subproof n m :
  Z_of_int (divz n m) = divZ (Z_of_int n) (Z_of_int m).
Proof. case: n => [[|n]|n]; rewrite /divz /divZ /= ?addn1 /=; nia. Qed.

#[global]
Instance Op_divz : BinOp (divz : int -> int -> int) :=
  { TBOp := divZ; TBOpInj := Op_divz_subproof }.
Add Zify BinOp Op_divz.

#[global]
Instance Op_modz : BinOp modz :=
  { TBOp := modZ; TBOpInj := ltac:(rewrite /= /modz; lia) }.
Add Zify BinOp Op_modz.

#[global]
Instance Op_dvdz : BinOp dvdz :=
  { TBOp n m := (modZ m n =? 0)%Z;
    TBOpInj _ _ := ltac:(apply/dvdz_mod0P/idP; lia) }.
Add Zify BinOp Op_dvdz.

Fact Op_gcdz_subproof n m :
  Z_of_int (gcdz n m) = Z.gcd (Z_of_int n) (Z_of_int m).
Proof. rewrite /gcdz -Z.gcd_abs_l -Z.gcd_abs_r; lia. Qed.

#[global]
Instance Op_gcdz : BinOp gcdz := { TBOp := Z.gcd; TBOpInj := Op_gcdz_subproof }.
Add Zify BinOp Op_gcdz.

#[global]
Instance Op_coprimez : BinOp coprimez :=
  { TBOp x y := (Z.gcd x y =? 1)%Z;
    TBOpInj := ltac:(rewrite /= /coprimez; lia) }.
Add Zify BinOp Op_coprimez.

Module Exports.
Add Zify InjTyp Inj_int_Z.
Add Zify UnOp Op_Z_of_int.
Add Zify UnOp Op_Posz.
Add Zify UnOp Op_Negz.
Add Zify BinRel Op_int_eq.
Add Zify BinOp Op_int_eq_op.
Add Zify CstOp Op_int_0.
Add Zify BinOp Op_addz.
Add Zify BinOp Op_int_add.
Add Zify UnOp Op_oppz.
Add Zify UnOp Op_int_opp.
Add Zify CstOp Op_int_1.
Add Zify BinOp Op_mulz.
Add Zify BinOp Op_int_mulr.
Add Zify BinOp Op_int_natmul.
Add Zify BinOp Op_int_intmul.
Add Zify BinOp Op_int_scale.
Add Zify BinOp Op_int_exp.
Add Zify UnOp Op_unitz.
Add Zify UnOp Op_int_unit.
Add Zify UnOp Op_invz.
Add Zify UnOp Op_int_inv.
Add Zify UnOp Op_absz.
Add Zify UnOp Op_int_normr.
Add Zify BinOp Op_lez.
Add Zify BinOp Op_ltz.
Add Zify UnOp Op_int_sgr.
Add Zify UnOp Op_int_sgz.
Add Zify BinOp Op_int_le.
Add Zify BinOp Op_int_le'.
Add Zify BinOp Op_int_ge.
Add Zify BinOp Op_int_ge'.
Add Zify BinOp Op_int_lt.
Add Zify BinOp Op_int_lt'.
Add Zify BinOp Op_int_gt.
Add Zify BinOp Op_int_gt'.
Add Zify BinOp Op_int_min.
Add Zify BinOp Op_int_min'.
Add Zify BinOp Op_int_max.
Add Zify BinOp Op_int_max'.
Add Zify BinOp Op_int_meet.
Add Zify BinOp Op_int_meet'.
Add Zify BinOp Op_int_join.
Add Zify BinOp Op_int_join'.
Add Zify BinOp Op_Z_eq_op.
Add Zify CstOp Op_Z_0.
Add Zify BinOp Op_Z_add.
Add Zify UnOp Op_Z_opp.
Add Zify CstOp Op_Z_1.
Add Zify BinOp Op_Z_mulr.
Add Zify BinOp Op_Z_natmul.
Add Zify BinOp Op_Z_intmul.
Add Zify BinOp Op_Z_scale.
Add Zify BinOp Op_Z_exp.
Add Zify UnOp Op_unitZ.
Add Zify UnOp Op_Z_unit.
Add Zify UnOp Op_invZ.
Add Zify UnOp Op_Z_inv.
Add Zify UnOp Op_Z_normr.
Add Zify UnOp Op_Z_sgr.
Add Zify BinOp Op_Z_le.
Add Zify BinOp Op_Z_le'.
Add Zify BinOp Op_Z_ge.
Add Zify BinOp Op_Z_ge'.
Add Zify BinOp Op_Z_lt.
Add Zify BinOp Op_Z_lt'.
Add Zify BinOp Op_Z_gt.
Add Zify BinOp Op_Z_gt'.
Add Zify BinOp Op_Z_min.
Add Zify BinOp Op_Z_min'.
Add Zify BinOp Op_Z_max.
Add Zify BinOp Op_Z_max'.
Add Zify BinOp Op_Z_meet.
Add Zify BinOp Op_Z_meet'.
Add Zify BinOp Op_Z_join.
Add Zify BinOp Op_Z_join'.
Add Zify BinOp Op_divz.
Add Zify BinOp Op_modz.
Add Zify BinOp Op_dvdz.
Add Zify BinOp Op_gcdz.
Add Zify BinOp Op_coprimez.
End Exports.

End AlgebraZifyInstances.
Export SsreflectZifyInstances.Exports.
Export AlgebraZifyInstances.Exports.


(* MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Modus_ponens.

Coq < Theorem MP: forall P Q: Prop, P /\ (P -> Q) -> Q.
1 subgoal

  ============================
   forall P Q : Prop, P /\ (P -> Q) -> Q

MP < intro P.
1 subgoal

  P : Prop
  ============================
   forall Q : Prop, P /\ (P -> Q) -> Q

MP < intro Q.
1 subgoal

  P : Prop
  Q : Prop
  ============================
   P /\ (P -> Q) -> Q

MP < intro HPPQ.
1 subgoal

  P : Prop
  Q : Prop
  HPPQ : P /\ (P -> Q)
  ============================
   Q

MP < destruct HPPQ as [HP HPQ].
1 subgoal

  P : Prop
  Q : Prop
  HP : P
  HPQ : P -> Q
  ============================
   Q

MP < apply HPQ.
1 subgoal

  P : Prop
  Q : Prop
  HP : P
  HPQ : P -> Q
  ============================
   P

MP < exact HP.
No more subgoals.

MP < Qed.
intro P.
intro Q.
intro HPPQ.
destruct HPPQ as (HP, HPQ).
apply HPQ.
exact HP.

MP is defined

Coq <
*)

Section Modus_ponens.
Theorem MP: forall P Q: Prop, P /\ (P -> Q) -> Q.
intro P.
intro Q.
intro HPPQ.
destruct HPPQ as [HP HPQ].
apply HPQ.
exact HP.
Qed.


Require Import Coq.Arith.Compare_dec.

Generalizable All Variables.

Class Decidable (P : Prop) := {
  Decidable_witness : bool;
  Decidable_spec : Decidable_witness = true <-> P
}.
Arguments Decidable_witness {P _} /.
Arguments Decidable_spec {P _} /.

Lemma Decidable_sound : forall P (H : Decidable P),
  Decidable_witness = true -> P.
Proof. intros; apply Decidable_spec; trivial. Qed.

Lemma Decidable_complete : forall P (H : Decidable P),
  P -> Decidable_witness = true.
Proof. intros; apply Decidable_spec; trivial. Qed.

Lemma Decidable_sound_alt : forall P (H : Decidable P),
  ~ P -> Decidable_witness = false.
Proof.
  intros.
  destruct Decidable_witness eqn:Heqe; trivial.
  apply Decidable_spec in Heqe.
  contradiction.
Qed.

Lemma Decidable_complete_alt : forall P (H : Decidable P),
  Decidable_witness = false -> ~ P.
Proof.
  intros.
  unfold not; intros.
  apply Decidable_spec in H1.
  congruence.
Qed.

Definition decide P {H : Decidable P} := Decidable_witness (Decidable:=H).

Ltac _decide_ P H :=
  let b := fresh "b" in
  set (b := decide P) in *;
  assert (H : decide P = b) by reflexivity;
  clearbody b;
  destruct b; [apply Decidable_sound in H|apply Decidable_complete_alt in H].

Tactic Notation "decide" constr(P) "as" ident(H) :=
  _decide_ P H.

Tactic Notation "decide" constr(P) :=
  let H := fresh "H" in _decide_ P H.

Hint Extern 2 =>
  match goal with
    [ H : @Decidable ?P |- _ ] =>
    let Heqe := fresh "Heqe" in
    destruct (@Decidable_witness P H) eqn:Heqe
  end : decidability.

Hint Extern 3 =>
  match goal with
    [ W : @Decidable_witness ?P ?H = true |- ?P ] =>
    exact (Decidable_sound P H W)
  end : decidability.

Hint Extern 3 =>
  match goal with
    [ W : @Decidable_witness ?P ?H = false |- ~ ?P ] =>
    exact (Decidable_complete_alt P H W)
  end : decidability.

Lemma Decidable_witness_dec `{Decidable P} : P \/ ~ P.
Proof. decide P; firstorder. Qed.
Arguments Decidable_witness_dec {P _} /.

Lemma Decidable_witness_decides `{Decidable P} :
  if Decidable_witness then P else ~ P.
Proof. auto with decidability. Qed.
Arguments Decidable_witness_decides {P _} /.

Local Ltac t :=
  intros;
  repeat
    match goal with
      [ H : Decidable ?P |- _ ] =>
      let Heqe := fresh "Heqe" in
      destruct (@Decidable_witness P H) eqn:Heqe;
      [ apply (@Decidable_sound P H) in Heqe
      | apply (@Decidable_complete_alt P H) in Heqe ];
      clear H
    end;
  simpl; split; intros;
  try discriminate;
  try contradiction;
  try reflexivity;
  intuition.

Section DecidableLogic.

Local Obligation Tactic := t.

Global Program Instance not_Decidable {P : Prop} `{Decidable P} :
  Decidable (~ P) := {
  Decidable_witness := negb Decidable_witness
}.

Global Program Instance and_Decidable {P Q : Prop}
  `{Decidable P} `{Decidable Q} : Decidable (P /\ Q) := {
  Decidable_witness := andb (Decidable_witness (P:=P))
                            (Decidable_witness (P:=Q))
}.

Global Program Instance or_Decidable {P Q : Prop}
  `{Decidable P} `{Decidable Q} : Decidable (P \/ Q) := {
  Decidable_witness := orb (Decidable_witness (P:=P))
                           (Decidable_witness (P:=Q))
}.

Global Program Instance impl_Decidable {P Q : Prop}
  `{Decidable P} `{Decidable Q} : Decidable (P -> Q) := {
  Decidable_witness := if Decidable_witness (P:=P)
                       then Decidable_witness (P:=Q)
                       else true
}.

End DecidableLogic.

Local Ltac t' tac := t; apply tac; assumption.

Require Import Coq.Bool.Bool.

Global Program Instance bool_eq_Decidable {n m : bool} : Decidable (n = m) := {
  Decidable_witness := eqb n m
}.
Obligation 1. t' eqb_true_iff. Qed.

Require Import Coq.Strings.Ascii.
Require Import Coq.Bool.Sumbool.

Global Program Instance ascii_eq_Decidable {n m : Ascii.ascii} :
  Decidable (n = m) := {
  Decidable_witness := bool_of_sumbool (Ascii.ascii_dec n m)
}.
Obligation 1. t; destruct (Ascii.ascii_dec n m); auto; discriminate. Qed.

Require Import Coq.Arith.Arith.

Global Program Instance nat_eq_Decidable {n m : nat} : Decidable (n = m) := {
  Decidable_witness := beq_nat n m
}.
Obligation 1. t' beq_nat_true_iff. Qed.

Global Program Instance le_Decidable {n m} : Decidable (le n m) := {
  Decidable_witness := Compare_dec.leb n m
}.
Obligation 1. t' leb_iff. Qed.

Global Instance lt_Decidable {n m} : Decidable (lt n m) := le_Decidable.

Require Import Coq.NArith.NArith.

Global Program Instance N_eq_Decidable {n m : N} : Decidable (n = m) := {
  Decidable_witness := N.eqb n m
}.
Obligation 1. t' N.eqb_eq. Qed.

Global Program Instance Nle_Decidable {n m} : Decidable (Nle n m) := {
  Decidable_witness := N.leb n m
}.
Obligation 1. t' N.leb_le. Qed.

Global Program Instance Nlt_Decidable {n m} : Decidable (Nlt n m) := {
  Decidable_witness := N.ltb n m
}.
Obligation 1. t' N.ltb_lt. Qed.

Require Import Coq.ZArith.ZArith.

Global Program Instance Z_eq_Decidable {n m : Z} : Decidable (n = m) := {
  Decidable_witness := Z.eqb n m
}.
Obligation 1. t' Z.eqb_eq. Qed.

Global Program Instance Zle_Decidable {n m} : Decidable (Zle n m) := {
  Decidable_witness := Z.leb n m
}.
Obligation 1. t' Z.leb_le. Qed.

Global Program Instance Zlt_Decidable {n m} : Decidable (Zlt n m) := {
  Decidable_witness := Z.ltb n m
}.
Obligation 1. t' Z.ltb_lt. Qed.

Require Import Coq.QArith.QArith.

Global Program Instance Q_eq_Decidable {n m : Q} : Decidable (n == m) := {
  Decidable_witness := Qeq_bool n m
}.
Obligation 1. t' Qeq_bool_iff. Qed.

Global Program Instance Qle_Decidable {n m} : Decidable (Qle n m) := {
  Decidable_witness := Qle_bool n m
}.
Obligation 1. t' Qle_bool_iff. Qed.

Global Program Instance Qlt_Decidable {n m} : Decidable (Qlt n m) := {
  Decidable_witness := bool_of_sumbool (Qlt_le_dec n m)
}.
Obligation 1.
  t; destruct (Qlt_le_dec n m); simpl in H; auto.
    discriminate.
  apply Qle_not_lt in H; auto.
Qed.

Section ListDec.
  Variable A : Type.
  Variable eq_dec : forall x y : A, {x = y} + {x <> y}.

  Global Program Instance list_eq_Decidable {xs ys : list A} :
    Decidable (xs = ys) := {
    Decidable_witness := bool_of_sumbool (List.list_eq_dec eq_dec xs ys)
  }.
  Obligation 1.
    t; destruct (List.list_eq_dec eq_dec xs ys);
    simpl in H; auto; discriminate.
  Qed.

  Global Program Instance list_in_Decidable {xs : list A} {x : A} :
    Decidable (List.In x xs) := {
    Decidable_witness := List.existsb (fun y => bool_of_sumbool (eq_dec x y)) xs
  }.
  Obligation 1.
    remember (fun _ => proj1_sig _) as F; t;
    destruct (List.existsb_exists F xs);
    destruct (List.existsb F xs);
    auto; try discriminate.
      destruct (H0 H).
      destruct H2.
      rewrite HeqF in H3.
      destruct (eq_dec x x0);
      subst; auto; discriminate.
    apply H1.
    exists x; split; auto.
    rewrite HeqF.
    destruct (eq_dec x x); auto.
  Qed.
End ListDec.

Definition Ifdec_Then_Else {A} (P : Prop) `{Decidable P} (t e : A) :=
  if Decidable_witness then t else e.
Arguments Ifdec_Then_Else {A} P {_} t e : simpl never.

Notation "'Ifdec' P 'Then' t 'Else' e" :=
  (Ifdec_Then_Else P t e) (at level 70).

Require Import Fiat.Common.
Require Import Fiat.Computation.Core.

Local Ltac t2 p := intros; destruct p; intuition.

Lemma refine_Ifdec_true : forall `{Decidable P} ResultT (t e : Comp ResultT),
  P -> refine (Ifdec P Then t Else e) t.
Proof.
  intros.
  apply Decidable_spec in H0.
  unfold Ifdec_Then_Else.
  rewrite H0; simpl.
  apply refine_PreOrder.
Qed.

Lemma refine_Ifdec_false : forall `{Decidable P} ResultT (t e : Comp ResultT),
  ~ P -> refine (Ifdec P Then t Else e) e.
Proof.
  intros.
  eapply Decidable_sound_alt in H0.
  unfold Ifdec_Then_Else.
  rewrite H0; simpl.
  apply refine_PreOrder.
Qed.

Require Import Fiat.Computation.Monad.
Require Import Fiat.Computation.Refinements.General.

Lemma refine_Ifdec_decides :
  forall `{Decidable P} ResultT (t e : Comp ResultT),
    refineEquiv (Ifdec P Then t Else e)
                (b <- {b : bool | decides b P};
                 If b Then t Else e).
Proof.
  split.
    apply refine_pick_decides.
      exact (refine_Ifdec_true _ _).
    exact (refine_Ifdec_false _ _).
  refine pick val Decidable_witness.
    rewrite refine_bind_unit.
    apply refine_PreOrder.
  exact Decidable_witness_decides.
Qed.

Lemma refine_Ifdec_Then_Else :
  forall (A : Type) `{Decidable P} (x y : Comp A),
    (P -> refine x y)
      -> forall x0 y0 : Comp A, (~ P -> refine x0 y0)
      -> refine (Ifdec P Then x Else x0)
                (Ifdec P Then y Else y0).
Proof.
  intros.
  unfold Ifdec_Then_Else.
  rewrite refine_if_If.
  destruct H, Decidable_witness0; simpl.
    apply H0, Decidable_spec0.
    reflexivity.
  apply H1.
  unfold not; intros.
  apply Decidable_spec0 in H.
  discriminate.
Qed.

Lemma refine_Ifdec_Then_Else_ret :
  forall `{Decidable P} ResultT (t e : ResultT),
    refine (Ifdec P Then ret t Else ret e)
           (ret (Ifdec P Then t Else e)%comp).
Proof.
  intros.
  unfold Ifdec_Then_Else.
  apply refine_If_Then_Else_ret; trivial.
Qed.

Lemma refine_sumbool_match :
  forall `(P : {A} + {~A}) B
         (f f' : A -> Comp B) (g g' : ~A -> Comp B),
       pointwise_relation A    refine f f'
    -> pointwise_relation (~A) refine g g'
    -> refine (match P with
               | left  H => f H
               | right H => g H
               end)
              (match P with
               | left  H => f' H
               | right H => g' H
               end).
Proof. t2 P. Qed.

Lemma refine_sumbool_ret :
  forall `(P : {A} + {~A}) `(f : A -> B) (g : ~A -> B),
    refine (match P with
            | left  H => ret (f H)
            | right H => ret (g H)
            end)
           (ret (match P with
                 | left  H => f H
                 | right H => g H
                 end)).
Proof. t2 P. Qed.

Lemma refine_sumbool_bind :
  forall `(P : {A} + {~A})
         `(f : A -> Comp B) (g : ~A -> Comp B)
         `(h : B -> Comp C),
    refine (x <- match P with
                 | left  H => f H
                 | right H => g H
                 end;
            h x)
           (match P with
            | left  H => x <- f H; h x
            | right H => x <- g H; h x
            end).
Proof. t2 P. Qed.

Lemma refine_bind_sumbool :
  forall `(P : {A} + {~A})
         `(f : C -> A -> Comp B) (g : C -> ~A -> Comp B)
         `(c : Comp C),
    refine (x <- c;
            match P with
            | left  H => f x H
            | right H => g x H
            end)
           (match P with
            | left  H => x <- c; f x H
            | right H => x <- c; g x H
            end).
Proof. t2 P. Qed.

Lemma Ifdec_true : forall (P : Prop) `{Decidable P} A (t e : A),
  P -> Ifdec P Then t Else e = t.
Proof.
  intros.
  unfold Ifdec_Then_Else; simpl.
  destruct H, Decidable_witness0; auto.
  firstorder.
Qed.

Lemma Ifdec_false : forall (P : Prop) `{Decidable P} A (t e : A),
  ~ P -> Ifdec P Then t Else e = e.
Proof.
  intros.
  unfold Ifdec_Then_Else; simpl.
  destruct H, Decidable_witness0; auto.
  firstorder.
Qed.

Ltac simplify_Ifdec :=
  match goal with
  | [ H : ?P |- context[Ifdec ?P Then _ Else _] ] =>
    rewrite Ifdec_true; trivial
  | [ H : ~ ?P |- context[Ifdec ?P Then _ Else _] ] =>
    rewrite Ifdec_false; trivial
  | [ H : ?P |- context[Ifdec ?P Then _ Else _] ] =>
    erewrite Ifdec_true; eauto
  | [ H : ~ ?P |- context[Ifdec ?P Then _ Else _] ] =>
    erewrite Ifdec_false; eauto
  end.


Require Import HoTT.Basics HoTT.Types Fibrations FunextVarieties.

(** A nice method for proving characterizations of path-types of nested sigma-types, due to Rijke. *)

(** To show that the based path-type of [A] is equivalent to some specified family [P], it suffices to show that [P] is reflexive and its total space is contractible. This is part of Theorem 5.8.2, namely (iv) implies (iii). *)
Definition equiv_path_from_contr {A : Type} (a : A) (P : A -> Type)
           (Prefl : P a)
           (cp : Contr {y:A & P y} )
           (b : A)
  : P b <~> a = b.
Proof.
  apply equiv_inverse.
  srefine (Build_Equiv _ _ _ _).
  { intros []; apply Prefl. }
  revert b; apply isequiv_from_functor_sigma.
  (* For some reason, typeclass search can't find the Contr instances unless we give the types explicitly. *)
  refine (@isequiv_contr_contr {x:A & a=x} {x:A & P x} _ _ _).
Defined.

(** This is another result for characterizing the path type of [A] when given an equivalence [e : B <~> A], such as an [issig] lemma for [A]. It can help Coq to deduce the type family [P] if [revert] is used to move [a0] and [a1] into the goal, if needed. *)
Definition equiv_path_along_equiv {A B : Type} {P : A -> A -> Type}
           (e : B <~> A)
           (K : forall b0 b1 : B, P (e b0) (e b1) <~> b0 = b1)
  : forall a0 a1 : A, P a0 a1 <~> a0 = a1.
Proof.
  equiv_intros e b0 b1.
  refine (_ oE K b0 b1).
  apply equiv_ap'.
Defined.

(** This simply combines the two previous results, a common idiom. Again, it can help Coq to deduce the type family [P] if [revert] is used to move [a0] and [a1] into the goal, if needed. *)
Definition equiv_path_issig_contr {A B : Type} {P : A -> A -> Type}
           (e : B <~> A)
           (Prefl : forall b, P (e b) (e b))
           (cp : forall b1, Contr {b2 : B & P (e b1) (e b2)})
  : forall a0 a1 : A, P a0 a1 <~> a0 = a1.
Proof.
  apply (equiv_path_along_equiv e).
  intro a0.
  serapply equiv_path_from_contr.
  apply Prefl.
Defined.

(** After [equiv_path_issig_contr], we are left showing the contractibility of a sigma-type whose base and fibers are large nested sigma-types of the same depth.  Moreover, we expect that the types appearing in those two large nested sigma-types "pair up" to form contractible based "path-types".  The following lemma "peels off" the first such pair, whose contractibility can often be found with typeclass search.  The remaining contractibility goal is then simplified by substituting the center of contraction of that first based "path-type", or more precisely a *specific* center that may or may not be the one given by the contractibility instance; the latter freedom sometimes makes things faster and simpler. *)
Definition contr_sigma_sigma (A : Type) (B : A -> Type)
           (C : A -> Type) (D : forall a, B a -> C a -> Type)
           {cac : Contr {x:A & C x} }
           (a : A) (c : C a)
           {ccd : Contr {y:B a & D a y c } }
  : Contr {ab : {x:A & B x} & {y:C ab.1 & D ab.1 ab.2 y} }.
Proof.
  pose (d := (center {y:B a & D a y c}).2).
  set (b := (center {y:B a & D a y c}).1) in *.
  exists ((a;b);(c;d)).
  intros [[a' b'] [c' d']]; cbn in *.
  pose (ac' := (a';c')).
  pose (bd' := (b';d') : {y:B ac'.1 & D ac'.1 y ac'.2}).
  change (((a;b);(c;d)) = ((ac'.1;bd'.1);(ac'.2;bd'.2))
          :> {ab : {x:A & B x} & {y:C ab.1 & D ab.1 ab.2 y} }).
  clearbody ac' bd'; clear a' b' c' d'.
  destruct (@path_contr {x:A & C x} _ (a;c) ac').
  destruct (@path_contr {y:B a & D a y c} _ (b;d) bd').
  reflexivity.
Defined.

(** This tactic just applies the previous lemma, using a match to figure out the appropriate type families so the user doesn't have to specify them. *)
Ltac contr_sigsig a c :=
  match goal with
  | [ |- Contr (@sig (@sig ?A ?B) (fun ab => @sig (@?C ab) (@?D ab))) ] =>
    (* The lemma only applies when C depends only on the first component of ab, so we need to factor it somehow through pr1. *)
    let C' := fresh in
    transparent assert (C' : {C' : A -> Type & forall ab, C' ab.1 = C ab});
    [ eexists; intros ab; reflexivity
    | refine (contr_sigma_sigma A B C'.1 (fun a b c => D (a;b) c) a c);
      subst C' ]
  end.

(** For examples of the use of this tactic, see for instance [Factorization] and [Idempotents]. *)


(************************************************************************)
(*  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: Rseries.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import Rbase.
Require Import Rfunctions.
Require Import Classical.
Require Import Compare.
Open Local Scope R_scope.

Implicit Type r : R.

(* classical is needed for [Un_cv_crit] *)
(*********************************************************)
(** *        Definition of sequence and properties       *)
(*                                                       *)
(*********************************************************)

Section sequence.

(*********)
  Variable Un : nat -> R.

(*********)
  Boxed Fixpoint Rmax_N (N:nat) : R :=
    match N with
      | O => Un 0
      | S n => Rmax (Un (S n)) (Rmax_N n)
    end.

(*********)
  Definition EUn r : Prop :=  exists i : nat, r = Un i.

(*********)
  Definition Un_cv (l:R) : Prop :=
    forall eps:R,
      eps > 0 ->
      exists N : nat, (forall n:nat, (n >= N)%nat -> R_dist (Un n) l < eps).

(*********)
  Definition Cauchy_crit : Prop :=
    forall eps:R,
      eps > 0 ->
      exists N : nat,
        (forall n m:nat,
          (n >= N)%nat -> (m >= N)%nat -> R_dist (Un n) (Un m) < eps).

(*********)
  Definition Un_growing : Prop := forall n:nat, Un n <= Un (S n).

(*********)
  Lemma EUn_noempty :  exists r : R, EUn r.
  Proof.
    unfold EUn in |- *; split with (Un 0); split with 0%nat; trivial.
  Qed.

(*********)
  Lemma Un_in_EUn : forall n:nat, EUn (Un n).
  Proof.
    intro; unfold EUn in |- *; split with n; trivial.
  Qed.

(*********)
  Lemma Un_bound_imp :
    forall x:R, (forall n:nat, Un n <= x) -> is_upper_bound EUn x.
  Proof.
    intros; unfold is_upper_bound in |- *; intros; unfold EUn in H0; elim H0;
      clear H0; intros; generalize (H x1); intro; rewrite <- H0 in H1;
        trivial.
  Qed.

(*********)
  Lemma growing_prop :
    forall n m:nat, Un_growing -> (n >= m)%nat -> Un n >= Un m.
  Proof.
    double induction n m; intros.
    unfold Rge in |- *; right; trivial.
    exfalso; unfold ge in H1; generalize (le_Sn_O n0); intro; auto.
    cut (n0 >= 0)%nat.
    generalize H0; intros; unfold Un_growing in H0;
      apply
        (Rge_trans (Un (S n0)) (Un n0) (Un 0) (Rle_ge (Un n0) (Un (S n0)) (H0 n0))
          (H 0%nat H2 H3)).
    elim n0; auto.
    elim (lt_eq_lt_dec n1 n0); intro y.
    elim y; clear y; intro y.
    unfold ge in H2; generalize (le_not_lt n0 n1 (le_S_n n0 n1 H2)); intro;
      exfalso; auto.
    rewrite y; unfold Rge in |- *; right; trivial.
    unfold ge in H0; generalize (H0 (S n0) H1 (lt_le_S n0 n1 y)); intro;
      unfold Un_growing in H1;
        apply
          (Rge_trans (Un (S n1)) (Un n1) (Un (S n0))
            (Rle_ge (Un n1) (Un (S n1)) (H1 n1)) H3).
  Qed.

(** classical is needed: [not_all_not_ex] *)
(*********)
  Lemma Un_cv_crit : Un_growing -> bound EUn ->  exists l : R, Un_cv l.
  Proof.
    unfold Un_growing, Un_cv in |- *; intros;
      generalize (completeness_weak EUn H0 EUn_noempty);
        intro; elim H1; clear H1; intros; split with x; intros;
          unfold is_lub in H1; unfold bound in H0; unfold is_upper_bound in H0, H1;
            elim H0; clear H0; intros; elim H1; clear H1; intros;
              generalize (H3 x0 H0); intro; cut (forall n:nat, Un n <= x);
                intro.
    cut (exists N : nat, x - eps < Un N).
    intro; elim H6; clear H6; intros; split with x1.
    intros; unfold R_dist in |- *; apply (Rabs_def1 (Un n - x) eps).
    unfold Rgt in H2;
      apply (Rle_lt_trans (Un n - x) 0 eps (Rle_minus (Un n) x (H5 n)) H2).
    fold Un_growing in H; generalize (growing_prop n x1 H H7); intro;
      generalize
        (Rlt_le_trans (x - eps) (Un x1) (Un n) H6 (Rge_le (Un n) (Un x1) H8));
        intro; generalize (Rplus_lt_compat_l (- x) (x - eps) (Un n) H9);
          unfold Rminus in |- *; rewrite <- (Rplus_assoc (- x) x (- eps));
            rewrite (Rplus_comm (- x) (Un n)); fold (Un n - x) in |- *;
              rewrite Rplus_opp_l; rewrite (let (H1, H2) := Rplus_ne (- eps) in H2);
                trivial.
    cut (~ (forall N:nat, x - eps >= Un N)).
    intro; apply (not_all_not_ex nat (fun N:nat => x - eps < Un N)); red in |- *;
      intro; red in H6; elim H6; clear H6; intro;
        apply (Rnot_lt_ge (x - eps) (Un N) (H7 N)).
    red in |- *; intro; cut (forall N:nat, Un N <= x - eps).
    intro; generalize (Un_bound_imp (x - eps) H7); intro;
      unfold is_upper_bound in H8; generalize (H3 (x - eps) H8);
        intro; generalize (Rle_minus x (x - eps) H9); unfold Rminus in |- *;
          rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; rewrite Rplus_opp_r;
            rewrite (let (H1, H2) := Rplus_ne (- - eps) in H2);
              rewrite Ropp_involutive; intro; unfold Rgt in H2;
                generalize (Rgt_not_le eps 0 H2); intro; auto.
    intro; elim (H6 N); intro; unfold Rle in |- *.
    left; unfold Rgt in H7; assumption.
    right; auto.
    apply (H1 (Un n) (Un_in_EUn n)).
  Qed.

(*********)
  Lemma finite_greater :
    forall N:nat,  exists M : R, (forall n:nat, (n <= N)%nat -> Un n <= M).
  Proof.
    intro; induction  N as [| N HrecN].
    split with (Un 0); intros; rewrite (le_n_O_eq n H);
      apply (Req_le (Un n) (Un n) (refl_equal (Un n))).
    elim HrecN; clear HrecN; intros; split with (Rmax (Un (S N)) x); intros;
      elim (Rmax_Rle (Un (S N)) x (Un n)); intros; clear H1;
        inversion H0.
    rewrite <- H1; rewrite <- H1 in H2;
      apply
        (H2 (or_introl (Un n <= x) (Req_le (Un n) (Un n) (refl_equal (Un n))))).
    apply (H2 (or_intror (Un n <= Un (S N)) (H n H3))).
  Qed.

(*********)
  Lemma cauchy_bound : Cauchy_crit -> bound EUn.
  Proof.
    unfold Cauchy_crit, bound in |- *; intros; unfold is_upper_bound in |- *;
      unfold Rgt in H; elim (H 1 Rlt_0_1); clear H; intros;
        generalize (H x); intro; generalize (le_dec x); intro;
          elim (finite_greater x); intros; split with (Rmax x0 (Un x + 1));
            clear H; intros; unfold EUn in H; elim H; clear H;
              intros; elim (H1 x2); clear H1; intro y.
    unfold ge in H0; generalize (H0 x2 (le_n x) y); clear H0; intro;
      rewrite <- H in H0; unfold R_dist in H0; elim (Rabs_def2 (Un x - x1) 1 H0);
        clear H0; intros; elim (Rmax_Rle x0 (Un x + 1) x1);
          intros; apply H4; clear H3 H4; right; clear H H0 y;
            apply (Rlt_le x1 (Un x + 1)); generalize (Rlt_minus (-1) (Un x - x1) H1);
              clear H1; intro; apply (Rminus_lt x1 (Un x + 1));
                cut (-1 - (Un x - x1) = x1 - (Un x + 1));
                  [ intro; rewrite H0 in H; assumption | ring ].
    generalize (H2 x2 y); clear H2 H0; intro; rewrite <- H in H0;
      elim (Rmax_Rle x0 (Un x + 1) x1); intros; clear H1;
        apply H2; left; assumption.
  Qed.

End sequence.

(*****************************************************************)
(**  *       Definition of Power Series and properties           *)
(*                                                               *)
(*****************************************************************)

Section Isequence.

(*********)
  Variable An : nat -> R.

(*********)
  Definition Pser (x l:R) : Prop := infinite_sum (fun n:nat => An n * x ^ n) l.

End Isequence.

Lemma GP_infinite :
  forall x:R, Rabs x < 1 -> Pser (fun n:nat => 1) x (/ (1 - x)).
Proof.
  intros; unfold Pser in |- *; unfold infinite_sum in |- *; intros;
    elim (Req_dec x 0).
  intros; exists 0%nat; intros; rewrite H1; rewrite Rminus_0_r; rewrite Rinv_1;
    cut (sum_f_R0 (fun n0:nat => 1 * 0 ^ n0) n = 1).
  intros; rewrite H3; rewrite R_dist_eq; auto.
  elim n; simpl in |- *.
  ring.
  intros; rewrite H3; ring.
  intro; cut (0 < eps * (Rabs (1 - x) * Rabs (/ x))).
  intro; elim (pow_lt_1_zero x H (eps * (Rabs (1 - x) * Rabs (/ x))) H2);
    intro N; intros; exists N; intros;
      cut
        (sum_f_R0 (fun n0:nat => 1 * x ^ n0) n = sum_f_R0 (fun n0:nat => x ^ n0) n).
  intros; rewrite H5;
    apply
      (Rmult_lt_reg_l (Rabs (1 - x))
        (R_dist (sum_f_R0 (fun n0:nat => x ^ n0) n) (/ (1 - x))) eps).
  apply Rabs_pos_lt.
  apply Rminus_eq_contra.
  apply Rlt_dichotomy_converse.
  right; unfold Rgt in |- *.
  apply (Rle_lt_trans x (Rabs x) 1).
  apply RRle_abs.
  assumption.
  unfold R_dist in |- *; rewrite <- Rabs_mult.
  rewrite Rmult_minus_distr_l.
  cut
    ((1 - x) * sum_f_R0 (fun n0:nat => x ^ n0) n =
      - (sum_f_R0 (fun n0:nat => x ^ n0) n * (x - 1))).
  intro; rewrite H6.
  rewrite GP_finite.
  rewrite Rinv_r.
  cut (- (x ^ (n + 1) - 1) - 1 = - x ^ (n + 1)).
  intro; rewrite H7.
  rewrite Rabs_Ropp; cut ((n + 1)%nat = S n); auto.
  intro H8; rewrite H8; simpl in |- *; rewrite Rabs_mult;
    apply
      (Rlt_le_trans (Rabs x * Rabs (x ^ n))
        (Rabs x * (eps * (Rabs (1 - x) * Rabs (/ x)))) (
          Rabs (1 - x) * eps)).
  apply Rmult_lt_compat_l.
  apply Rabs_pos_lt.
  assumption.
  auto.
  cut
    (Rabs x * (eps * (Rabs (1 - x) * Rabs (/ x))) =
      Rabs x * Rabs (/ x) * (eps * Rabs (1 - x))).
  clear H8; intros; rewrite H8; rewrite <- Rabs_mult; rewrite Rinv_r.
  rewrite Rabs_R1; cut (1 * (eps * Rabs (1 - x)) = Rabs (1 - x) * eps).
  intros; rewrite H9; unfold Rle in |- *; right; reflexivity.
  ring.
  assumption.
  ring.
  ring.
  ring.
  apply Rminus_eq_contra.
  apply Rlt_dichotomy_converse.
  right; unfold Rgt in |- *.
  apply (Rle_lt_trans x (Rabs x) 1).
  apply RRle_abs.
  assumption.
  ring; ring.
  elim n; simpl in |- *.
  ring.
  intros; rewrite H5.
  ring.
  apply Rmult_lt_0_compat.
  auto.
  apply Rmult_lt_0_compat.
  apply Rabs_pos_lt.
  apply Rminus_eq_contra.
  apply Rlt_dichotomy_converse.
  right; unfold Rgt in |- *.
  apply (Rle_lt_trans x (Rabs x) 1).
  apply RRle_abs.
  assumption.
  apply Rabs_pos_lt.
  apply Rinv_neq_0_compat.
  assumption.
Qed.


Require Export Coq.Lists.List.
Require Import Iron.Data.Nat.
Require Import Iron.Tactics.

(* Unfolding defs from Coq.Lists.List module *)
Hint Unfold length.
Hint Unfold app.
Hint Unfold firstn.
Hint Unfold skipn.

(********************************************************************)
(* Definitions *)

(* Add a single element to the end of the list *)
Fixpoint snoc {A: Type} (x: A) (xx: list A) : list A :=
 match xx with
 | nil       => x :: nil
 | y :: xs'  => y :: snoc x xs'
 end.

(* Get an indexed element from a list, starting from 0.
   This is like the Coq 'nth' function, but returns an option instead
   of a provided default value. Using an option is useful when we simply
   want to determine whether some element is in the list, but don't
   need the actual value *)
Fixpoint get {A: Type} (i: nat) (e: list A) {struct e}: option A :=
 match e, i with
 | x :: _,  O     => Some x
 | _ :: xs, S i'  => get  i' xs
 | _, _           => None
 end.

(********************************************************************)
(* Environment notations.
   These look more natural than the standard operators when dealing
   with de-Bruijn environments. *)
Notation "xs :> x"  := (x :: xs)   (at level 61, left associativity).
Notation "x  <: xs" := (snoc x xs) (at level 62, right associativity).
Notation "xs >< ys" := (app ys xs) (at level 60, right associativity).

(********************************************************************)
(** Lemmas: cons/snoc *)

Lemma cons_snoc_empty
 :  forall A (x: A)
 ,  x <: nil = nil :> x.
Proof.
 auto.
Qed.
Hint Resolve cons_snoc_empty.

Lemma snoc_cons
 :  forall A (xs: list A) (x: A) (y: A)
 ,  ((x <: xs) :> y) = (x <: (xs :> y)).
Proof.
 intros. destruct xs; auto.
Qed.
Hint Resolve snoc_cons.

Lemma snocable
 : forall {A} (ts: list A)
 , ts = nil \/ (exists t ts', ts = snoc t ts').
Proof.
 intros.
 induction ts.
  auto.
  inverts IHts.
   right. eauto.
   right. dest t. dest ts.
    subst. eauto.
Qed.

(********************************************************************)
(** Lemmas: length *)

(* A list with length zero is always nil. *)
Lemma length_zero_is_nil
 :  forall {A} (xx: list A)
 ,  length xx = O
 -> xx = nil.
Proof.
 intros.
 destruct xx; burn.
Qed.
Hint Resolve length_zero_is_nil.

Lemma length_simpl_snoc
 : forall {A} x (xs: list A)
 , length (x <: xs) = 1 + length xs.
Proof.
 induction xs; burn.
Qed.
Hint Resolve length_simpl_snoc.

Lemma get_length_snoc
 :  forall {A} (xs : list A) (x : A)
 ,  get (length xs) (x <: xs) = Some x.
Proof.
 intros. gen x.
 induction xs; burn.
Qed.
Hint Resolve get_length_snoc.

Lemma get_length_less_snoc
 :  forall {A} i x (xs : list A)
 ,  i < length xs
 -> get i (x <: xs) = get i xs.
Proof.
 intros. gen i.
 induction xs; intros.
  destruct i.
   nope.
   auto.
  destruct i.
   auto.
   simpl.
   simpl in H.
   assert (i < length xs). omega.
   eauto.
Qed.
Hint Resolve get_length_less_snoc.

(* If there is an element at a particular index, then the length
   of the list is bigger than that index. *)
Lemma get_length_more
 :  forall A n (xx: list A) x
 ,  get n xx = Some x
 -> length xx > n.
Proof.
 intros. gen xx.
 induction n; intros.
  destruct xx.
   false.
   simpl in H. inverts H. simpl. omega.

  destruct xx.
   false.
   simpl in H. apply IHn in H. simpl. omega.
Qed.
Hint Resolve get_length_more.

Lemma get_length_less
 :  forall A n (xx: list A) x
 ,  get n xx = Some x
 -> n < length xx.
Proof.
 eapply get_length_more.
Qed.
Hint Resolve get_length_less.

Lemma get_length_less_exists
 :  forall {A} i (xs : list A)
 ,  i < length xs
 -> exists x, get i xs = Some x.
Proof.
 intros. gen xs.
 induction i; intros.
  destruct xs.
   nope.
   simpl in H. burn.
  destruct xs.
   simpl in H. nope.
   simpl in H.
   simpl. eapply IHi.
    burn.
Qed.
Hint Resolve get_length_less_exists.

Lemma get_none_length
 :  forall {A} n (xs: list A)
 ,  get n xs = None
 -> length xs <= n.
Proof.
 intros. gen n.
 induction xs; intros.
  simpl. burn.
  simpl. simpl in H.
   destruct n.
    false.
    apply IHxs in H. omega.
Qed.
Hint Resolve get_none_length.

Lemma length_in_in_nonempty
 :  forall {A} xs1 xs2
 ,  (forall (x: A), In x xs1 -> In x xs2)
 -> length xs1 > 0
 -> length xs2 > 0.
Proof.
 intros.
 destruct xs1.
  nope.
  destruct xs2.
   have (In a (xs1 :> a)).
   spec H a. rip. nope.
   simpl. omega.
Qed.
Hint Resolve length_in_in_nonempty.

(********************************************************************)
(** Lemmas: app *)

Lemma app_nil_left
 :  forall A (xx: list A)
 ,  nil ++ xx = xx.
Proof.
 auto.
Qed.
Hint Resolve app_nil_left.
Hint Rewrite app_nil_left : global.

Lemma app_nil_right
 :  forall A (xx: list A)
 ,  xx ++ nil = xx.
Proof.
 intros.
 induction xx.
  auto.
  simpl. rewrite IHxx. trivial.
Qed.
Hint Resolve app_nil_right.
Hint Rewrite app_nil_right : global.

Lemma app_snoc
 :  forall A (l1: list A) (l2: list A) (x : A)
 ,  ((l1 :> x) >< l2) = l1 >< (x <: l2).
Proof.
 intros.
 induction l2.
  auto.
  simpl. rewrite IHl2. auto.
Qed.
Hint Resolve app_snoc.

Lemma app_snoc'
 :  forall A (l1: list A) (l2: list A) (x : A)
 ,  (x <: l1) >< l2 = x <: (l1 >< l2).
Proof.
 intros.
 induction l2.
  auto.
  simpl. rewrite IHl2. auto.
Qed.
Hint Resolve app_snoc'.

Lemma app_cons_nil_left
 :  forall A x (yy: list A)
 ,  (x :: nil) ++ yy
 =  x :: yy.
Proof.
 intros.
 simpl. auto.
Qed.
Hint Resolve app_cons_nil_left.
Hint Rewrite app_cons_nil_left : global.

Lemma app_cons_nil_right
 :  forall A y (xx: list A)
 ,  xx ++ (y :: nil)
 =  snoc y xx.
Proof.
 intros.
 rewrite app_snoc. rr.
 auto.
Qed.
Hint Resolve app_cons_nil_right.
Hint Rewrite app_cons_nil_right : global.

Lemma app_length
 :  forall A (l1: list A) l2
 ,  length (l1 ++ l2) = length l1 + length l2.
Proof.
 intros.
 induction l1.
  auto.
  simpl. rip.
Qed.
Hint Rewrite app_length : global.

Lemma length_snoc
 :  forall A (xs: list A) x
 ,  length (x <: xs)  = 1 + length xs.
Proof.
 intros.
 assert (x <: xs = (x :: nil) >< xs).
  rewrite app_snoc.
  rewrite app_nil_right. auto.

 rewrite H.
 rewrite app_length.
 simpl. omega.
Qed.
Hint Rewrite length_snoc : global.

(********************************************************************)
(** Lemmas: get *)

Lemma get_rewind
 :  forall A n x (xx: list A)
 ,  get n xx = get (S n) (xx :> x).
Proof. auto. Qed.
Hint Resolve get_rewind.

(* If we can get an element from a list then it is in that list. *)
Lemma get_in
 :  forall A (xs: list A) x n
 ,  get n xs = Some x -> In x xs.
Proof.
 intros.
  gen x xs.
  induction n; intros.
   destruct xs.
    false.
    simpl in H. inverts H. simpl. auto.
   destruct xs.
    simpl in H. false.
    simpl in H. simpl. right. auto.
Qed.
Hint Resolve get_in.

(* If a list contains an element at a non-zero index,
   then it also contains an element at the previous index. *)
Lemma get_succ_some
 :  forall A (xx: list A) n
 ,  (exists t, get (S n) xx = Some t)
 -> (exists t, get n xx     = Some t).
Proof.
 intros. gen n.
 induction xx; intros.
  simpl in H. inverts H. inverts H0.
  destruct n; simpl; eauto.
Qed.
Hint Resolve get_succ_some.

(* If a list contains an element at a non-zero index,
   then it also contains an element at the previous index. *)
Lemma get_minus1
 :  forall A n x (xx: list A)
 ,  n > 0
 -> get n (xx :> x) = get (n - 1) xx.
Proof.
 intros. destruct n.
  inverts H.
  simpl. norm_nat. trivial.
Qed.
Hint Resolve get_minus1.

(* If a list contains an element at a particular index,
   then if we add a new element to the end of the list
   then it still contains the original element at that same index. *)
Lemma get_snoc_some
 :  forall A (xx: list A) n x1 x2
 ,  get n xx         = Some x1
 -> get n (x2 <: xx) = Some x1.
Proof.
 intros. gen n.
 induction xx; intros.
  destruct n.
   simpl in H. false.
   simpl in H. false.
  destruct n.
   simpl in H. simpl. trivial.
   simpl in H. simpl. apply IHxx. trivial.
Qed.
Hint Resolve get_snoc_some.

(* If a list contains an element at a particular index,
   then if we append more elements to the end of the ilst
   then it still contains the original element at that same index. *)
Lemma get_app_some
 :  forall A (l1: list A) (l2: list A) n x1
 ,  get n l1         = Some x1
 -> get n (l1 ++ l2) = Some x1.
Proof.
 intros. gen l1.
 induction l2; intros.
  rewrite app_nil_right. auto.
  rewrite app_snoc.
   eapply IHl2. apply get_snoc_some. auto.
Qed.
Hint Resolve get_app_some.

Lemma get_cons_some
 :  forall A n (e1: list A) x1 x2
 ,  get n e1               = Some x2
 -> get (n + 1) (e1 :> x1) = Some x2.
Proof.
 intros.
 destruct n.
  simpl. auto.
  simpl. norm_nat. auto.
Qed.
Hint Resolve get_cons_some.

Lemma get_app_left_some
 :  forall A n (e1 e2: list A) x1
 ,  get  n e1                      = Some x1
 -> get (n + length e2) (e2 ++ e1) = Some x1.
Proof.
 intros.
 induction e2.
  simpl. norm_nat. auto.
  assert ((e2 :> a) ++ e1 = (e2 ++ e1) :> a).
   simpl. auto.
  rewrite H0.
  assert (n + length (e2 :> a) = ((n + length e2) + 1)).
   norm_nat. simpl. auto.
  rewrite H1.
  rewrite <- (get_cons_some A (n + length e2) (e2 ++ e1) a).
   auto. auto.
Qed.
Hint Resolve get_app_left_some.

Lemma get_length_snoc_some
 : forall A x (xs: list A)
 , get (length xs) (x <: xs) = Some x.
Proof.
 intros.
 induction xs; simpl; auto.
Qed.
Hint Resolve get_length_snoc_some.
Hint Rewrite get_length_snoc_some : global.

(* We cannot get elements from a list at indices the same, or larger,
   than the length of that list *)
Theorem get_above_false
 :  forall A n (xx: list A) t
 ,  n >= length xx
 -> get n xx = Some t
 -> False.
Proof.
 intros. gen n t.
 induction xx; intros.
  simpl in H0. false.
  destruct n.
   simpl in H0. inverts H0. inverts H.
   simpl in H0. simpl in H.
   assert (n >= length xx). omega.
   eapply IHxx in H1. false. eauto.
Qed.
Hint Resolve get_above_false.

Lemma get_zero_nonempty_some
 :  forall {A} (us: list A)
 ,  length us > 0
 -> (exists x, get 0 us = Some x).
Proof.
 intros.
 destruct us.
  simpl in H. inverts H.
  simpl. eauto.
Qed.
Hint Resolve get_zero_nonempty_some.

Lemma get_same_length
 :  forall {A B} (xs: list A) x (ys: list B) i
 ,  length xs = length ys
 -> get i xs  = Some x
 -> exists y, get i ys = Some y.
Proof.
 intros. gen ys x i.
 induction xs; intros.
  have (ys = nil).
   subst. nope.
  destruct ys.
   nope.
   have (length xs = length ys).
   spec IHxs H1.
   destruct i.
    simpl in H0.
     inverts H0.
     exists b. eauto.
    simpl in H0.
    simpl.
    spec IHxs H0. auto.
Qed.
Hint Resolve get_same_length.

Lemma get_in_exists
 :  forall {A} (x : A) (xs : list A)
 ,  In x xs -> exists n, get n xs = Some x.
Proof.
 intros.
 induction xs.
  nope.
  simpl in H. inverts H.
   exists 0. simpl. auto.
   spec IHxs H0.
   destruct IHxs as [n].
   exists (S n).
   simpl. auto.
Qed.
Hint Resolve get_in_exists.

(********************************************************************)
(** Lemmas: in *)
Lemma in_head
 :  forall {A} (x : A) xs
 ,  In x (x :: xs).
Proof. firstorder. Qed.
Hint Resolve in_head.

Lemma in_tail
 :  forall {A} (a : A) b xs
 ,  a <> b
 -> In a (b :: xs) -> In a xs.
Proof.
 intros.
 apply get_in_exists in H0.
 destruct H0 as [n].
  destruct n.
  simpl in H0. inverts H0. tauto.
  simpl in H0. eapply get_in. eauto.
Qed.
Hint Resolve in_tail.

Lemma in_split
 :  forall {A} (x y : A) (xs : list A)
 ,  In x xs \/ x = y -> In x (y :: xs).
Proof.
 intros. inverts H.
  apply get_in_exists in H0.
  destruct H0 as [n].
  apply get_in with (n := S n).
  simpl. auto.
  firstorder.
Qed.
Hint Resolve in_split.

Lemma in_snoc
 :  forall {A} x a (xs: list A)
 ,  In x xs
 -> In x (a <: xs).
Proof.
 intros.
 induction xs.
  nope.
  simpl in H.
   inverts H.
   simpl. auto.
   simpl. eauto.
Qed.
Hint Resolve in_snoc.

Lemma in_app_split
 :  forall {A} (x : A) xs ys
 ,  In x (xs ++ ys)
 -> In x xs \/ In x ys.
Proof.
 intros.
 induction xs.
  - simpl.
    right. simpl in H. auto.
  - rrwrite ((ys >< (xs :> a)) = (ys >< xs) :> a) in H.
    simpl in H.
    inverts H.
    + left. auto.
    + rip.
      inverts IHxs.
      * left.
        auto.
      * rip.
Qed.
Hint Resolve in_app_split.

Lemma in_snoc_split
 :  forall {A} (x : A) y ys
 ,  In x (y <: ys)
 -> x = y \/ In x ys.
Proof.
 intros.
 rrwrite (y <: ys = (nil :> y) >< ys) in H.
 eapply in_app_split in H.
 inverts H.
 - tauto.
 - inverts H0.
   + tauto.
   + inverts H.
Qed.
Hint Resolve in_snoc_split.

Lemma in_app_left
 :  forall {A} x (xs ys: list A)
 ,  In x xs
 -> In x (xs ++ ys).
Proof.
 intros.
 eapply (@rev_ind A (fun ys => In x (xs ++ ys))); intros.
  rr. auto.
  rr. rrwrite ((x0 <: l) >< xs = (x0 <: (l >< xs))). eauto.
Qed.
Hint Resolve in_app_left.

Lemma in_app_right
 :  forall {A} x (xs ys: list A)
 ,  In x ys
 -> In x (xs ++ ys).
Proof.
 intros.
 induction xs.
  rr. auto.
  rrwrite ((a :: xs) ++ ys = a :: (xs ++ ys)).
  apply in_cons. auto.
Qed.
Hint Resolve in_app_right.

Lemma in_app_comm
 :  forall {A} (x : A) xs ys
 ,  In x (xs ++ ys)
 -> In x (ys ++ xs).
Proof.
 intros. gen ys.
 induction xs; intros.
  - rewrite app_nil_left in H.
    rewrite app_nil_right.
    auto.
  - simpl in H.
    inverts H.
    + rrwrite ((xs :> x) >< ys = xs >< (x <: ys)).
      eapply IHxs. eauto.
    + rrwrite ((xs :> a) >< ys = xs >< (a <: ys)).
      eapply in_app_split in H0.
      inverts H0.
      * apply in_app_right. auto.
      * apply in_app_left. auto.
Qed.
Hint Resolve in_app_comm.

Lemma in_not_in
 :  forall {A} (y z : A) xs
 ,    In y xs
 -> ~(In z xs)
 -> ~(y = z).
Proof.
 unfold not in *.
 intros. subst. auto.
Qed.
Hint Resolve in_not_in.


Require Import Iron.SimplePCFa.Step.
Require Import Iron.SimplePCFa.Value.

(********************************************************************)
(* Big Step Evaluation.
   This is also called 'Natural Semantics'.
   It provides a relation between the expression to be reduced
   and its final value.
 *)
Inductive EVAL : exp -> exp -> Prop :=

 (* Values are already evaluated ******)
 | EvDone
   : forall v2
   , EVAL (XVal v2) (XVal v2)

 (* Let Evaluation ********************)
 | EvLet
   :  forall t1 x1 v1 x2 x3
   ,  EVAL x1                (XVal v1)
   -> EVAL (substVX 0 v1 x2) x3
   -> EVAL (XLet t1 x1 x2)   x3

 (* Function Applications *************)
 | EvAppLam
   :  forall t11 x12 v2 x3
   ,  EVAL (substVX 0 v2 x12) x3
   -> EVAL (XApp (VLam t11 x12) v2) x3

 | EvFunApp
   :  forall t11 v12 v2 x3
   ,  EVAL (XApp (substVV 0 (VFix t11 v12) v12) v2) x3
   -> EVAL (XApp (VFix t11 v12) v2) x3

 (* Naturals **************************)
 | EvSucc
   :  forall n
   ,  EVAL (XOp1 OSucc (VConst (CNat n)))
           (XVal (VConst (CNat (S n))))

 | EvPredZero
   :  EVAL (XOp1 OPred (VConst (CNat O)))
           (XVal (VConst (CNat O)))

 | EvPredSucc
   :  forall n
   ,  EVAL (XOp1 OPred (VConst (CNat (S n))))
           (XVal (VConst (CNat n)))

 (* Booleans **************************)
 | EvIsZeroTrue
   :  EVAL (XOp1 OIsZero (VConst (CNat O)))
           (XVal (VConst (CBool true)))

 | EvIsZeroFalse
   :  forall n
   ,  EVAL (XOp1 OIsZero (VConst (CNat (S n))))
           (XVal (VConst (CBool false)))

 (* Branching *************************)
 | EvIfThen
   :  forall x2 x2' x3
   ,  EVAL x2 x2'
   -> EVAL (XIf (VConst (CBool true))  x2 x3) x2'

 | EvIfElse
   :  forall x2 x3 x3'
   ,  EVAL x3 x3'
   -> EVAL (XIf (VConst (CBool false)) x2 x3) x3'.

Hint Constructors EVAL.

Lemma eval_value
 :  forall x1 x2
 ,  EVAL x1 x2
 -> (exists v2, x2 = XVal v2).
Proof.
 intros.
 induction H; eauto.
Qed.
Hint Resolve eval_value.

(*****************************************************************************)
(* Eval to steps *)
Lemma eval_steps
 :  forall x1 x2
 ,  EVAL  x1 x2
 -> STEPS x1 x2.
Proof.
 admit.
Qed.
Hint Resolve eval_steps.

Lemma steps_eval
 :  forall x1 x2
 ,  STEPS x1 x2
 -> EVAL  x1 x2.
Proof.
 admit.
Qed.
Hint Resolve steps_eval.

(******************************************************************************)
(* Termination *)
Lemma term_steps_exists
 :  forall x
 ,  TERM x
 -> (exists x', STEPS x x').
Proof.
 intros.
 inverts H.
 induction H0; eauto.
Qed.
Hint Resolve term_steps_exists.

Lemma term_eval_exists
 :  forall x
 ,  TERM x
 -> (exists x', EVAL x x').
Proof.
 intros.
 have (exists x', STEPS x x').
 shift x'.
 eauto.
Qed.

Lemma term_eval_wrapped
 :  forall x1 f
 ,  TERMS f x1
 -> (exists x2, EVAL (wrap f x1) x2).
Proof. eauto. Qed.

Lemma term_steps_rewind
 : forall f x1 x2
 , TERMS f x2 -> STEPS x1 x2 -> TERMS f x1.
Proof.
 intros.
 induction H0; eauto.
 admit.  (* TODO *)
Qed.

(******************************************************************************)

(* If we have a big-step evaluation for some expression,
   then that expression terminates. *)
Lemma eval_term
 : forall x1 x2
 , EVAL x1 x2 -> TERM x1.
Proof.
 intros.
 induction H; eauto.

 Case "XLet".
  eapply RTerm.
  inverts IHEVAL1.
  inverts IHEVAL2.
  eapply term_steps_rewind.
  eauto.
  have (STEPS x1 (XVal v1))
   by (eapply eval_steps; auto).
  eapply SsAppend.
  eapply steps_context_let1. eauto.
  eapply SsStep.
  eauto.

 Case "XApp/VLam".
  eapply RTerm.
  eapply RfStep.
  eapply SpAppLam.
  inverts IHEVAL. eauto.

 Case "XApp/VFix".
  eapply RTerm.
  eapply RfStep.
  eapply SpAppFix.
  inverts IHEVAL. eauto.

 Case "XIfThen".
  inverts IHEVAL. eauto.
  inverts IHEVAL. eauto.
Qed.

Lemma eval_term_wrapped
 :  forall x1 x2 f
 ,  EVAL (wrap f x1) x2
 -> TERMS f x1.
Proof.
 intros.
 eapply eval_term in H.
 gen x1.
 induction f; intros.
  simpl in *. inverts H. auto.
  simpl in *.
  destruct a.
  lets D: IHf H. inverts D. auto.
   inverts H0.
Qed.
Hint Resolve eval_term_wrapped.

Lemma eval_eval_wrapped
 : forall x1 x2 f
 , EVAL (wrap f x1) x2 -> (exists x3, EVAL x1 x3).
Proof. burn. Qed.
Hint Resolve eval_eval_wrapped.


Section Declaration.
  Variable n : nat.
  Hypothesis Pos_n : (gt n 0).
  Definition one := S 0.
  Definition two : nat := S one.
  Definition three := S two : nat.
  Definition double (m:nat) := plus m m.
  Definition double' := fun m:nat => plus m m.
  Definition add_n (m:nat) := plus m n.

End Declaration.

Section Minimal_Logic.
  Variable A B C : Prop.
  Definition Ax1 := (A -> (B -> C)) -> (A -> B) -> (A -> C).
  Goal Ax1.
  unfold Ax1.
  intro H.
  intros H' HA.
  apply H.
  exact HA.
  apply H'.
  assumption.

  Save trivial_lemma.

  Lemma distr_impl: (A -> (B -> C)) -> ((A -> B) -> (A -> C)).
    intros.
    apply H; [ assumption | apply H0; assumption ].
  Qed.

  Lemma distr_impl': (A -> B -> C) -> (A -> B) -> (A -> C).
    auto.
  Qed.

  Inspect 5.

  Lemma and_commutative : A/\B -> B/\A.
    intro H; elim H; auto.
  Qed.

  Lemma or_commutative: A\/B -> B\/A.
    intro H; elim H.
    intro HA.
    clear H.
    clear C.
    right.
    assumption.
    auto.
  Restart.
    tauto.
  Qed.

  Lemma distr_and : (A -> B/\C) -> (A -> B) /\ (A -> C).
    tauto.
  Qed.

  Lemma Peirce : ((A -> B) -> A) -> A.
    try tauto.
  Abort.

  Lemma NNPeirce : ~~(((A -> B) -> A) -> A).
    tauto.
  Qed.

  Require Import Classical.

  Lemma Peirce : ((A -> B) -> A) -> A.
    apply NNPP; tauto.
  Qed.

  Section club.

  Variables Scottish RedSocks WearKilt Married GoOutSunday : Prop.
  Hypothesis rule1 : ~Scottish -> RedSocks.
  Hypothesis rule2 : WearKilt \/ ~RedSocks.
  Hypothesis rule3 : Married -> ~GoOutSunday.
  Hypothesis rule4 : GoOutSunday <-> Scottish.
  Hypothesis rule5 : WearKilt -> Scottish/\Married.
  Hypothesis rule6 : Scottish -> WearKilt.

  Lemma NoMember : False.
    tauto.
  Qed.

  End club.