Require Export ZArith.
Require Export Zwf.
Require Export Inverse_Image.
Require Export Wellfounded.

Section little_abstract_semantics.
Variables
  (Var aExp bExp state : Set)
  (evalA : state -> aExp -> option Z)
  (evalB : state -> bExp -> option bool)
  (update : state -> Var -> Z -> option state).

Inductive inst : Set :=
  | Skip : inst
  | Assign : Var -> aExp -> inst
  | Scolon : inst -> inst -> inst
  | WhileDo : bExp -> inst -> inst.

Arguments Some [A] _.

(* The semantics of the language is given in chapter 7. *)

Inductive exec : state -> inst -> state -> Prop :=
  | execSkip : forall s:state, exec s Skip s
  | execAssign :
      forall (s s1:state) (v:Var) (n:Z) (a:aExp),
        evalA s a = Some n ->
        update s v n = Some s1 -> exec s (Assign v a) s1
  | execScolon :
      forall (s s1 s2:state) (i1 i2:inst),
        exec s i1 s1 -> exec s1 i2 s2 -> exec s (Scolon i1 i2) s2
  | execWhileFalse :
      forall (s:state) (i:inst) (e:bExp),
        evalB s e = Some false -> exec s (WhileDo e i) s
  | execWhileTrue :
      forall (s s1 s2:state) (i:inst) (e:bExp),
        evalB s e = Some true ->
        exec s i s1 -> exec s1 (WhileDo e i) s2 -> exec s (WhileDo e i) s2.
(* We need to use the evaluation functions as if they were total.  extract_option
   makes them total by adding a default value. *)

Definition extract_option {A:Type} (x:option A) (def:A) : A :=
  match x with
  | None => def
  | Some v => v
  end.

(* When a while loop contains a variable that is decreased at each
  step and tested against a bound, it is obvious that this loop will
  terminate.  We consider such loops are "for" loops.*)

Inductive forLoops : inst -> Prop :=
  | aForLoop :
      forall (e:bExp) (i:inst) (variant:aExp),
        (forall s s':state,
           evalB s e = Some true ->
           exec s i s' ->
           Zwf 0 (extract_option (evalA s' variant) 0%Z)
             (extract_option (evalA s variant) 0%Z)) ->
        forLoops i -> forLoops (WhileDo e i)
  | assignFor : forall (v:Var) (e:aExp), forLoops (Assign v e)
  | skipFor : forLoops Skip
  | scolonFor :
      forall i1 i2:inst,
        forLoops i1 -> forLoops i2 -> forLoops (Scolon i1 i2).

(* Following a suggestion by C. McBride and J. McKinna in "The view from the left. "
  we use an auxillary function to perform case analysis instead of using dependent
  pattern-matching construct.  This relies on a "sister type" where pattern matching
  information is gathered in an equality. *)

Inductive inst_cases_type (i:inst) : Set :=
  | is_Skip : i = Skip -> inst_cases_type i
  | is_assign : forall (v:Var) (e:aExp), i = Assign v e -> inst_cases_type i
  | is_seq : forall i1 i2:inst, i = Scolon i1 i2 -> inst_cases_type i
  | is_while :
      forall (b:bExp) (i':inst), i = WhileDo b i' -> inst_cases_type i.

(* We avoid dependent pattern matching in the main function, but of course
  this auxillary function has to do the dirty work. *)

Definition inst_cases (i:inst) : inst_cases_type i :=
  match i as x return inst_cases_type x with
  | Assign v e => is_assign (Assign v e) v e (refl_equal (Assign v e))
  | Scolon i1 i2 => is_seq (Scolon i1 i2) i1 i2 (refl_equal (Scolon i1 i2))
  | WhileDo b i => is_while (WhileDo b i) b i (refl_equal (WhileDo b i))
  | Skip => is_Skip Skip (refl_equal Skip)
  end.

(* We are going to use recursion on an ad-hoc predicate to define our function.
  This requires that we prove inversion lemmas by case analysis and make sure
  these lemmas are transparent. *)

Theorem forLoops_Inv_seq1 :
 forall i:inst,
   forLoops i -> forall i1 i2:inst, i = Scolon i1 i2 -> forLoops i1.
Proof.
intros i h; case h; try (intros; discriminate).
intros i1 i2 H H0 i0 i3 H1; injection H1.
intros heq2 heq1; rewrite <- heq1; assumption.
Defined.

Theorem forLoops_Inv_seq2 :
 forall i:inst,
   forLoops i -> forall i1 i2:inst, i = Scolon i1 i2 -> forLoops i2.
Proof.
intros i h; case h; try (intros; discriminate).
intros i1 i2 H H0 i0 i3 H1; injection H1.
intros heq2 heq1; rewrite <- heq2; assumption.
Defined.

Theorem forLoops_Inv_while2 :
 forall i:inst,
   forLoops i -> forall (b:bExp) (i':inst), i = WhileDo b i' -> forLoops i'.
Proof.
 intros i h; case h; try (intros; discriminate).
 intros e i0 variant H H0 b i' H1; injection H1.
 intros heq2 heq1; rewrite <- heq2; assumption.
Defined.

Inductive exec_or_not (s:state) (i:inst) : Set :=
  | result : forall s':state, exec s i s' -> exec_or_not s i
  | no_result : (forall s':state, ~ exec s i s') -> exec_or_not s i.

Parameter
  exec_det :
    forall (s s' s'':state) (i:inst), exec s i s' -> exec s i s'' -> s' = s''.

(* We invent a new relation indexed by instructions and boolean expressions.
  If the indexes are i and b, we say that two states s1 and s2 are related if
  s1 is the result of executing i from state s2 and if b evaluates to true in b.
  Intuitively, i will be used as the body of a while loop construct and b as the
  halting condition for this loop.  In general, this relation is NOT well-founded.*)

Definition state_loop_order (i:inst) (b:bExp) (s1 s2:state) : Prop :=
  evalB s2 b = Some true /\ exec s2 i s1.

(* If the loop (WhileDo b i) is a "for" loop, then there is something
  that decreases each time the loop body is executed (by definition).
  This makes it possible to prove that the relation (state_loop_order i b) is
  well-founded.*)

Theorem state_loop_order_wf :
 forall (b:bExp) (i:inst),
   forLoops (WhileDo b i) -> well_founded (state_loop_order i b).
Proof.
  intros b i h; inversion h.
  apply wf_incl with
  (fun s1 s2:state =>
     Zwf 0 (extract_option (evalA s1 variant) 0%Z)
         (extract_option (evalA s2 variant) 0%Z)).
   unfold Relation_Definitions.inclusion in |- *.
   unfold state_loop_order in |- *; intros x y [H3 H4].
   apply H1.
   apply H3.
   apply H4.
   apply
     (wf_inverse_image state Z (Zwf 0)
                       (fun s:state => extract_option (evalA s variant) 0%Z)
                       (Zwf_well_founded 0)).
Qed.

(* If i is the Skip instruction, it is always possible to decide whether
   executing i will succeed or not.*)

Lemma exec_skip : forall (i:inst) (s:state), i = Skip -> exec_or_not s i.
Proof.
  intros i s heq;
 exact (result s i s (eq_ind_r (fun j:inst => exec s j s) (execSkip s) heq)).
Defined.

(* If i is an assignment, it is always possible to decide whether
  executing i will succeed or not.*)

Lemma exec_assign :
 forall (i:inst) (s:state) (v:Var) (e:aExp),
   i = Assign v e -> exec_or_not s i.
Proof.
 intros i s v e heq; case_eq (evalA s e).
 - intros v' heqa; case_eq (update s v v').
   + intros s' Hequ; apply (result s i s').
     rewrite heq.
     apply execAssign with v'; assumption.
   + intros heq_None; apply no_result.
     rewrite heq; intros s' H; inversion H.
     rewrite heqa in H3; injection H3.
     intros heqv'; rewrite heqv' in heq_None; rewrite H5 in heq_None.
     discriminate.
 - intros heq_None; apply no_result.
   rewrite heq; intros s' H; inversion H.
   rewrite H3 in heq_None; discriminate.
Defined.

(* If i is a sequence of two instructions and we already have two functions
   that can decide the success of execution for these instructions, then
   deciding the success for these instructions is an easy matter.*)

Lemma exec_sequence :
 forall (i:inst) (s:state) (i1 i2:inst),
   i = Scolon i1 i2 ->
   forall (f1:forall s:state, exec_or_not s i1)
     (f2:forall s:state, exec_or_not s i2), exec_or_not s i.
Proof.
 intros i s i1 i2 heq f1 f2.
 case (f1 s).
 - intros s1 Hexec1; case (f2 s1).
   + intros s2 Hexec2; apply (result s i s2).
     rewrite heq; apply execScolon with s1; assumption.
   + intros Hnot; apply no_result.
     rewrite heq.
     intros s'; red in |- *; intros H; inversion H.
     elim (Hnot s').
     rewrite (exec_det s s1 s2 i1); assumption.
 - intros Hnot; apply no_result.
   rewrite heq.
   intros s' H; inversion H.
   elim (Hnot s1); assumption.
Defined.

(** Now comes the difficult part.  If i is a loop, the body of which is i',
  then it is in general not possible to decide whether the execution will
  succeed or not.  On the other hand, if the loop is a "for" loop and we
  are given a function that can decide whether executing i' succeeds, then
  we can use well-founded recursion to define a function that repeats
  the body as many times until execution fails or succeeds.  This is
  guaranteed to terminate thanks to the proof of state_loop_order_wf. *)

Lemma exec_forLoop :
 forall (i i':inst) (b:bExp) (s:state),
   i = WhileDo b i' ->
   forLoops (WhileDo b i') ->
   forall f:forall s:state, exec_or_not s i', exec_or_not s i.
Proof.
 intros i i' b s heq h' f;
  apply
    (well_founded_induction (state_loop_order_wf b i' h')
                            (fun s:state => exec_or_not s i)).
 intros s0 loop_again.
 case_eq (evalB s0 b).
 -  intros vb; case vb.
    + intros heqCond; elim (f s0).
      * intros s1 Hexeci'; elim (loop_again s1).
       intros s2 Hexeci; apply (result s0 i s2).
       rewrite heq.
       apply execWhileTrue with (s1 := s1); try assumption.
       rewrite <- heq.
       apply Hexeci.
       intros Hnot; apply no_result.
       rewrite heq; intros s' H; inversion H.
       rewrite H2 in heqCond.
       rewrite heqCond in H4.
       discriminate H4.
       elim (Hnot s').
       rewrite (exec_det s0 s1 s3 i'); try assumption.
       rewrite heq.
       assumption.
       split; assumption.
    * intros Hnot; apply no_result.
      rewrite heq; intros s' H; inversion H.
      rewrite H2 in heqCond; rewrite H4 in heqCond.
      discriminate.
      elim (Hnot s2); assumption.
    + intros heqCond; apply (result s0 i s0).
      rewrite heq.
      apply execWhileFalse; assumption.
 - intros heqCond; apply no_result.
   rewrite heq.
   intros s' H; inversion H.
   rewrite H2 in heqCond.
   rewrite H4 in heqCond; discriminate heqCond.
   rewrite H2 in heqCond.
discriminate heqCond.
Defined.

(*This is the main recursive function.  Note that its definition relies on
  the advanced technique of recursion on an ad-hoc predicate.  In fact, the
  whole execution process relies on a nested recursion, since loops are
  executed using well-founded recursion inside the exec_forLoop function.*)

Definition exl : forall i:inst, forLoops i -> forall s:state, exec_or_not s i.
refine
 (fix exl (i:inst) (h:forLoops i) {struct h} :
    forall s:state, exec_or_not s i :=
    fun s =>
      match inst_cases i with
      | is_Skip _ heq => exec_skip i s heq
      | is_assign _ v e heq => exec_assign i s v e heq
      | is_seq _ i1 i2 heq => exec_sequence i s i1 i2 heq _ _
      | is_while _ b i' heq => exec_forLoop i i' b s heq _ _
      end).
Proof.
  exact (exl i1 (forLoops_Inv_seq1 i h i1 i2 heq)).
  exact (exl i2 (forLoops_Inv_seq2 i h i1 i2 heq)).
  rewrite <- heq; assumption.
  exact (exl i' (forLoops_Inv_while2 i h b i' heq)).
Defined.
(* This function has the type required in the exercise. *)

Definition execute_loops :
  forall (s:state) (i:inst),
    forLoops i ->
    {s' : state | exec s i s'} + {(forall s':state, ~ exec s i s')}.
Proof.
  intros s i h; elim (exl i h s).
  - left; exists s'; assumption.
  -right; assumption.
Defined.

End little_abstract_semantics.

(* This is not part of the exercise. *)

(* Here we want to instantiate the various types to build a minimal
   programming language and show we can build a program that satisfies
   the "forLoops" predicate. *)

Arguments Some [A] _.

Require Export List.
Require Export Arith.
Require Export Compare_dec.
Require Export Omega.

Inductive aExp : Set :=
  | aPlus : aExp -> aExp -> aExp
  | aNum : Z -> aExp
  | aVar : nat -> aExp.

Inductive bExp : Set :=
    bGt : aExp -> aExp -> bExp.

Definition state := list Z.

Fixpoint lookup (idx:nat) (s:state) {struct idx} :
 option Z :=
  match idx, s with
  | O, a :: _ => Some a
  | S p, _ :: tl => lookup p tl
  | _, _ => None (A:=Z)
  end.

Fixpoint evalA (s:state) (e:aExp) {struct e} : option Z :=
  match e with
  | aPlus e1 e2 =>
      match evalA s e1, evalA s e2 with
      | Some n1, Some n2 => Some (n1 + n2)%Z
      | _, _ => None (A:=Z)
      end
  | aNum n => Some n
  | aVar n => lookup n s
  end.

Definition evalB (s:state) (e:bExp) : option bool :=
  match e with
  | bGt e1 e2 =>
      match evalA s e1, evalA s e2 with
      | Some n1, Some n2 =>
          match Z_le_gt_dec n1 n2 with
          | left _ => Some false
          | right _ => Some true
          end
      | _, _ => None (A:=bool)
      end
  end.

Fixpoint update (s:state) (n:nat) (x:Z) {struct n} :
 option state :=
  match s, n with
  | a :: tl, O => Some (x :: tl)
  | a :: tl, S p =>
      match update tl p x with
      | Some tl' => Some (a :: tl')
      | _ => None (A:=state)
      end
  | _, _ => None (A:=state)
  end.

Implicit Arguments Assign [Var aExp bExp].
Implicit Arguments WhileDo [Var aExp bExp].
Implicit Arguments Scolon [Var aExp bExp].

Example fact3 :=
  Scolon (Assign 1 (aNum 3))
    (Scolon (Assign 2 (aNum 1))
       (WhileDo (bGt (aVar 1) (aNum 0))
          (Scolon (Assign 0 (aVar 1))
             (Scolon (Assign 1 (aPlus (aVar 1) (aNum (-1))))
                (Scolon (Assign 3 (aVar 2))
                   (Scolon (Assign 2 (aNum 0))
                      (WhileDo (bGt (aVar 0) (aNum 0))
                         (Scolon (Assign 0 (aPlus (aVar 0) (aNum (-1))))
                            (Assign 2 (aPlus (aVar 2) (aVar 3))))))))))).

Fixpoint noAssign (n:nat) (i:inst nat aExp bExp) {struct i} : bool :=
  match i with
  | Skip _ _ _  => true
  | Scolon  i1 i2 =>
      match noAssign n i1 with
      | true => noAssign n i2
      | false => false
      end
  | WhileDo b i' => noAssign n i'
  | Assign v e =>
      match eq_nat_dec v n with
      | left _ => false
      | right _ => true
      end
  end.

Theorem lookup_update_eq :
 forall (n:nat) (s s':state) (v:Z),
   update s n v = Some s' -> lookup n s' = Some v.
Proof.
simple induction n.
- intros s; case s.
  + intros; discriminate.
  + simpl in |- *; intros z tl s' v Heq; injection Heq; intros Heq1;
    rewrite <- Heq1; trivial.
- intros p Hrec s; case s; simpl in |- *; try (intros; discriminate).
  intros z l s' v; generalize (fun s':state => Hrec l s' v).
  case (update l p v); simpl in |- *; try (intros; discriminate).
  intros s'0 Hrec' Heq; injection Heq; intros Heq1; rewrite <- Heq1;
 simpl in |- *; rewrite Hrec'; auto.
Qed.

Theorem lookup_update_diff :
 forall (n m:nat) (s s':state) (v:Z),
   update s n v = Some s' -> n <> m -> lookup m s' = lookup m s.
Proof.
 simple induction n.
 - intros m; case m.
   + intros s s' v H H1; elim H1; auto.
   + intros m' s; case s; simpl in |- *; try (intros; discriminate).
     * intros z tl s' v Heq; injection Heq; intros Heq1; now rewrite <- Heq1.
 - intros p Hrec m; case m; simpl in |- *.
   + intros s; case s; simpl in |- *; try (intros; discriminate).
     intros z l s' v; case (update l p v); simpl in |- *;
     try (intros; discriminate).
     intros s'0 Heq; injection Heq; intros Heq1; now rewrite <- Heq1.
   + intros m' s; case s; simpl in |- *; try (intros; discriminate).
     intros z l s' v; generalize (fun s':state => Hrec m' l s' v);
     case (update l p v); try (intros; discriminate).
     intros s'0 Hrec' Heq; injection Heq; intros Heq1; rewrite <- Heq1.
     intros Hneq; apply Hrec'; auto with arith.
Qed.

Theorem noAssign_noChange :
 forall (n:nat) (i:inst nat aExp bExp),
   noAssign n i = true ->
   forall s s':state,
     exec nat aExp bExp state evalA evalB update s i s' ->
     evalA s (aVar n) = evalA s' (aVar n).
Proof.
  intros n i Heq s s' Hexec; generalize n Heq; clear Heq n;  elim Hexec.
  -  auto.
  - simpl in |- *;
    intros s0 s1 v n' a Heval Hupdate n; case (eq_nat_dec v n).
    + discriminate.
    + intros; symmetry  in |- *; apply lookup_update_diff with v n'; auto.
  - simpl in |- *; intros s0 s1 s2 i1 i2 Hex1 Hrec1 Hex2 Hrec2 n.
    generalize (Hrec1 n) (Hrec2 n); clear Hrec1 Hrec2.
    case (noAssign n i1); simpl in |- *; try (intros; discriminate).
    case (noAssign n i2); simpl in |- *; try (intros; discriminate).
    transitivity (lookup n s1); auto.
 - auto.
 - simpl in |- *; intros s0 s1 s2 i' b Heval Hex1 Hrec1 Hex2 Hrec2 n;
   generalize (Hrec1 n) (Hrec2 n); clear Hrec1 Hrec2.
   intros; transitivity (lookup n s1); auto.
Qed.

Theorem forLoops_fact3 :
 forLoops nat aExp bExp state evalA evalB update fact3.
Proof.
 unfold fact3 in |- *; repeat constructor.
 apply aForLoop with (aVar 1).
 intros s; case s.
 -  intros s' Hevgt1 Hexec1; inversion Hexec1.
    inversion H2; simpl in H10; discriminate.
 -  intros v0 s0; case s0.
    +  intros s' Hevgt1 Hexec1; inversion Hexec1.
       inversion H2.
       simpl in H8; discriminate.
    +  intros v1 s1 s' Hevgt1 Hexec1; inversion Hexec1.
       inversion H2.
       simpl in H8.
       simpl in H10.
       injection H8; clear H8; intros H8.
       subst v1; clear Hexec1; inversion H4.
       rewrite <- noAssign_noChange with (2 := H15).
       *  inversion H13.
          simpl in H19.
          injection H10.
          intros Heq1.
          rewrite <- Heq1 in H19, H21.
          injection H19; clear H19; intros H19.
          rewrite <- H19 in H21; simpl in H21; injection H21.
          intros Heq2; rewrite <- Heq2; simpl in |- *.
          unfold Zwf in |- *; auto with zarith.
          inversion Hevgt1.
          generalize H23;
            case (Z_le_gt_dec n 0); simpl in |- *; try (intros; discriminate).
          intros; omega.
       *  simpl in |- *; auto.
 - repeat constructor.
   apply aForLoop with (aVar 0).
  +  intros s s'; lazy beta iota zeta delta [evalB] in |- *; fold evalB in |- *.
     intros Hevgt Hexec; inversion Hexec.
     inversion H2.
     rewrite <- noAssign_noChange with (2 := H4).
     *  lazy beta iota zeta delta [evalA] in H8; fold evalA in H8.
        generalize H8; clear H8; case_eq (lookup 0 s).
        intros z Hlk H8; injection H8; clear H8; intros H8.
        lazy beta iota zeta delta [evalA] in |- *.
        rewrite lookup_update_eq with (1 := H10).
        rewrite Hlk; rewrite <- H8.
        generalize Hevgt; lazy beta iota zeta delta [evalA] in |- *.
        rewrite Hlk.
        case (Z_le_gt_dec z 0); simpl in |- *; try (intros; discriminate).
        unfold Zwf in |- *; intros; omega.
        intros; discriminate.
     * simpl in |- *; auto.
+ repeat constructor.
Qed.

Definition execute_loops2 :=
  execute_loops nat aExp bExp state evalA evalB update.

Definition value :=
  execute_loops2 (0%Z :: 0%Z :: 0%Z :: 0%Z :: nil) fact3 forLoops_fact3.

(* We use extracted code to test the value of our program instead of
  evaluating inside Coq *)

Extraction "execute_loops" execute_loops2 fact3 value.


Parameter A : Set.
Definition Eq : A -> A -> Prop :=
  fun a => fun b => forall P : A -> Prop, P a <-> P b.

Lemma Eq_eq : forall x y, Eq x y <-> x = y.
Proof.
  unfold Eq.
  intros x y; split.
    - intro E.
    destruct (E (fun z => x = z)).
    apply (H (eq_refl x)).
    - intro E.
    subst; split; auto.
Qed.


(** Numbers up to @n@ **)
Require Coq.Lists.List.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Tactics.EqDep.
Require Import ExtLib.Tactics.Injection.

Set Implicit Arguments.
Set Strict Implicit.
Set Asymmetric Patterns.

(** `fin n` corresponds to "naturals less than `n`",
 ** i.e. a finite set of size n
 **)
Inductive fin : nat -> Type :=
| F0 : forall {n}, fin (S n)
| FS : forall {n}, fin n -> fin (S n).

Fixpoint fin_all (n : nat) : list (fin n) :=
  match n as n return list (fin n) with
    | 0 => nil
    | S n => @F0 n :: List.map (@FS _) (fin_all n)
  end%list.

Theorem fin_all_In : forall {n} (f : fin n),
  List.In f (fin_all n).
Proof.
  induction n; intros.
  inversion f.
  remember (S n). destruct f.
  simpl; firstorder.
  inversion Heqn0. subst.
  simpl. right. apply List.in_map. auto.
Qed.

Theorem fin_case : forall n (f : fin (S n)),
  f = F0 \/ exists f', f = FS f'.
Proof.
  intros. generalize (fin_all_In f). intros.
  destruct H; auto.
  eapply List.in_map_iff in H. right. destruct H.
  exists x. intuition.
Qed.

Definition fin0_elim (f : fin 0) : forall T, T :=
  match f in fin n return match n with
                            | 0 => forall T, T
                            | _ => unit
                          end with
    | F0 _ => tt
    | FS _ _ => tt
  end.

Fixpoint pf_lt (n m : nat) : Prop :=
  match n , m with
    | 0 , S _ => True
    | S n , S m => pf_lt n m
    | _ , _ => False
  end.

Fixpoint make (m n : nat) {struct m} : pf_lt n m -> fin m :=
  match n as n , m as m return pf_lt n m -> fin m with
    | 0 , 0 => @False_rect _
    | 0 , S n => fun _ => F0
    | S n , 0 => @False_rect _
    | S n , S m => fun pf => FS (make m n pf)
  end.

Notation "'##' n" := (@make _ n I) (at level 0).

Global Instance Injective_FS {n : nat} (a b : fin n)
  : Injective (FS a = FS b).
refine {| result := a = b |}.
abstract (intro ; inversion H ; eapply inj_pair2 in H1 ; assumption).
Defined.

Fixpoint fin_eq_dec {n} (x : fin n) {struct x} : fin n -> bool :=
  match x in fin n' return fin n' -> bool with
    | F0 _ => fun y => match y with
                         | F0 _ => true
                         | _ => false
                       end
    | FS n' x' => fun y : fin (S n') =>
      match y in fin n'' return (match n'' with
                                   | 0 => unit
                                   | S n'' => fin n''
                                 end -> bool) -> bool with
        | F0 _ => fun _ => false
        | FS _ y' => fun f => f y'
      end (fun y => fin_eq_dec x' y)
    end.

Global Instance RelDec_fin_eq (n : nat) : RelDec (@eq (fin n)) :=
{ rel_dec := fin_eq_dec }.

Global Instance RelDec_Correct_fin_eq (n : nat)
  : RelDec_Correct (RelDec_fin_eq n).
Proof.
  constructor.
  induction x. simpl.
  intro. destruct (fin_case y) ; subst.
  intuition.
  destruct H ; subst.
  intuition ; try congruence.
(*  inversion H.*)
  intro ; destruct (fin_case y) ; subst ; simpl.
  intuition ; try congruence.
  inversion H.
  destruct H ; subst.
  split ; intro.
  f_equal ; eauto.
  eapply IHx.
  eapply H.
  inv_all ; subst.
  apply IHx. reflexivity.
Qed.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Category.
Require Import Blech.Category.Bsh.

Import CategoryNotations.
Import BishopNotations.

Open Scope category_scope.
Open Scope bishop_scope.

#[local]
#[program]
Definition fin N := {x | x ≤ N} /~ {| equiv x y := proj1_sig x = proj1_sig y |}.

Next Obligation.
Proof.
  cbn in *.
  exists.
  - intros ?.
    reflexivity.
  - intros ? ? ?.
    symmetry.
    assumption.
  - intros ? ? ? p q.
    rewrite p, q.
    reflexivity.
Qed.

#[program]
Definition FinSet: Category := {|
  Obj := nat ;
  Mor A B := Bsh (fin A) (fin B) ;

  id _ := id _ ;
  compose _ _ _ := @compose _ _ _ _ ;

  compose_assoc _  _ _ _ f g h := @compose_assoc Bsh _ _ _ _ f g h ;
  compose_id_left _ _ f := @compose_id_left Bsh _ _ f ;
  compose_id_right _ _ f := @compose_id_right Bsh _ _ f ;

  compose_compat _ _ _ f f' g g' := @compose_compat Bsh _ _ _ f f' g g' ;
|}.


Require Export ast.
Require Export Coq.Arith.Peano_dec.

(*General Purpose tactics*)
Ltac inv H := inversion H; subst; clear H.
Ltac copy H :=
  match type of H with
      |?x => assert(x) by auto
  end.
Ltac invertHyp :=
  match goal with
      |H:exists x, ?P |- _ => inv H; try invertHyp
      |H: ?P /\ ?Q |- _ => inv H; try invertHyp
  end.

(*maps locations to terms and time stamps*)
Definition heap := list (location * term * stamp).

Fixpoint lookup (H:heap) (l:location) :=
  match H with
      |(l', v, stamp)::H' => if eq_nat_dec l l'
                            then Some (v, stamp)
                            else lookup H' l
      |nil => None
  end.

Theorem lookupExtension : forall Hnew H l v S,
                            lookup H l  = Some(v, S) ->
                            exists v' S', lookup (Hnew++H) l = Some(v', S').
Proof.
  induction Hnew; intros.
  {simpl. exists v. exists S. assumption. }
  {simpl. destruct a. destruct p. destruct (eq_nat_dec l l0).
   {subst. exists t. exists s. reflexivity. }
   {eapply IHHnew in H0. invertHyp. exists x. exists x0. assumption. }
  }
Qed.

Theorem lookupDeterministic : forall H l v v' S S',
                                 lookup H l = Some(v, S) -> lookup H l = Some(v', S') ->
                                 v = v' /\ S = S'.
Proof.
  induction H; intros.
  {inv H. }
  {simpl in *. destruct a. destruct p. destruct (eq_nat_dec l l0).
   {inv H0. inv H1. auto. }
   {eapply IHlist in H0; eauto. invertHyp. auto. }
  }
Qed.

(*Extensional equality for heaps*)
Definition heapExtEq H1 H2 := forall l, lookup H1 l = lookup H2 l.


Require Import base.

(* Need(?) the -noinit flag *)

(* Inspired by https://github.com/coq-contribs/zfc/blob/master/zfc.v *)

Require Import Ltac.
Require Import Logic.
(* Attempting to reason without classical logic is too hard (and useless) *)
Require Import Classical.

(* ens ("superset") (transformation function) *)
Inductive Ensemble : Type := ens : forall A : Type, (A -> Ensemble) -> Ensemble.
Definition pi1e (e : Ensemble) := let (A, _) := e in A.
Definition pi2e (e : Ensemble) := match e return pi1e e -> Ensemble with ens _ f => f end.
Lemma ens_pi_is_orig : forall a : Ensemble, a = ens (pi1e a) (pi2e a).
Proof. by intros [A f]; exact (eq_refl _). Qed.
Fixpoint Ensemble_eq (a b : Ensemble) : Prop := let (a', f) := a in let (b', g) := b in
	   (forall x : a', exists y : b', Ensemble_eq (f x) (g y))
	/\ (forall y : b', exists x : a', Ensemble_eq (f x) (g y)).
Definition In (a B : Ensemble) := let (B', f) := B in exists b : B', Ensemble_eq a (f b).
Infix "inE" := In (at level 70, no associativity).
Notation "a 'not_in' b" := (~ (a inE b)) (at level 70, no associativity).
Definition Included (A B : Ensemble) : Prop :=
	forall e : Ensemble, (e inE A) -> (e inE B).
Infix "incl" := Included (at level 70, no associativity).
Definition NotIncluded (A B : Ensemble) : Prop :=
	exists e : Ensemble, (e inE A) /\ ~(e inE B).
Infix "not_incl" := NotIncluded (at level 70, no associativity).

Axiom extensionality_axiom
	: forall (A B : Ensemble), (forall x, ((x inE A) <-> (x inE B))) -> (A = B).
Axiom pairing_axiom
	: forall A B : Ensemble, exists C : Ensemble, forall x : Ensemble,
	(x inE C) <-> ((x = A) \/ (x = B)).
Axiom union_axiom
	: forall A : Ensemble, exists C : Ensemble, forall x,
	(x inE C) <-> exists Y, (Y inE A) /\ (x inE Y).
Axiom power_set_axiom : forall A : Ensemble, exists C : Ensemble,
	forall X, (X inE C) <-> (X incl A).
Axiom empty_set_axiom : exists E : Ensemble, E = E.
Axiom schema_restricted_comprehension_axiom :
	forall (P : Ensemble -> Prop) (A : Ensemble),
	exists C : Ensemble, forall x,
	(x inE C) <-> ((x inE A) /\ (P x)).

(* Ensemble_eq is defined by induction in a sense *)
Lemma Eeq_refl : forall a : Ensemble, Ensemble_eq a a.
Proof.
	by intros a; induction a as [a f IHa]; split;
	  intros x; exists x; exact (IHa x).
Qed.
Lemma Eeq_trans : forall a b c : Ensemble, Ensemble_eq a b -> Ensemble_eq b c -> Ensemble_eq a c.
Proof.
	intros a; induction a as [a f IHa]; intros [b g] [c h].
	minimize Ensemble_eq; intros [ainclb bincla] [binclc cinclb]; split.
	clear bincla cinclb; intros x.
	specialize (ainclb x) as [y xinbbyy]; specialize (binclc y) as [z yincbyz].
	by exists z; exact (IHa _ _ _ xinbbyy yincbyz).
	clear ainclb binclc; intros z.
	specialize (cinclb z) as [y zinbbyy]; specialize (bincla y) as [x yinabyx].
	by exists x; exact (IHa _ _ _ yinabyx zinbbyy).
Qed.
Lemma Eeq_sym : forall (a b : Ensemble), (Ensemble_eq a b) -> (Ensemble_eq b a).
Proof.
	intros a; induction a as [a f IHa]; intros [b g] [ainclb bincla]; split.
	by intros y; specialize (bincla y) as [x Hx]; exists x; exact (IHa _ _ Hx).
	by intros x; specialize (ainclb x) as [y Hy]; exists y; exact (IHa _ _ Hy).
Qed.
Lemma Eeq_is_eq : forall (a b : Ensemble), (Ensemble_eq a b) -> (a = b).
Proof.
	intros [a f] [b g] [ainclb bincla].
	apply extensionality_axiom; intros x; split.
	by intros [xa xinabyxa];
	   specialize (ainclb xa) as [y fxaeqgy];
	   exists y;
	   exact (Eeq_trans _ _ _ xinabyxa fxaeqgy).
	by intros [xb xinbbyxb];
	   specialize (bincla xb) as [y fyeqgxb];
	   exists y;
	   exact (Eeq_trans _ _ _ xinbbyxb (Eeq_sym _ _ fyeqgxb)).
Qed.
Lemma eq_is_Eeq : forall (a b : Ensemble), (a = b) -> (Ensemble_eq a b).
Proof. by intros a ? H; rewrite <-H; exact (Eeq_refl a). Qed.
Arguments Eeq_refl a : clear implicits.
Arguments Eeq_trans {a b c} ainclb binclc.
Arguments Eeq_sym {a b} ainclb.
Arguments Eeq_is_eq {a b} aEeqb.
Arguments eq_is_Eeq {a b} aeqb.

Lemma incl_refl : forall a : Ensemble, a incl a.
Proof. by intros a b bina; exact bina. Qed.
Lemma incl_trans : forall a b c : Ensemble, a incl b -> b incl c -> a incl c.
Proof.
	intros a b c ainclb binclc x xina.
	by exact (binclc _ (ainclb _ xina)).
Qed.
Lemma incl_antisym : forall a b : Ensemble, a incl b -> b incl a -> Ensemble_eq a b.
Proof.
	intros [a f] [b g] ainclb bincla; split.
	intros x.
	assert (fxina : f x inE (ens a f)) by (exists x; exact (Eeq_refl _)).
	by exact (ainclb _ fxina).
	intros y.
	assert (gyinb : g y inE (ens b g)) by (exists y; exact (Eeq_refl _)).
	specialize (bincla _ gyinb) as [x gyeqfx].
	by exists x; exact (Eeq_sym gyeqfx).
Qed.
Lemma Eeq_incl_l : forall a b : Ensemble, Ensemble_eq a b -> a incl b.
Proof.
	by intros a b aeqb; rewrite (Eeq_is_eq aeqb); exact (incl_refl _).
Qed.
Lemma Eeq_incl_r : forall a b : Ensemble, Ensemble_eq a b -> b incl a.
Proof.
	by intros a b beqa; rewrite (Eeq_is_eq beqa); exact (incl_refl _).
Qed.
Arguments incl_refl a : clear implicits.
Arguments incl_trans {a b c} ainclb binclc.
Arguments incl_antisym {a b} ainclb bincla.
Arguments Eeq_incl_l {a b} aeqb.
Arguments Eeq_incl_r {a b} aeqb.

Lemma notincl_not_incl : forall a b : _, (a not_incl b) -> ~ (a incl b).
Proof. by intros a b [e [eina enib]] ainclb; exact (enib (ainclb _ eina)). Qed.
Lemma not_incl_notincl : forall a b : _, ~ (a incl b) -> (a not_incl b).
Proof.
	intros a b nainclb.
	specialize (not_all_ex_not _ _ nainclb) as [e He].
	by exists e; exact (imply_to_and _ _ He).
Qed.
Arguments notincl_not_incl {a b} anib.
Arguments not_incl_notincl {a b} anib.

Lemma ex_empty_set : exists E : Ensemble, forall x, ~ (x inE E).
Proof.
	specialize empty_set_axiom as [e _].
	specialize (schema_restricted_comprehension_axiom (fun x => x <> x) e) as [V HV].
	exists V; intros x xiV.
	by exact (proj2 (proj1 (iff_and (HV x)) xiV) (eq_refl x)).
Qed.
Definition EmptySet := ens False (fun f => match f return Ensemble with end).
Lemma empty_is_empty : forall x, x not_in EmptySet.
Proof. by intros _ [[] _]. Qed.
Lemma empty_is_empty' : ~ (exists x, x inE EmptySet).
Proof. by intros [_ [[] _]]. Qed.
Lemma empties_are_empty : forall a : Ensemble, (~ (exists x, x inE a)) -> (a = EmptySet).
Proof.
	intros a ae.
	apply Eeq_is_eq, incl_antisym.
	intros x xina.
	by is_false (ae (ex_intro _ x xina)).
	intros ? [[] _]. (* is_false *)
	(* intros [a f] ae.
	apply Eeq_is_eq; split.
	2: by intros y; is_false y.
	intros x.
	elim ae. (* exfalso; apply ae *)
	exists (f x), x.
	by exact (Eeq_refl _). *)
Qed.
Corollary non_empty_is_not_empty : forall A : Ensemble,
  (A <> EmptySet) -> exists x : _, x inE A.
Proof.
	intros a anee.
	apply NNPP; intros nexxina.
	by exact (anee (empties_are_empty a nexxina)).
	(* intros [A f] Ane.
	specialize (classic (exists x, x inE ens A f)) as [exx | nex].
	by exact exx.
	specialize (not_ex_all_not _ _ nex) as nex'; clear nex; rename nex' into nex; lazy beta in nex.
	elim Ane.
	apply Eeq_is_eq.
	split.
	intros x.
	by elim (nex (f x) (ex_intro _ x (Eeq_refl _))).
	by intros y; elim y. *)
Qed.

Corollary ex_union_set : forall A B : Ensemble, exists C : Ensemble,
	forall x, (x inE C) <-> ((x inE A) \/ (x inE B)).
Proof.
	intros a b.
	specialize (pairing_axiom a b) as [c' Hc'].
	specialize (union_axiom c') as [c Hc].
	exists c; intros x; specialize (Hc x) as [xincisexy exyisxinc]; split.
	intros xinc; specialize (xincisexy xinc) as [y [yinc' xiny]].
	by specialize (proj1 (iff_and (Hc' y)) yinc') as [xeq | xeq];
	  rewrite xeq in xiny; [left | right]; exact xiny.
	intros [xin | xin]; apply exyisxinc; [exists a | exists b]; split.
	1: by exact (proj2 (iff_and (Hc' a)) (or_introl (eq_refl _))).
	2: by exact (proj2 (iff_and (Hc' b)) (or_intror (eq_refl _))).
	1,2: by exact xin.
	(* intros A B.
	specialize (pairing_axiom A B) as [C' HC'].
	specialize (union_axiom C') as [C HC].
	exists C; intros x; specialize (HC x); split.
	intros xinC; specialize HC as [HC _]; specialize (HC xinC) as [Y [HY Hx]].
	specialize (HC' Y) as [HC' _]; specialize (HC' HY) as [YA | YB].
	by left;  rewrite <-YA; exact Hx.
	by right; rewrite <-YB; exact Hx.
	by intros [Hx | Hx];
		specialize HC as [_ HC]; apply HC; clear HC C;
		[specialize (HC' A) as [_ HC'];
		specialize (HC' (or_introl (eq_refl A))); exists A
		|specialize (HC' B) as [_ HC'];
		specialize (HC' (or_intror (eq_refl B))); exists B]; exact (conj HC' Hx). *)
Qed.
Inductive bool' := | leftopt : bool' | rightopt : bool'.
Definition pairing_cons (A B : Ensemble)
	:= ens bool' (fun b => match b with | leftopt => A | rightopt => B end).
Definition singleton (x : Ensemble) := pairing_cons x x.
(* Inductive ExistsSigma (P : Type) (Q : P -> Prop) : Type
	:= ex_sigma : forall x : P, Q x -> ExistsSigma P Q. === exist *)
(* Definition separation_cons (A : Ensemble) (P : Ensemble -> Prop) : Ensemble.
	destruct A as [A f].
	apply (ens (ExistsSigma _ (fun x => P (f x)))).
	intros [x _]. exact (f x).
Defined. *)
Definition separation_cons (A : Ensemble) (P : Ensemble -> Prop) : Ensemble :=
	let (A', f) := A in
	 ens { x : A' | P (f x) }
	  (fun p : { x : A' | P (f x) } => match p with exist _ x _ => f x end).

Lemma separation_cons_included : forall (A : Ensemble) (P : Ensemble -> Prop),
	(separation_cons A P) incl A.
Proof.
	intros [A f] P x [[y _] xinabyy].
	by exists y; exact xinabyy.
Qed.
Lemma separation_cons_separated : forall (A : Ensemble) (P : Ensemble -> Prop) x,
	(x inE separation_cons A P) -> P x.
Proof.
	intros [A f] P x [[y Pfy] xinsepbyy].
	by rewrite (Eeq_is_eq xinsepbyy); exact Pfy.
Qed.
Lemma separation_cons_separates : forall (A : Ensemble) (P : Ensemble -> Prop) x,
	(x inE A) -> P x -> (x inE separation_cons A P).
Proof.
	intros [A f] P x [y xinAbyy] Px.
	rewrite (Eeq_is_eq xinAbyy) in Px.
	by exists (exist _ y Px); exact xinAbyy.
Qed.

(* Inductive TypePower (P : Type) (Q : P -> Type) : Type
	:= type_pow : forall x : P, forall y : Q x, TypePower P Q. === sigT *)
(* Definition ens_union_cons (A : Ensemble) : Ensemble.
	destruct A as [A f].
	apply (ens (TypePower _ (fun x : A => pi1e (f x)))).
	intros [a imgA].
	exact (pi2e (f a) imgA).
Defined. *)
(* For all Ensemble A,
 * ens_union_cons constructs a type that is then mapped to all elements
 *  of the elements of A.
 * existT x y: x is of the type of A, and maps to B by A;
 *   then y is of the type A, and maps to the final set by B.
 *)
Definition ens_union_cons (A : Ensemble) : Ensemble := let (A', f) := A in
	ens { x : A' & pi1e (f x) }
		(fun X => match X with existT _ x y => pi2e (f x) y end).
Definition pair_union_cons (A B : Ensemble) : Ensemble
	:= ens_union_cons (pairing_cons A B).

Infix "\union" := pair_union_cons (at level 150, left associativity).
Notation "'\Union' a" := (ens_union_cons a) (at level 150, no associativity).
Notation "a \\ b" := (separation_cons a (fun x => x not_in b)) (at level 150, no associativity).
Definition inter a b := separation_cons a (fun x => x inE b).
Infix "\inter" := inter (at level 150, left associativity).

Lemma ens_union_is_union : forall A : Ensemble, forall B : Ensemble,
	B inE (ens_union_cons A) -> exists C : Ensemble, C inE A /\ B inE C.
Proof.
	intros [A f] [B g] [[x y] BinCbyy].
	remember (f x) as fx eqn:eqnfx; destruct fx as [C h].
	exists (ens C h); split.
	by exists x; exact (eq_is_Eeq eqnfx).
	by exists y; exact BinCbyy.
Qed.
Lemma union_is_ens_union : forall A : Ensemble, forall B : Ensemble,
	(B inE A) -> B incl (ens_union_cons A).
Proof.
	intros [A f] [B g] [x BinAbyx] [C h] [y CinBbyy].
	rewrite (ens_pi_is_orig (f x)) in BinAbyx.
	destruct BinAbyx as [Binclfx _].
	specialize (Binclfx y) as [y' gxinfxbyy'].
	specialize (Eeq_trans CinBbyy gxinfxbyy') as Cinfxbyy'; clear gxinfxbyy'.
	exists (existT _ x y').
	by exact Cinfxbyy'.
Qed.

Lemma l_in_pairing : forall A B : Ensemble, A inE (pairing_cons A B).
Proof.
	by intros A B; exists leftopt; exact (Eeq_refl _).
Qed.
Lemma r_in_pairing : forall A B : Ensemble, B inE (pairing_cons A B).
Proof.
	by intros A B; exists rightopt; exact (Eeq_refl _).
Qed.
Lemma pairing_is_lr : forall A B C : Ensemble, C inE (pairing_cons A B) -> C = A \/ C = B.
Proof.
	intros A B C [[|] eeq].
	by left;  exact (Eeq_is_eq eeq).
	by right; exact (Eeq_is_eq eeq).
Qed.
Lemma pair_union_is_union_l : forall A B : Ensemble, A incl (pair_union_cons A B).
Proof.
	intros A B e einA.
	by exact (union_is_ens_union (pairing_cons A B) A (l_in_pairing _ _) _ einA).
Qed.
Lemma pair_union_is_union_r : forall A B : Ensemble, B incl (pair_union_cons A B).
Proof.
	intros A B e einB.
	by exact (union_is_ens_union (pairing_cons A B) B (r_in_pairing _ _) _ einB).
Qed.
Lemma pair_union_is_union : forall A B C : Ensemble,
	C inE (pair_union_cons A B) -> C inE A \/ C inE B.
Proof.
	intros [A f] [B g] [C h] [[[|] xval] CinAuBbyx].
	by left;  exists xval; exact CinAuBbyx.
	by right; exists xval; exact CinAuBbyx.
Qed.

Lemma singleton_has_elem : forall A : Ensemble, A inE (singleton A).
Proof.
	by intros [A f]; exists leftopt; exact (Eeq_refl _).
Qed.
Lemma singleton_is_singleton : forall A B : Ensemble, B inE (singleton A) -> B = A.
Proof.
	by intros A B BinsA;
	 specialize (pairing_is_lr _ _ _ BinsA) as [H | H];
	 exact H.
Qed.
Lemma singleton_incl_is_in : forall A B : Ensemble, (singleton A) incl B -> A inE B.
Proof.
	intros [A f] [B g] sAinclB.
	by exact (sAinclB _ (singleton_has_elem (ens A f))).
Qed.

Lemma exists_inter_set
 : forall A, (A <> EmptySet) ->
  exists C, forall x, (x inE C) <-> (forall a, (a inE A) -> (x inE a)).
Proof.
	intros A Ane.
	specialize (non_empty_is_not_empty _ Ane) as [a0 a0inA]; clear Ane.
	specialize (schema_restricted_comprehension_axiom
	 (fun e => (forall a, (a inE A) -> (e inE a))) a0) as [C HC].
	exists C; intros x; specialize (HC x) as [HCl HCr]; split; [clear HCr | clear HCl].
	by intros xiC; exact (proj2 (HCl xiC)).
	by intros H0; exact (HCr (conj (H0 _ a0inA) H0)).
Qed.

Definition Succ (A : Ensemble) := pair_union_cons A (singleton A).
Definition is_nat (A : Ensemble) :=
	(EmptySet inE A) /\ forall x, (x inE A) -> ((Succ x) inE A).
Axiom infinity_axiom : exists N : Ensemble,
	(is_nat N) /\ (forall a, (is_nat a) -> N incl a).

Lemma e_in_succ : forall e : Ensemble, e inE Succ e.
Proof.
	intros e.
	by apply (pair_union_is_union_r _), singleton_has_elem.
Qed.
Lemma e_incl_succ : forall e : Ensemble, e incl Succ e.
Proof.
	intros e.
	by unfold Succ; exact (pair_union_is_union_l _ _).
Qed.

Inductive nat :=
	| O : nat
	| S : nat -> nat.
Fixpoint N (n : nat) : Ensemble := match n with O => EmptySet | S n => Succ (N n) end.
Definition Nnat : Ensemble := ens nat N.

Lemma induction_N (P : Ensemble -> Prop) :
 P (N O) -> (forall e : Ensemble, P e -> P (Succ e)) -> forall n : nat, P (N n).
Proof.
	intros I IH.
	specialize (schema_restricted_comprehension_axiom P Nnat) as [[C h] Cprop].
	assert (C_is_nat : is_nat (ens C h)).
	{ split.
	  apply (proj2 (iff_and (Cprop EmptySet))); split.
	  by exists O; exact (Eeq_refl _).
	  by exact I.
	  intros x xinC.
	  specialize (proj1 (iff_and (Cprop x)) xinC) as [[n xinNnatbyn] Px].
	  apply (proj2 (iff_and (Cprop (Succ x)))); split.
	  apply Eeq_is_eq in xinNnatbyn; rewrite xinNnatbyn.
	  by exists (S n); exact (Eeq_refl _).
	  by exact (IH x Px). }
	intros n.
	destruct C_is_nat as [einC IHC].
	induction n as [|n IHn]. (* Seems weird to do this, but oh well... (N is defined weirdly) *)
	by exact (proj2 (proj1 (iff_and (Cprop (N O))) einC)).
	(* I hate intermediary steps :p (basically, use Cprop the two ways, then IHC) *)
	by exact (proj2 (proj1 (iff_and (Cprop _)) (IHC _
		(proj2 (iff_and (Cprop (N n))) (conj (ex_intro _ n (Eeq_refl _)) IHn))))).
Qed.
Lemma double_induction : forall P : nat -> Prop, P O -> P (S O) ->
  (forall n : nat, P n -> P (S n) -> P (S (S n))) -> forall n, P n.
Proof.
	intros P I0 I1 IH.
	assert (H : forall n : nat, P n /\ P (S n)).
	{ intros n; induction n as [|n [IHn IHSn]]; split.
	  by exact I0. by exact I1.
	  by exact IHSn.
	  by exact (IH _ IHn IHSn). }
	by intros n; exact (proj1 (H _)).
Qed.

Lemma N_in_nat : forall a : _, is_nat a -> Nnat incl a.
Proof.
	intros a [eina succaincla] Nn [n NninNbyn].
	rewrite (Eeq_is_eq NninNbyn).
	by exact (induction_N (fun k => k inE a) eina succaincla n).
	(* forall n : nat, forall a : Ensemble, is_nat a -> N n inE a.
	intros n [A f] anat; induction n as [|n [m Hm]].
	destruct anat as [[x einabyx] _].
	by exists x; exact einabyx.
	destruct anat as [_ anat].
	specialize (anat (N n)).
	apply anat; clear anat.
	exists m. by exact Hm. *)
Qed.
Lemma N_is_nat : is_nat Nnat.
Proof.
	split.
	by exists O; exact (Eeq_refl _).
	intros x [n xinNbyn].
	rewrite (Eeq_is_eq xinNbyn).
	by exists (S n); exact (Eeq_refl _).
Qed.
Lemma nat_in_N : forall a : Ensemble, is_nat a -> (forall b : Ensemble, is_nat b -> a incl b) -> forall n : Ensemble, n inE a -> exists k : nat, n = N k.
Proof.
	intros a [eina succaincla] ainclallnat n nina.
	specialize (ainclallnat Nnat N_is_nat) as ainclN.
	specialize (ainclN _ nina) as [b ninNbyb].
	by exists b; exact (Eeq_is_eq ninNbyb).
Qed.

Inductive LessThan_iterc : nat -> nat -> Type :=
	| ltic_o : forall n : nat, LessThan_iterc O (S n)
	| ltic_iter : forall m n : nat, LessThan_iterc m n -> LessThan_iterc (S m) (S n).
Inductive GreaterEqual_iterc : nat -> nat -> Type :=
	| geic_o : forall m : nat, GreaterEqual_iterc m O
	| geic_iter : forall m n : nat, GreaterEqual_iterc m n
		-> GreaterEqual_iterc (S m) (S n).
Fixpoint Min (m : nat) (n : nat) : nat := match m, n with
	| O, _ | _, O => O
	| S m', S n' => S (Min m' n') end.
Arguments ltic_iter {m n} p.
Arguments geic_iter {m n} p.
Definition LessThan_iter m n := exists p : LessThan_iterc m n, p = p.
Definition GreaterEqual_iter m n := exists p : GreaterEqual_iterc m n, p = p.
Definition ltc2lt_iter m n p := ex_intro (fun p: LessThan_iterc m n => p = p) p (eq_refl p).
Definition gec2ge_iter m n p := ex_intro (fun p: GreaterEqual_iterc m n => p = p) p (eq_refl p).
Arguments ltc2lt_iter {m n} p.
Arguments gec2ge_iter {m n} p.
Definition lti_o n := ltc2lt_iter (ltic_o n).
Definition gei_o n := gec2ge_iter (geic_o n).
Definition lti_iter {m n} (p : LessThan_iter _ _)
	:= let (p', _) := p in ltc2lt_iter (ltic_iter (m:=m) (n:=n) p').
Definition gei_iter {m n} (p : GreaterEqual_iter _ _)
	:= let (p', _) := p in gec2ge_iter (geic_iter (m:=m) (n:=n) p').
Lemma minC : forall m n : nat, Min m n = Min n m.
Proof.
	intros m; induction m as [|m IHm]; intros [|n].
	1,2,3: by exact (eq_refl _).
	by minimize Min; rewrite (IHm _); exact (eq_refl _).
Qed.
Lemma lt_or_ge_iter : forall m n : nat, LessThan_iter m n \/ GreaterEqual_iter m n.
Proof.
	intros m n; generalize dependent m; induction n as [|n IHn];
	 [intros ? | intros [|m]].
	by right; exact (gei_o _).
	by left;  exact (lti_o _).
	specialize (IHn m) as [lt | ge].
	by left;  exact (lti_iter lt).
	by right; exact (gei_iter ge).
Qed.
Lemma lt_iterc_rev : forall m n, LessThan_iterc (S m) (S n) -> LessThan_iterc m n.
Proof.
	intros m n mltn.
	inversion mltn as [|m' n' H m'eqm n'eqn]; clear m' n' m'eqm n'eqn.
	by exact H.
Qed.
Lemma ge_iterc_rev : forall m n, GreaterEqual_iterc (S m) (S n) -> GreaterEqual_iterc m n.
Proof.
	intros m n mgen.
	inversion mgen as [|m' n' H m'eqm n'eqn]; clear m' n' m'eqm n'eqn.
	by exact H.
Qed.
Arguments lt_iterc_rev {m n} p.
Arguments ge_iterc_rev {m n} p.
Lemma lt_iter_rev : forall m n, LessThan_iter (S m) (S n) -> LessThan_iter m n.
Proof.
	intros m n [mltn _].
	by exact (ltc2lt_iter (lt_iterc_rev mltn)).
Qed.
Lemma ge_iter_rev : forall m n, GreaterEqual_iter (S m) (S n) -> GreaterEqual_iter m n.
Proof.
	intros m n [mgen _].
	by exact (gec2ge_iter (ge_iterc_rev mgen)).
Qed.
Arguments lt_iter_rev {m n} p.
Arguments ge_iter_rev {m n} p.
Lemma lt_is_not_ge_iter : forall m n, LessThan_iter m n -> ~ GreaterEqual_iter m n.
Proof.
	intros m; induction m as [|m IHm]; intros [|n] mltn mgen.
	1,3: by destruct mltn as [mltn _]; inversion mltn.
	     by destruct mgen as [mgen _]; inversion mgen.
	by exact (IHm _ (lt_iter_rev mltn) (ge_iter_rev mgen)).
Qed.
Lemma ge_is_not_lt_iter : forall m n, GreaterEqual_iter m n -> ~ LessThan_iter m n.
Proof.
	intros m; induction m as [|m IHm]; intros [|n] mgen mltn.
	1,3: by destruct mltn as [mltn _]; inversion mltn.
	     by destruct mgen as [mgen _]; inversion mgen.
	by exact (IHm _ (ge_iter_rev mgen) (lt_iter_rev mltn)).
Qed.

Lemma lt_is_min_iter : forall m n : nat, LessThan_iter m n -> Min m n = m.
Proof.
	intros m; induction m as [|m IHm].
	by intros; exact (eq_refl _).
	intros [|n] mltn.
	by is_false (ge_is_not_lt_iter _ _ (gei_o _) mltn).
	by exact (f_equal _ (IHm _ (lt_iter_rev mltn))).
Qed.
Lemma le_is_min_iter : forall m n : nat, LessThan_iter m (S n) -> Min m n = m.
Proof.
	intros m; induction m as [|m IHm].
	by intros; exact (eq_refl _).
	intros [|n] mltn; apply lt_iter_rev in mltn.
	by is_false (ge_is_not_lt_iter _ _ (gei_o _) mltn).
	by exact (f_equal _ (IHm _ mltn)).
Qed.

Lemma lt_iterc_next {m n : nat} : LessThan_iterc m n -> LessThan_iterc m (S n).
Proof.
	intros lti.
	induction lti as [n|m n mltn IHmltn].
	by exact (ltic_o _).
	by exact (ltic_iter IHmltn).
Qed.
Lemma ge_iterc_next {m n : nat} : GreaterEqual_iterc m n -> GreaterEqual_iterc (S m) n.
Proof.
	intros gei.
	induction gei as [n|m n mgen IHmgen].
	by exact (geic_o _).
	by exact (geic_iter IHmgen).
Qed.
Lemma lt_iter_next {m n : nat} : LessThan_iter m n -> LessThan_iter m (S n).
Proof.
	intros [mltn _].
	by exact (ltc2lt_iter (lt_iterc_next mltn)).
Qed.
Lemma ge_iter_next {m n : nat} : GreaterEqual_iter m n -> GreaterEqual_iter (S m) n.
Proof.
	intros [mgen _].
	by exact (gec2ge_iter (ge_iterc_next mgen)).
Qed.

Lemma lt_is_tg_iter : forall m n : nat, LessThan_iter m n -> GreaterEqual_iter n (S m).
Proof.
	intros m; induction m as [|m IHm]; intros [|n] mltn.
	1,3: by is_false (lt_is_not_ge_iter _ _ mltn (gei_o _)).
	by exact (gei_iter (gei_o _)).
	by exact (gei_iter (IHm _ (lt_iter_rev mltn))).
Qed.
Lemma ge_is_el_iter : forall m n : nat, GreaterEqual_iter m n -> LessThan_iter n (S m).
Proof.
	intros m; induction m as [|m IHm]; intros [|n] mgen.
	1,3: by exact (lti_o _).
	by is_false (ge_is_not_lt_iter _ _ mgen (lti_o _)).
	by exact (lti_iter (IHm _ (ge_iter_rev mgen))).
Qed.

Lemma n_lt_Sn : forall n : nat, LessThan_iter n (S n).
Proof.
	intros n; induction n as [|n IHn].
	by exact (lti_o _).
	by exact (lti_iter IHn).
Qed.
Lemma n_ge_n : forall n : nat, GreaterEqual_iter n n.
Proof.
	intros n; induction n as [|n IHn].
	by exact (gei_o _).
	by exact (gei_iter IHn).
Qed.

Lemma m_lt_Sn_ne_n : forall m n : nat, LessThan_iter m (S n) -> m <> n -> LessThan_iter m n.
Proof.
	intros m; induction m as [|m IHm]; intros [|n] mltSn mnen.
	by is_false (mnen (eq_refl _)).
	by exact (lti_o _).
	by is_false (ge_is_not_lt_iter _ _ (gei_iter (gei_o _)) mltSn).
	assert (mnen' : m <> n) by (intros meqn; exact (mnen (f_equal _ meqn))).
	by exact (lti_iter (IHm _ (lt_iter_rev mltSn) mnen')).
Qed.

Fixpoint add m n := match m with
	| O => n
	| S m' => S (add m' n) end.
Lemma add_m_Sn : forall m n : nat, add m (S n) = S (add m n).
Proof.
	intros m; induction m as [|m IHm]; intros n.
	by exact (eq_refl _).
	by minimize add; rewrite IHm; exact (eq_refl _).
Qed.
Lemma add_Sm_n : forall m n : nat, add (S m) n = S (add m n).
Proof.
	by intros; exact (eq_refl _).
Qed.
Lemma addC : forall m n : nat, add m n = add n m.
Proof.
	intros m; induction m as [|m IHm]; intros n.
	induction n as [|n IHn].
	by exact (eq_refl _).
	by rewrite (add_m_Sn _ _), IHn; exact (eq_refl _).
	by rewrite (add_m_Sn _ _), <-(IHm _); exact (eq_refl _).
Qed.
Lemma addA : forall m n p : nat, add (add m n) p = add m (add n p).
Proof.
	intros m; induction m as [|m IHm]; intros n p.
	by exact (eq_refl _).
	by minimize add; rewrite IHm; exact (eq_refl _).
Qed.

Lemma n_in_Sn : forall n : nat, (N n) inE (N (S n)).
Proof.
	intros n.
	by exact (e_in_succ _).
Qed.
Lemma natural_longest_string_n : forall n : nat,
	(forall g : nat -> Ensemble,
	 (forall m : nat, LessThan_iter m n -> (g m) inE (g (S m))) ->
	 (g n = N n) ->
	 (forall m : nat, LessThan_iter m (S n) -> g m = N m)) /\
	(forall f : nat -> Ensemble, (exists m : nat,
		(LessThan_iter m (S n) /\ (f m) not_in (f (S m)))) \/
		((f (S n)) not_in (N (S n)))).
Proof.
	intros n; induction n as [|n [IHnL IHnR]]; split.
	- intros g Hg gOeqO [|m] mltSO.
	  by exact gOeqO.
	  by is_false (ge_is_not_lt_iter _ _ (gei_o _) (lt_iter_rev mltSO)).
	- intros f.
	  specialize (classic (f (S O) = N O)) as [fSOeq | fSOne].
	  left; exists O; split.
	  by exact (lti_o _).
	  rewrite fSOeq; unfold N.
	  by exact (empty_is_empty _).
	  right; intros fSOinSO.
	  specialize (pair_union_is_union _ _ _ fSOinSO) as [fSOinO | fSOinsO].
	  by exact (empty_is_empty _ fSOinO).
	  specialize (singleton_is_singleton _ _ fSOinsO) as fSOinO.
	  by exact (fSOne fSOinO).
	- intros g Hg gSneqSn.
	  remember Hg as Hg' eqn:tmp; specialize (Hg' _ (n_lt_Sn n)) as gninSn; clear tmp Hg'.
	  rewrite gSneqSn in gninSn.
	  specialize (pair_union_is_union _ _ _ gninSn) as [gninn | gninsn].
	  + exfalso.
	    pose (h' := fix h' i j k n := match i with
	      | O => match j with | O => N n | _ => g k end
	      | S i' => match j with
	        | O => match i' with | O => g (S k) | _ => h' i' O (S k) n end
	        | S j' => h' i' j' (S k) n end
	    end).
	    assert (h'SmOisgSm : forall m n p, h' (S m) O n p = g (add (S m) n)).
	    { clear dependent n; intros m; induction m as [|m IHm]; intros n p.
	      by exact (eq_refl _).
	      minimize h' in IHm; minimize add in IHm.
	      minimize add; rewrite <-(add_m_Sn m n).
	      rewrite <-(IHm (S n) p).
	      by exact (eq_refl _). }
	    assert (neisg'eqg : forall m p q r, m <> p -> h' m p q r = g (add q m)).
	    { clear dependent n; intros m p.
	      generalize dependent m; induction p as [|p IHp]; intros m q r mneSp.
	      destruct m as [|m].
	      by is_false (mneSp (eq_refl _)).
	      by rewrite addC; exact (h'SmOisgSm m q r).
	      destruct m as [|m].
	      by rewrite addC; exact (eq_refl _).
	      assert (mnep : m <> p) by (intros meqp; exact (mneSp (f_equal S meqp))).
	      rewrite (add_m_Sn _ _), <-(add_Sm_n _ _).
	      by exact (IHp _ (S q) r mnep). }
	    assert (g'SneqNSn : forall n p q, h' n n p q = N q).
	    { clear; intros n; induction n as [|n IHn]; intros p q.
	      by exact (eq_refl _).
	      by exact (IHn _ _). }
	    specialize (let g' := fun m => h' m (S n) O n in IHnR g') as [[m [mltSn fmnifSm]] | fSnniSn].
	    * specialize (classic (m = n)) as [meqn | mnen].
	      -- rewrite meqn in fmnifSm; clear dependent m.
	         rewrite (g'SneqNSn _ _ _) in fmnifSm.
	         assert (nneSn : n <> S n).
	         { clear; intros neqSn; induction n as [|n IHn].
	           by discriminate neqSn.
	           by injection neqSn as neqSn'; exact (IHn neqSn'). }
	         rewrite (neisg'eqg _ _ _ _ nneSn) in fmnifSm.
	         by exact (fmnifSm gninn).
	      -- assert (mneSn : m <> S n) by (
	           intros meqSn; rewrite meqSn in mltSn;
	           exact (ge_is_not_lt_iter _ _ (n_ge_n _) mltSn)).
	         assert (SmneSn : S m <> S n) by (
	           intros SmeqSn; injection SmeqSn as meqn; exact (mnen meqn)).
	         rewrite (neisg'eqg _ _ _ _ SmneSn) in fmnifSm.
	         rewrite (neisg'eqg _ _ _ _ mneSn) in fmnifSm.
	         by exact (fmnifSm (Hg _ mltSn)).
	    * rewrite (g'SneqNSn _ _ _) in fSnniSn.
	      by exact (fSnniSn (n_in_Sn _)).

	  + specialize (singleton_is_singleton _ _ gninsn) as gneqn; clear gninsn.
	    intros m mltSSn.
	    specialize (classic (m = S n)) as [meqSn | mneSn].
	    by rewrite meqSn; exact gSneqSn.
	    specialize (m_lt_Sn_ne_n _ _ mltSSn mneSn) as mltSn; clear mltSSn mneSn.
	    refine (IHnL _ _ gneqn _ mltSn).
	    clear m mltSn; intros m mltn.
	    by exact (Hg _ (lt_iter_next mltn)).
	- intros f.
	  specialize (classic (f (S (S n)) inE N (S (S n)))) as [fSSninSSn | fSSnniSSn]; swap 1 2.
	  by right; exact fSSnniSSn.
	  left.
	  specialize (classic (exists m : nat, LessThan_iter m (S n) /\ f m not_in f (S m))) as [[m [mltSn fmnifSm]] | nex].
	  + exists m; split.
	    by exact (lt_iter_next mltSn).
	    by exact fmnifSm.
	  + exists (S n); split.
	    by exact (n_lt_Sn _).
	    remember IHnR as IHnR' eqn:tmp; clear tmp; specialize (IHnR' f) as [mex | fSnniSn].
	    by is_false (nex mex).
	    specialize (not_ex_all_not _ _ nex) as hypf; lazy beta in hypf; clear nex.
	    specialize (IHnR (fun m => f (S m))) as [[m [mltSn fSmnifSSm]] | fSSnniSn].
	    specialize (classic (m = n)) as [meqn | mnen].
	    by rewrite <-meqn; exact fSmnifSSm.
	    specialize (lti_iter (m_lt_Sn_ne_n _ _ mltSn mnen)) as SmltSn.
	    specialize (not_and_or _ _ (hypf (S m))) as [l | r].
	    by is_false (l SmltSn).
	    by is_false (r fSmnifSSm).
	    specialize (pair_union_is_union _ _ _ fSSninSSn) as [fSSninSn | fSSninsSn].
	    by is_false (fSSnniSn fSSninSn).
	    specialize (singleton_is_singleton _ _ fSSninsSn) as fSSneqSn.
	    by rewrite fSSneqSn; exact fSnniSn.
Qed.

Fixpoint parity {A : Type} (n : nat) (even odd : A) := match n with
	| O => even | S O => odd
	| S (S n') => parity n' even odd end.
(* Or:
Fixpoint parity {A : Type} (n : nat) (even odd : A) := match n with
	| O => even
	| S n' => parity n' odd even end.
*)
Lemma parity_even_or_odd {A : Type} : forall n : nat, forall even odd : A,
  (parity n even odd = even) \/ (parity n even odd = odd).
Proof.
	intros n even odd; generalize dependent n.
	apply double_induction.
	left. 2: right.
	1,2: by exact (eq_refl _).
	intros n IHn _.
	by exact IHn.
Qed.
Lemma parity_even_then_odd {A : Type} : forall n : nat, forall even odd : A,
  (parity n even odd = even) -> (parity (S n) even odd = odd).
Proof.
	intros n even odd; generalize dependent n.
	apply (double_induction (fun n => (parity n even odd = even) -> (parity (S n) even odd = odd))).
	by intros _; exact (eq_refl _).
	intros oddeqeven; unfold parity in oddeqeven; rewrite oddeqeven.
	by exact (eq_refl _).
	by intros ? IHn _; exact IHn.
Qed.
Lemma parity_odd_then_even {A : Type} : forall n : nat, forall even odd : A,
  (parity n even odd = odd) -> (parity (S n) even odd = even).
Proof.
	intros n even odd; generalize dependent n.
	apply (double_induction (fun n => (parity n even odd = odd) -> (parity (S n) even odd = even))).
	intros eveneqodd; unfold parity in eveneqodd; rewrite eveneqodd.
	by exact (eq_refl _).
	by intros _; exact (eq_refl _).
	by intros ? IHn _; exact IHn.
Qed.
Lemma parity_even_then_odd2 {A B : Type} : forall n : nat, forall even odd : A,
  even <> odd -> forall even2 odd2 : B,
   (parity n even odd = even) -> (parity (S n) even2 odd2 = odd2).
Proof.
	intros n even odd evenneodd even2 odd2; generalize dependent n.
	apply (double_induction (fun n => (parity n even odd = even) -> (parity (S n) even2 odd2 = odd2))).
	by intros _; exact (eq_refl _).
	intros oddeqeven; unfold parity in oddeqeven; symmetry in oddeqeven.
	by is_false (evenneodd oddeqeven).
	by intros ? IHn _; exact IHn.
Qed.
Lemma parity_odd_then_even2 {A B : Type} : forall n : nat, forall even odd : A,
  even <> odd -> forall even2 odd2 : B,
   (parity n even odd = odd) -> (parity (S n) even2 odd2 = even2).
Proof.
	intros n even odd evenneodd even2 odd2; generalize dependent n.
	apply (double_induction (fun n => (parity n even odd = odd) -> (parity (S n) even2 odd2 = even2))).
	intros eveneqodd; unfold parity in eveneqodd.
	by is_false (evenneodd eveneqodd).
	by intros _; exact (eq_refl _).
	by intros ? IHn _; exact IHn.
Qed.

Lemma succ_inj : forall m n : nat, Succ (N m) = Succ (N n) -> N m = N n.
Proof.
	intros m n SmeqSn.
	specialize (n_in_Sn m) as minSn; minimize N in minSn; rewrite SmeqSn in minSn.
	specialize (pair_union_is_union _ _ _ minSn) as [minn | minsn].
	specialize (n_in_Sn n) as ninSm; minimize N in ninSm; rewrite <-SmeqSn in ninSm.
	specialize (pair_union_is_union _ _ _ ninSm) as [ninm | ninsm].
	exfalso; clear ninSm minSn SmeqSn.
	pose (f := fun k => match parity m leftopt rightopt with
	  | leftopt  => parity k (N m) (N n)
	  | rightopt => parity k (N n) (N m) end).
	assert (lner : leftopt <> rightopt) by discriminate.
	specialize (parity_even_or_odd m leftopt rightopt) as [meven | modd];
	specialize (proj2 (natural_longest_string_n m) f) as [[k [kltSm fknifSk]] | fmniSm].
	unfold f in fknifSk; rewrite meven in fknifSk; clear f.
	specialize (parity_even_or_odd k (N m) (N n)) as [pkeqm | pkeqn].
	rewrite pkeqm in fknifSk.
	rewrite (parity_even_then_odd _ _ _ pkeqm) in fknifSk.
	by exact (fknifSk minn).
	rewrite pkeqn in fknifSk.
	rewrite (parity_odd_then_even _ _ _ pkeqn) in fknifSk.
	by exact (fknifSk ninm).
	unfold f in fmniSm; rewrite meven in fmniSm; clear f.
	rewrite (parity_even_then_odd2 _ _ _ lner (N m) (N n) meven) in fmniSm.
	by exact (fmniSm (e_incl_succ _ _ ninm)).

	unfold f in fknifSk; rewrite modd in fknifSk; clear f.
	specialize (parity_even_or_odd k (N n) (N m)) as [pkeqn | pkeqm].
	rewrite pkeqn in fknifSk.
	rewrite (parity_even_then_odd _ _ _ pkeqn) in fknifSk.
	by exact (fknifSk ninm).
	rewrite pkeqm in fknifSk.
	rewrite (parity_odd_then_even _ _ _ pkeqm) in fknifSk.
	by exact (fknifSk minn).
	unfold f in fmniSm; rewrite modd in fmniSm; clear f.
	rewrite (parity_odd_then_even2 _ _ _ lner (N n) (N m) modd) in fmniSm.
	by exact (fmniSm (e_incl_succ _ _ ninm)).

	by symmetry; apply singleton_is_singleton in ninsm; exact ninsm.
	by           apply singleton_is_singleton in minsn; exact minsn.
Qed.
Arguments succ_inj {m n} SNmeqSNn.

Lemma N_inj : forall m n : nat, N m = N n -> m = n.
Proof.
	intros m; induction m as [|m IHm].
	- intros [|n] NOeqNn.
	  + by exact (eq_refl _).
	  + exfalso.
	    specialize (n_in_Sn n) as ninSn.
	    rewrite <-NOeqNn in ninSn.
	    by exact (empty_is_empty _ ninSn).
	- intros [|n] NmeqNn.
	  + exfalso.
	    specialize (n_in_Sn m) as minSm.
	    rewrite NmeqNn in minSm.
	    by exact (empty_is_empty _ minSm).
	  + by exact (f_equal _ (IHm _ (succ_inj NmeqNn))).
Qed.
Arguments N_inj {m n} NmeqNn.

Lemma add_normal_l : forall n a b : nat, add n a = add n b -> a = b.
Proof.
	(* Allowed because Succ is injective (see Nadd_normal_l) *)
	intros n; induction n as [|n IHn]; intros a b npaeqnpb.
	by exact npaeqnpb.
	minimize add in npaeqnpb; injection npaeqnpb as npaeqnpb.
	by exact (IHn _ _ npaeqnpb).
Qed.
Lemma add_normal_r : forall n a b : nat, add a n = add b n -> a = b.
Proof.
	by intros n a b apneqbpn; rewrite (addC a _), (addC b _) in apneqbpn;
	  exact (add_normal_l _ _ _ apneqbpn).
Qed.
Lemma add_normal_lr : forall n a b : nat, add n a = add b n -> a = b.
Proof.
	by intros n a b apneqbpn; rewrite (addC b _) in apneqbpn;
	  exact (add_normal_l _ _ _ apneqbpn).
Qed.
Lemma add_normal_rl : forall n a b : nat, add a n = add n b -> a = b.
Proof.
	by intros n a b apneqbpn; rewrite (addC a _) in apneqbpn;
	  exact (add_normal_l _ _ _ apneqbpn).
Qed.
Lemma Nadd_normal_l : forall n a b : nat, N (add n a) = N (add n b) -> N a = N b.
Proof.
	intros n; induction n as [|n IHn]; intros a b npaeqnpb.
	by exact npaeqnpb.
	by exact (IHn _ _ (succ_inj npaeqnpb)).
Qed.
Lemma Nadd_normal_r : forall n a b : nat, N (add a n) = N (add b n) -> N a = N b.
Proof.
	by intros n a b apneqbpn; rewrite (addC a _), (addC b _) in apneqbpn;
	  exact (Nadd_normal_l _ _ _ apneqbpn).
Qed.
Lemma Nadd_normal_lr : forall n a b : nat, N (add n a) = N (add b n) -> N a = N b.
Proof.
	by intros n a b apneqbpn; rewrite (addC b _) in apneqbpn;
	  exact (Nadd_normal_l _ _ _ apneqbpn).
Qed.
Lemma Nadd_normal_rl : forall n a b : nat, N (add a n) = N (add n b) -> N a = N b.
Proof.
	by intros n a b apneqbpn; rewrite (addC a _) in apneqbpn;
	  exact (Nadd_normal_l _ _ _ apneqbpn).
Qed.
Arguments add_normal_l {n a b} equality.
Arguments add_normal_r {n a b} equality.
Arguments add_normal_lr {n a b} equality.
Arguments add_normal_rl {n a b} equality.
Arguments Nadd_normal_l {n a b} equality.
Arguments Nadd_normal_r {n a b} equality.
Arguments Nadd_normal_lr {n a b} equality.
Arguments Nadd_normal_rl {n a b} equality.

Definition LessEqual_exist (m n : nat) := exists p : nat, add p m = n.
Lemma lee_O_n : forall n : nat, LessEqual_exist O n.
Proof.
	by intros n; exists n; rewrite addC; exact (eq_refl _).
Qed.
Lemma le_ex_refl : forall n : nat, LessEqual_exist n n.
Proof.
	by intros ?; exists O; exact (eq_refl _).
Qed.
Lemma le_ex_trans : forall m n p : nat, LessEqual_exist m n -> LessEqual_exist n p -> LessEqual_exist m p.
Proof.
	intros m n p [mn mlen] [np nlep].
	exists (add np mn).
	by rewrite addA, mlen; exact nlep.
Qed.
Lemma le_ex_sym : forall m n : nat, LessEqual_exist m n -> LessEqual_exist n m -> m = n.
Proof.
	intros m n [mn mlen] [nm nlem].
	destruct mn as [|mn].
	by exact mlen.
	exfalso; rewrite <-mlen, <-addA, add_m_Sn in nlem; clear n mlen; symmetry in nlem.
	generalize dependent (add nm mn); clear mn nm; intros n npmeqm.
	induction m as [|m IHm].
	by discriminate npmeqm.
	by rewrite add_m_Sn in npmeqm; injection npmeqm as npmeqm; exact (IHm npmeqm).
	(* assert (mltSnpm : forall n : nat, LessThan_iter m (add (S n) m)).
	{ intros n; induction n as [|n IHn].
	  by exact (n_lt_Sn _).
	  by specialize (lt_iter_next IHn) as tmp; rewrite <-add_Sm_n in tmp; exact tmp. }
	assert (mgeSnpm : GreaterEqual_iter m (add (S n) m)) by
	 (rewrite <-npmeqm; exact (n_ge_n _)).
	by exact (ge_is_not_lt_iter _ _ mgeSnpm (mltSnpm _)). *)
Qed.

Lemma le_compat_plus : forall m n p : nat, LessEqual_exist (add m p) (add n p) -> LessEqual_exist m n.
Proof.
	intros m n p [mpnp mplenp].
	exists mpnp.
	rewrite <-addA in mplenp.
	by exact (add_normal_r mplenp).
Qed.

Lemma le_Sm_Sn_m_n : forall m n : nat, LessEqual_exist (S m) (S n) -> LessEqual_exist m n.
Proof.
	intros m n [mn mlen].
	exists mn.
	rewrite add_m_Sn in mlen; injection mlen as mlen.
	by exact mlen.
Qed.
Lemma lee_iter : forall m n : nat, LessEqual_exist m n -> LessEqual_exist (S m) (S n).
Proof.
	intros m n [mn mlen].
	exists mn.
	rewrite add_m_Sn.
	by exact (f_equal S mlen).
Qed.

Lemma lee_total : forall m n : nat, LessEqual_exist m n \/ LessEqual_exist n m.
Proof.
	intros m; induction m as [|m IHm].
	by intros n; left; exists n; rewrite addC; exact (eq_refl _).
	intros [|n].
	by right; exact (lee_O_n _).
	specialize (IHm n) as [mlen | nlem].
	by left;  exact (lee_iter _ _ mlen).
	by right; exact (lee_iter _ _ nlem).
Qed.

Example sum_less_individual_more : forall a b c d : nat,
 LessEqual_exist (add a b) (add c d) -> LessEqual_exist c a -> LessEqual_exist b d.
Proof.
	intros a b c d [abcd ablecd] [ca clea].
	exists (add abcd ca).
	rewrite <-clea in ablecd; clear clea.
	rewrite (addC ca _), (addA c _ _), (addC c _), <-(addA _ _ c) in ablecd.
	apply add_normal_rl in ablecd.
	rewrite <-addA in ablecd.
	by exact ablecd.
Qed.

Lemma lti_is_in : forall m n : nat, LessThan_iter m n -> N m inE N n.
Proof.
	intros m; induction m as [|m IHm].
	intros [|n] OltSn.
	by is_false (ge_is_not_lt_iter _ _ (gei_o _) OltSn).
	clear OltSn; induction n as [|n IHn].
	by exact (n_in_Sn _).
	by exact (e_incl_succ _ _ IHn).
	intros [|n] SmltSn.
	by is_false (ge_is_not_lt_iter _ _ (gei_o _) SmltSn).
	specialize (IHm _ (lt_iter_rev SmltSn)) as NminNn; clear IHm SmltSn.
	generalize dependent m; induction n as [|n IHn].
	by intros m NminNO; is_false (empty_is_empty _ NminNO).
	intros m NminNSn.
	specialize (pair_union_is_union _ _ _ NminNSn) as [NminNn | NminsNSn].
	by exact (e_incl_succ _ _ (IHn _ NminNn)).
	apply singleton_is_singleton in NminsNSn; fold N in NminsNSn.
	by rewrite (f_equal S (N_inj NminsNSn)); exact (n_in_Sn _).
Qed.
Lemma in_is_lti : forall m n : nat, N m inE N n -> LessThan_iter m n.
Proof.
	intros m n; generalize dependent m; induction n as [|n IHn].
	intros ? minO.
	by is_false (empty_is_empty _ minO).
	intros m minSn.
	specialize (pair_union_is_union _ _ _ minSn) as [minn | minsn].
	by exact (lt_iter_next (IHn _ minn)).
	by apply singleton_is_singleton, N_inj in minsn; rewrite minsn; exact (n_lt_Sn _).
Qed.
Arguments lti_is_in {m n} mltn.
Arguments in_is_lti {m n} minn.

Lemma lee_is_incl : forall m n : nat, LessEqual_exist m n -> (N m) incl (N n).
Proof.
	intros m n [mn mlen].
	rewrite <-mlen; clear n mlen; induction mn as [|mn IHmn].
	by unfold add; exact (incl_refl _).
	intros x xinm.
	specialize (IHmn _ xinm) as xinmnpm.
	by exact (e_incl_succ _ _ xinmnpm).
Qed.
Lemma incl_is_lee : forall m n : nat, (N m) incl (N n) -> LessEqual_exist m n.
Proof.
	intros m n mincln; generalize dependent m; induction n as [|n IHn]; intros m mincln.
	- specialize (classic (N m = N O)) as [meqO | mneO].
	  by rewrite (N_inj meqO); exact (le_ex_refl _).
	  specialize (non_empty_is_not_empty _ mneO) as [x xinm].
	  specialize (mincln _ xinm) as xine.
	  by is_false (empty_is_empty _ xine).
	- destruct m as [|m].
	  by exact (lee_O_n _).
	  refine (lee_iter _ _ (IHn m _)).
	  clear IHn; intros x xinm.
	  specialize (mincln _ (e_incl_succ _ _ xinm)) as xinSn.
	  specialize (pair_union_is_union _ _ _ xinSn) as [xinn | xinsn]; clear xinSn.
	  by exact xinn.
	  apply singleton_is_singleton in xinsn; fold N in xinsn.
	  exfalso; rewrite xinsn in xinm; clear x xinsn.
	  specialize (mincln _ (lti_is_in (lti_iter (in_is_lti xinm)))) as SninSn; clear xinm mincln.
	  specialize (proj2 (natural_longest_string_n n) (fun _ => N (S n)))
	    as [[_ [_ NSnniNSn]] | NSnniNSn]; by exact (NSnniNSn SninSn).
Qed.
Arguments lee_is_incl {m n} mlen.
Arguments incl_is_lee {m n} mincln.

Lemma le_is_in_eq : forall m n : nat, LessEqual_exist m n -> (N m inE N n) \/ (m = n).
Proof.
	intros m n [mn mlen]; generalize dependent mlen; generalize dependent n;
	  generalize dependent m; induction mn as [|mn IHmn].
	by intros ? ? mlen; right; exact mlen.
	intros m [|n] mlen.
	by minimize add in mlen; discriminate mlen.
	injection mlen as mlen; specialize (IHmn _ _ mlen) as [minn | meqn]; left.
	by exact (e_incl_succ _ _ minn).
	by rewrite meqn; exact (n_in_Sn _).
Qed.
Lemma lti_is_lee : forall m n : nat, LessThan_iter m n -> LessEqual_exist m n.
Proof.
	intros m n; generalize dependent m; induction n as [|n IHn]; intros [|m] mltSSn.
	1,3: by exact (lee_O_n _).
	by is_false (ge_is_not_lt_iter _ _ (gei_o _) mltSSn).
	by exact (lee_iter _ _ (IHn _ (lt_iter_rev mltSSn))).
Qed.

Example all_nonempty_N_is_minored : forall a : Ensemble,
  a incl Nnat -> a <> EmptySet -> exists n : nat, (N n inE a)
    /\ (forall y : Ensemble, y inE a -> N n incl y).
Proof.
	intros a ainclN anee.
	assert (strong_induction : forall n : nat,
	  (exists k : nat, LessEqual_exist k n /\ N k inE a) ->
	   (exists k : nat, N k inE a /\ (forall y : _, y inE a -> N k incl y))).
	{ intros n; induction n as [|n IHn].
	  - intros [[|k] [[kO kleO] kina]].
	    + clear kO kleO; exists O; split.
	      by exact kina.
	      intros y yina.
	      specialize (ainclN _ yina) as [z yinNbyz]; rewrite (Eeq_is_eq yinNbyz); clear.
	      by exact (lee_is_incl (lee_O_n _)).
	    + by rewrite add_m_Sn in kleO; discriminate kleO.
	  - intros [k [[kn klen] kina]].
	    specialize (classic (exists k, LessEqual_exist k n /\ N k inE a)) as [exkina | nexkina].
	    by exact (IHn exkina).
	    destruct kn as [|kn].
	    exists (S n); split; clear IHn anee.
	    by unfold add in klen; rewrite klen in kina; exact kina.
	    intros y yina.
	    specialize (ainclN _ yina) as [m yeqm];
	      apply Eeq_is_eq in yeqm; rewrite yeqm; rewrite yeqm in yina; clear y yeqm.
	    specialize (not_and_or _ _
	      (not_ex_all_not _ (fun k => LessEqual_exist k n /\ N k inE a) nexkina m))
	      as [mgtn | mnia].
	    assert (Snlem : LessEqual_exist (S n) m).
	    { specialize (lee_total n m) as [[[|nm] nlem] | mlen].
	      by unfold add in nlem; rewrite nlem in mgtn; is_false (mgtn (le_ex_refl _)).
	      by exists nm; rewrite add_m_Sn; exact nlem.
	      by is_false (mgtn mlen). }
	    by exact (lee_is_incl Snlem).
	    by is_false (mnia yina).

	    exfalso; rewrite add_Sm_n in klen; injection klen as klen.
	    specialize (not_and_or _ _
	      (not_ex_all_not _ (fun k => LessEqual_exist k n /\ N k inE a) nexkina k))
	      as [kgtn | knia].
	    by exact (kgtn (ex_intro _ _ klen)).
	    by exact (knia kina). }
	specialize (non_empty_is_not_empty _ anee) as [x xina].
	destruct (ainclN _ xina) as [n xinNbyn]; rewrite (Eeq_is_eq xinNbyn) in xina; clear x xinNbyn.
	by exact (strong_induction _ (ex_intro _ _ (conj (le_ex_refl _) xina))).
Qed.
Example all_nonempty_majored_maximum : forall a : Ensemble,
  a incl Nnat -> a <> EmptySet -> (exists n : nat, (forall k : _, k inE a -> k incl N n))
    -> exists n : nat, (N n inE a) /\ (forall y : Ensemble, y inE a -> y incl N n).
Proof.
	intros a ainclN anee [M amajbyM].
	induction M as [|M IHM].
	exists O; split.
	specialize (non_empty_is_not_empty _ anee) as [x xina].
	destruct (ainclN _ xina) as [n xinNbyn]; rewrite (Eeq_is_eq xinNbyn) in xina; clear x xinNbyn.
	specialize (amajbyM _ xina).
	specialize (classic (N n = N O)) as [neqO | nneO].
	by rewrite neqO in xina; exact xina.
	specialize (non_empty_is_not_empty _ nneO) as [x xinn].
	by is_false (empty_is_empty _ (amajbyM _ xinn)).
	by exact amajbyM.

	specialize (classic (N (S M) inE a)) as [SMina | SMnia].
	exists (S M); split.
	by exact SMina.
	intros y yina.
	destruct (ainclN _ yina) as [n yinNbyn]; apply Eeq_is_eq in yinNbyn; rewrite yinNbyn; rewrite yinNbyn in yina; clear y yinNbyn.
	by exact (amajbyM _ yina).
	apply IHM.
	intros k kina.
	destruct (ainclN _ kina) as [n kinNbyn]; apply Eeq_is_eq in kinNbyn; rewrite kinNbyn; rewrite kinNbyn in kina; clear k kinNbyn.
	specialize (incl_is_lee (amajbyM _ kina)) as [[|nSM] nleSM].
	unfold add in nleSM; rewrite nleSM in kina.
	by is_false (SMnia kina).
	injection nleSM as nleM.
	by exact (lee_is_incl (ex_intro _ _ nleM)).
Qed.
Example N_not_maximized : forall n : nat, exists k : nat, N k not_incl N n.
Proof.
	intros n; exists (S n); apply not_incl_notincl; intros Snincln.
	apply incl_is_lee in Snincln.
	assert (nleSn : LessEqual_exist n (S n)) by (exists (S O); exact (eq_refl _)).
	specialize (le_ex_sym _ _ Snincln nleSn) as Sneqn.
	clear Snincln nleSn; induction n as [|n IHn]. (* Sigh... *)
	by discriminate Sneqn.
	by injection Sneqn as Sneqn; exact (IHn Sneqn).
Qed.

Fixpoint mul (m n : nat) := match m with | O => O | S m' => add (mul m' n) n end.
Lemma mulC : forall m n : nat, mul m n = mul n m.
Proof.
	intros m; induction m as [|m IHm]; intros n; induction n as [|n IHn].
	by exact (eq_refl _).
	by minimize mul; rewrite <-IHn; exact (eq_refl _).
	by minimize mul; rewrite   IHm; exact (eq_refl _).
	by minimize mul; rewrite <-IHn, IHm; minimize mul;
	  rewrite IHm, (addA _ m _), (addA _ n _), (addC m (S n)), add_Sm_n, <-add_m_Sn;
	  exact (eq_refl _).
Qed.
Lemma mul_Sm_n : forall m n : nat, mul (S m) n = add (mul m n) n.
Proof. by intros; exact (eq_refl _). Qed.
Lemma mul_m_Sn : forall m n : nat, mul m (S n) = add (mul m n) m.
Proof.
	by intros; rewrite (mulC _ (S _)), mul_Sm_n;
	  exact (f_equal (fun k => add k _) (mulC _ _)).
Qed.
Lemma mul_add_distr_l : forall m n p : nat, mul (add m n) p = add (mul m p) (mul n p).
Proof.
	intros m; induction m as [|m IHm]; intros n p.
	by exact (eq_refl _).
	rewrite add_Sm_n, mul_Sm_n, mul_Sm_n, IHm, (addA _ _ p), (addC (mul n _) p), <-addA.
	by exact (eq_refl _).
Qed.
Lemma mulA : forall m n p : nat, mul (mul m n) p = mul m (mul n p).
Proof.
	intros m; induction m as [|m IHm]; intros n p.
	by exact (eq_refl _).
	by rewrite mul_Sm_n, mul_add_distr_l, IHm; exact (eq_refl _).
Qed.
Corollary mul_O_n : forall n : nat, mul O n = O.
Proof. by intros; exact (eq_refl _). Qed.
Corollary mul_n_O : forall n : nat, mul n O = O.
Proof. by intros; rewrite mulC; exact (eq_refl _). Qed.
Corollary mul_SO_n : forall n : nat, mul (S O) n = n.
Proof. by intros; exact (eq_refl _). Qed.
Corollary mul_n_SO : forall n : nat, mul n (S O) = n.
Proof. by intros; rewrite mulC; exact (eq_refl _). Qed.

Lemma add_eq_O_l : forall m n : nat, add m n = O -> m = O.
Proof.
	intros m; induction m as [|m IHm]; intros n cond.
	by exact (eq_refl _).
	by discriminate cond.
Qed.
Lemma add_eq_O_r : forall m n : nat, add m n = O -> n = O.
Proof.
	by intros m n cond; rewrite addC in cond; exact (add_eq_O_l _ _ cond).
Qed.

Lemma le_is_le_mul : forall m n p : nat, LessEqual_exist m n -> LessEqual_exist (mul m p) (mul n p).
Proof.
	intros m n p [mn mlen]; exists (mul mn p).
	by rewrite <-mlen, mul_add_distr_l; exact (eq_refl _).
Qed.
Lemma le_mul_is_le_l : forall n a b : nat, n <> O -> LessEqual_exist (mul n a) (mul n b) -> LessEqual_exist a b.
Proof.
	intros [|n] a b nneO nalenb.
	by is_false (nneO (eq_refl _)).
	clear nneO; generalize dependent nalenb; generalize dependent b;
	  generalize dependent a; induction n as [|n IHn]; intros a b nalenb.
	by exact nalenb.
	specialize (lee_total a b) as [aleb | blea].
	by exact aleb.
	rewrite (mul_Sm_n (S n) _), (mul_Sm_n (S n) _), (addC _ a), (addC _ b) in nalenb.
	by exact (IHn _ _ (sum_less_individual_more _ _ _ _ nalenb blea)).
Qed.
Lemma le_mul_is_le_r : forall n a b : nat, n <> O -> LessEqual_exist (mul a n) (mul b n) -> LessEqual_exist a b.
Proof.
	intros n a b nneO nalenb; rewrite (mulC _ n), (mulC _ n) in nalenb.
	generalize dependent nalenb; generalize dependent nneO;
	  generalize dependent b; generalize dependent a; generalize dependent n.
	by exact le_mul_is_le_l.
Qed.
Corollary eq_mul_is_eq_l : forall n a b : nat, n <> O -> (mul n a) = (mul n b) -> a = b.
Proof.
	intros n a b nneO naeqnb; apply le_ex_sym.
	specialize (le_ex_refl (mul n b)) as tmp; rewrite <-naeqnb in tmp at 1; clear naeqnb.
	generalize dependent tmp; generalize dependent nneO; generalize dependent b;
	  generalize dependent a; generalize dependent n; exact le_mul_is_le_l.
	specialize (le_ex_refl (mul n a)) as tmp; rewrite naeqnb in tmp at 1; clear naeqnb.
	generalize dependent tmp; generalize dependent nneO; generalize dependent a;
	  generalize dependent b; generalize dependent n; exact le_mul_is_le_l.
Qed.
Corollary eq_mul_is_eq_r : forall n a b : nat, n <> O -> (mul a n) = (mul b n) -> a = b.
Proof.
	by intros n a b nneO aneqbn; rewrite (mulC _ n), (mulC _ n) in aneqbn;
	  exact (eq_mul_is_eq_l n _ _ nneO aneqbn).
Qed.


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

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

Require Import ZArith ZAxioms ZDivFloor ZSig.

(** * The interface [ZSig.ZType] implies the interface [ZAxiomsSig]

    It also provides [sgn], [abs], [div], [mod]
*)

Module ZTypeIsZAxioms (Import Z : ZType').

Hint Rewrite
 spec_0 spec_1 spec_add spec_sub spec_pred spec_succ
 spec_mul spec_opp spec_of_Z spec_div spec_modulo
 spec_compare spec_eq_bool spec_max spec_min spec_abs spec_sgn
 : zsimpl.

Ltac zsimpl := autorewrite with zsimpl.
Ltac zcongruence := repeat red; intros; zsimpl; congruence.
Ltac zify := unfold eq, lt, le in *; zsimpl.

Instance eq_equiv : Equivalence eq.
Proof. unfold eq. firstorder. Qed.

Local Obligation Tactic := zcongruence.

Program Instance succ_wd : Proper (eq ==> eq) succ.
Program Instance pred_wd : Proper (eq ==> eq) pred.
Program Instance add_wd : Proper (eq ==> eq ==> eq) add.
Program Instance sub_wd : Proper (eq ==> eq ==> eq) sub.
Program Instance mul_wd : Proper (eq ==> eq ==> eq) mul.

Theorem pred_succ : forall n, pred (succ n) == n.
Proof.
intros. zify. auto with zarith.
Qed.

Section Induction.

Variable A : Z.t -> Prop.
Hypothesis A_wd : Proper (eq==>iff) A.
Hypothesis A0 : A 0.
Hypothesis AS : forall n, A n <-> A (succ n).

Let B (z : Z) := A (of_Z z).

Lemma B0 : B 0.
Proof.
unfold B; simpl.
rewrite <- (A_wd 0); auto.
zify. auto.
Qed.

Lemma BS : forall z : Z, B z -> B (z + 1).
Proof.
intros z H.
unfold B in *. apply -> AS in H.
setoid_replace (of_Z (z + 1)) with (succ (of_Z z)); auto.
zify. auto.
Qed.

Lemma BP : forall z : Z, B z -> B (z - 1).
Proof.
intros z H.
unfold B in *. rewrite AS.
setoid_replace (succ (of_Z (z - 1))) with (of_Z z); auto.
zify. auto with zarith.
Qed.

Lemma B_holds : forall z : Z, B z.
Proof.
intros; destruct (Z_lt_le_dec 0 z).
apply natlike_ind; auto with zarith.
apply B0.
intros; apply BS; auto.
replace z with (-(-z))%Z in * by (auto with zarith).
remember (-z)%Z as z'.
pattern z'; apply natlike_ind.
apply B0.
intros; rewrite Zopp_succ; unfold Zpred; apply BP; auto.
subst z'; auto with zarith.
Qed.

Theorem bi_induction : forall n, A n.
Proof.
intro n. setoid_replace n with (of_Z (to_Z n)).
apply B_holds.
zify. auto.
Qed.

End Induction.

Theorem add_0_l : forall n, 0 + n == n.
Proof.
intros. zify. auto with zarith.
Qed.

Theorem add_succ_l : forall n m, (succ n) + m == succ (n + m).
Proof.
intros. zify. auto with zarith.
Qed.

Theorem sub_0_r : forall n, n - 0 == n.
Proof.
intros. zify. auto with zarith.
Qed.

Theorem sub_succ_r : forall n m, n - (succ m) == pred (n - m).
Proof.
intros. zify. auto with zarith.
Qed.

Theorem mul_0_l : forall n, 0 * n == 0.
Proof.
intros. zify. auto with zarith.
Qed.

Theorem mul_succ_l : forall n m, (succ n) * m == n * m + m.
Proof.
intros. zify. ring.
Qed.

(** Order *)

Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
Proof.
 intros. zify. destruct (Zcompare_spec [x] [y]); auto.
Qed.

Definition eqb := eq_bool.

Lemma eqb_eq : forall x y, eq_bool x y = true <-> x == y.
Proof.
 intros. zify. symmetry. apply Zeq_is_eq_bool.
Qed.

Instance compare_wd : Proper (eq ==> eq ==> Logic.eq) compare.
Proof.
intros x x' Hx y y' Hy. rewrite 2 spec_compare, Hx, Hy; intuition.
Qed.

Instance lt_wd : Proper (eq ==> eq ==> iff) lt.
Proof.
intros x x' Hx y y' Hy; unfold lt; rewrite Hx, Hy; intuition.
Qed.

Theorem lt_eq_cases : forall n m, n <= m <-> n < m \/ n == m.
Proof.
intros. zify. omega.
Qed.

Theorem lt_irrefl : forall n, ~ n < n.
Proof.
intros. zify. omega.
Qed.

Theorem lt_succ_r : forall n m, n < (succ m) <-> n <= m.
Proof.
intros. zify. omega.
Qed.

Theorem min_l : forall n m, n <= m -> min n m == n.
Proof.
intros n m. zify. omega with *.
Qed.

Theorem min_r : forall n m, m <= n -> min n m == m.
Proof.
intros n m. zify. omega with *.
Qed.

Theorem max_l : forall n m, m <= n -> max n m == n.
Proof.
intros n m. zify. omega with *.
Qed.

Theorem max_r : forall n m, n <= m -> max n m == m.
Proof.
intros n m. zify. omega with *.
Qed.

(** Part specific to integers, not natural numbers *)

Program Instance opp_wd : Proper (eq ==> eq) opp.

Theorem succ_pred : forall n, succ (pred n) == n.
Proof.
intros. zify. auto with zarith.
Qed.

Theorem opp_0 : - 0 == 0.
Proof.
intros. zify. auto with zarith.
Qed.

Theorem opp_succ : forall n, - (succ n) == pred (- n).
Proof.
intros. zify. auto with zarith.
Qed.

Theorem abs_eq : forall n, 0 <= n -> abs n == n.
Proof.
intros n. zify. omega with *.
Qed.

Theorem abs_neq : forall n, n <= 0 -> abs n == -n.
Proof.
intros n. zify. omega with *.
Qed.

Theorem sgn_null : forall n, n==0 -> sgn n == 0.
Proof.
intros n. zify. omega with *.
Qed.

Theorem sgn_pos : forall n, 0<n -> sgn n == succ 0.
Proof.
intros n. zify. omega with *.
Qed.

Theorem sgn_neg : forall n, n<0 -> sgn n == opp (succ 0).
Proof.
intros n. zify. omega with *.
Qed.

Program Instance div_wd : Proper (eq==>eq==>eq) div.
Program Instance mod_wd : Proper (eq==>eq==>eq) modulo.

Theorem div_mod : forall a b, ~b==0 -> a == b*(div a b) + (modulo a b).
Proof.
intros a b. zify. intros. apply Z_div_mod_eq_full; auto.
Qed.

Theorem mod_pos_bound :
 forall a b, 0 < b -> 0 <= modulo a b /\ modulo a b < b.
Proof.
intros a b. zify. intros. apply Z_mod_lt; auto with zarith.
Qed.

Theorem mod_neg_bound :
 forall a b, b < 0 -> b < modulo a b /\ modulo a b <= 0.
Proof.
intros a b. zify. intros. apply Z_mod_neg; auto with zarith.
Qed.

End ZTypeIsZAxioms.

Module ZType_ZAxioms (Z : ZType)
 <: ZAxiomsSig <: ZDivSig <: HasCompare Z <: HasEqBool Z <: HasMinMax Z
 := Z <+ ZTypeIsZAxioms.


(** This file contains the three logical axioms and the direct consequences of
those axioms. *)

Require Export coq_logic.
Require Export Setoid.

Set Implicit Arguments.

Axiom functional_ext : ∀ (A : Type) (B : A → Type) (f g : ∀ x, B x),
    (∀ x, f x = g x) → f = g.
Axiom propositional_ext : ∀ (P Q : Prop), P ↔ Q → P = Q.
Axiom indefinite_description : ∀ {A : Type}, inhabited A → A.

Global Instance iff_rewrite : subrelation iff equal.
Proof.
    intros A B Hequiv.
    apply propositional_ext.
    exact Hequiv.
Qed.

Theorem ex_to_type : ∀ {A : Type} {P : A → Prop}, ex P → ex_type P.
Proof.
    intros A P P_ex.
    apply indefinite_description.
    destruct P_ex as [y Py].
    split.
    exists y.
    exact Py.
Qed.

(* begin hide *)
(* This proof is not my own *)
Module ProofIrrelevance.
    Lemma prop_eq_self_impl_when_true : ∀ {P : Prop}, P → P = (P → P).
    Proof.
        intros P H.
        apply propositional_ext.
        split; intros; exact H.
    Qed.
    Record has_fixpoint (P : Prop) : Prop := has_fixpoint_make {
        has_fixpoint_F : (P → P) → P;
        has_fixpoint_fix : ∀ f, has_fixpoint_F f = f (has_fixpoint_F f)
    }.
    Lemma prop_has_fixpoint_when_true : ∀ P : Prop, P → has_fixpoint P.
    Proof.
        intros P H.
        set (P' := P).
        assert (P' = P) as P_eq by (unfold P'; reflexivity).
        pose (g1 (a : P') := a).
        pose (g2 (a : P') := a).
        assert (∀ x, g1 (g2 x) = x) as Fix by reflexivity.
        clearbody g1 g2.
        unfold P' in g1 at 2.
        unfold P' in g2 at 1.
        unfold P' in Fix.
        generalize dependent g2.
        generalize dependent g1.
        rewrite (prop_eq_self_impl_when_true H).
        subst P'.
        intros.
        set (Y := λ f, (λ x, f (g1 x x)) (g2 (λ x, f (g1 x x)))).
        apply (@has_fixpoint_make P Y).
        intros f.
        unfold Y at 1.
        rewrite Fix.
        reflexivity.
    Qed.
    Inductive boolP : Prop :=
        | trueP : boolP
        | falseP : boolP.
    Lemma trueP_eq_falseP : trueP = falseP.
    Proof.
        pose proof (@prop_has_fixpoint_when_true boolP trueP) as [Y Yfix].
        set (neg := λ b, match b with | trueP => falseP | falseP => trueP end).
        pose proof (Yfix neg) as F.
        set (b := Y neg).
        assert (b = Y neg) as E by reflexivity.
        destruct b.
        {
            change (trueP = neg trueP).
            rewrite E, <- F.
            reflexivity.
        }
        {
            change (neg falseP = falseP).
            rewrite E, <- F.
            reflexivity.
        }
    Qed.
    Theorem proof_irrelevance : ∀ {P : Prop} (a b : P), a = b.
    Proof.
        intros P a b.
        set (f := λ c, match c with trueP => a | falseP => b end).
        change a with (f trueP).
        change b with (f falseP).
        rewrite trueP_eq_falseP.
        reflexivity.
    Qed.
End ProofIrrelevance.
(* end hide *)
Export ProofIrrelevance (proof_irrelevance).

Theorem predicate_ext : ∀ {U : Type} (P Q : U → Prop),
    (∀ x, P x ↔ Q x) → P = Q.
Proof.
    intros U P Q H.
    apply functional_ext.
    intros x.
    specialize (H x).
    apply propositional_ext.
    exact H.
Qed.

Definition ex_type_val {A : Type} {P : A → Prop} (e : ex_type P) :
    A                 := match e with ex_type_constr _ a _ => a end.
Definition ex_type_proof {A : Type} {P : A → Prop} (e : ex_type P) :
    P (ex_type_val e) := match e with ex_type_constr _ _ b => b end.

Definition ex_val {A : Type} {P : A → Prop} (e : ex P) :=
    ex_type_val (ex_to_type e).
Definition ex_proof {A : Type} {P : A → Prop} (e : ex P) :=
    ex_type_proof (ex_to_type e).

Theorem unpack_ex_val {A : Type} {P : A → Prop} : ∀ H : ex P,
    ∃ a, ex_val H = a ∧ P a.
Proof.
    intros H.
    exists (ex_val H).
    split.
    -   reflexivity.
    -   unfold ex_val.
        destruct (ex_to_type H) as [y Py].
        cbn.
        exact Py.
Qed.

Tactic Notation "unpack_ex_val_with"
    constr(H) simple_intropattern(a) ident(b) simple_intropattern(c)
    :=
    destruct (unpack_ex_val H) as [a [b c]].

Tactic Notation "unpack_ex_val"
    simple_intropattern(a) ident(b) simple_intropattern(c)
    :=
    match goal with
    | |- context [ex_val ?H] => unpack_ex_val_with H a b c
    | K: context [ex_val ?H] |- _ => unpack_ex_val_with H a b c
    end.

Tactic Notation "rewrite_ex_val_with"
    constr(H) simple_intropattern(a) simple_intropattern(c)
    :=
    let b := fresh in
    unpack_ex_val_with H a b c;
    rewrite b in *;
    clear b.

Tactic Notation "rewrite_ex_val" simple_intropattern(a) simple_intropattern(c)
    :=
    let b := fresh in
    unpack_ex_val a b c;
    rewrite b in *;
    clear b.

(* begin hide *)
(* This proof is not my own *)
Module ExcludedMiddle.
    Inductive bool : Set :=
        | true : bool
        | false : bool.
    Theorem em : ∀ (P : Prop), P ∨ ¬P.
    Proof.
        intros P.
        set (B1 b := b = true ∨ P).
        set (B2 b := b = false ∨ P).
        assert (ex B1) as H1 by (exists true; left; reflexivity).
        assert (ex B2) as H2 by (exists false; left; reflexivity).
        destruct (ex_proof H1) as [HA|]; try (left; assumption).
        destruct (ex_proof H2) as [HB|]; try (left; assumption).
        right; intros HP.
        assert (B1 = B2) as EB.
        {
            apply predicate_ext.
            intros b.
            split; intros; right; exact HP.
        }
        destruct EB.
        rewrite (proof_irrelevance H2 H1) in HB.
        rewrite HB in HA.
        inversion HA.
    Qed.
    Theorem sem : ∀ P, {P} + {¬P}.
    Proof.
        intros P.
        apply indefinite_description.
        destruct (em P) as [PH|PH].
        -   split; left; exact PH.
        -   split; right; exact PH.
    Qed.
End ExcludedMiddle.
(* end hide *)
Export ExcludedMiddle (em).
Export ExcludedMiddle (sem).

Tactic Notation "classic_case" constr(P) := destruct (sem P).
Tactic Notation "classic_case" constr(P)
    "as" "[" simple_intropattern(H1) "|" simple_intropattern(H2) "]"
    := destruct (sem P) as [H1|H2].

Notation "'If' P 'then' v1 'else' v2" :=
    (if (sem P) then v1 else v2)
    (at level 200, right associativity).

Notation "'IfH' P 'then' v1 'else' v2" :=
    match (sem P) with
    | strong_or_left H => v1 H
    | strong_or_right H => v2 H
    end
    (at level 200, right associativity).

Theorem if_true {U} : ∀ {H : Prop} {a b : U}, H → (If H then a else b) = a.
Proof.
    intros H a b P.
    destruct (sem H).
    -   reflexivity.
    -   contradiction.
Qed.

Theorem if_false {U} : ∀ {H : Prop} {a b : U}, ¬H → (If H then a else b) = b.
Proof.
    intros H a b P.
    destruct (sem H).
    -   contradiction.
    -   reflexivity.
Qed.


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

Coq < Section Examples.

Coq < Require Import Classical.

Coq < Variables P Q : Prop.
P is assumed
Q is assumed

Coq < Goal ((P \/ Q) /\ ~P) -> Q.
1 subgoal

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

Unnamed_thm < intros.
1 subgoal

  P : Prop
  Q : Prop
  H : (P \/ Q) /\ ~ P
  ============================
   Q

Unnamed_thm < elim H.
1 subgoal

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

Unnamed_thm < intro.
1 subgoal

  P : Prop
  Q : Prop
  H : (P \/ Q) /\ ~ P
  H0 : P \/ Q
  ============================
   ~ P -> Q

Unnamed_thm < intro.
1 subgoal

  P : Prop
  Q : Prop
  H : (P \/ Q) /\ ~ P
  H0 : P \/ Q
  H1 : ~ P
  ============================
   Q

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
firstorder .

Unnamed_thm is defined

Coq <


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

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


(** Copyright (c) 2018 by Swirlds, Inc.
   Implemented by Karl Crary.
*)

Require Import Nat.
Require Import Bool.
Require Import Omega.
Require Import List.
Require Import Permutation.

Require Import Tact.
Require Import Decide.
Require Import Relation.
Require Import HashgraphFacts.
Require Import Sees.
Require Import Round.
Require Import Progress.
Require Import Decision.
Require Import Consensus.
Require Import Famous.
Require Import Received.
Require Import Median.

Definition earliest_observer (x y z : event) : Prop :=
  x @= y
  /\ (forall y', self_parent y' y -> x @= y' -> False)
  /\ y $= z.

Definition time_received (s : sample) (W : world) (x : event) (t : nat) : Prop :=
  exists i l,
    received s W i x
    /\ NoDup l
    /\ (forall y,
          (exists w,
             ufwitness s W i w
             /\ earliest_observer x y w)
          <-> In y l)
    /\ t = median l.

(** The consensus order. *)
Definition corder (s : sample) (W : world) (x y : event) : Prop :=
  exists i j t u,
    received s W i x
    /\ received s W j y
    /\ time_received s W x t
    /\ time_received s W y u
    /\ (i < j
        \/ (i = j /\ t < u)
        \/ (i = j /\ t = u /\ Is_true (textorder x y))).

Lemma earliest_observer_impl_self_ancestor :
  forall x y z,
    earliest_observer x y z
    -> y $= z.
Proof.
intros x y z H.
destruct H as (_ & _ & H).
exact H.
Qed.

Lemma time_received_fun :
  forall s W x t u,
    time_received s W x t
    -> time_received s W x u
    -> t = u.
Proof.
intros s W x t u Ht Hu.
destruct Ht as (i & l & Hi & Hdistl & Hl & ->).
destruct Hu as (i' & m & Hi' & Hdistm & Hm & ->).
so (received_fun _#5 Hi Hi'); subst i'.
clear Hi'.
apply median_unique.
apply NoDup_Permutation; auto.
intro y.
rewrite <- Hl.
rewrite <- Hm.
reflexivity.
Qed.

Lemma received_impl_time_received :
  forall s W x i,
    received s W i x
    -> finite (ufwitness s W i)
    -> exists t,
         time_received s W x t.
Proof.
intros s W x i Hrec Hfinf.
cut (finite (fun y =>
               exists w,
                 ufwitness s W i w
                 /\ earliest_observer x y w)).
  {
  intro Hfin.
  destruct Hfin as (l & Hl).
  so (Cardinality.deduplicate _ l eq_event_decide) as (l' & Hdist & Hl').
  exists (median l').
  exists i, l'.
  do2 3 split; auto.
  intro y.
  transitivity (In y l); auto.
  }
apply finite_exists; auto.
intros w Hfwit.
apply (finite_subset _ _ (fun y => y @= w)).
  {
  intros y Hy.
  destruct Hy as (_ & _ & Hyw).
  apply self_ancestor_impl_ancestor; auto.
  }

  {
  intros y.
  apply dec_and; [| apply dec_and].
    {
    apply ancestor_decide.
    }

    {
    apply dec_forall_imp_finite.
      {
      apply (finite_subset _ _ (fun y' => parent y' y)).
        {
        intros y' Hy'.
        apply self_parent_impl_parent; auto.
        }

        {
        intro.
        apply self_parent_decide.
        }

        {
        apply parent_finite.
        }
      }

      {
      intros y' Hyy.
      apply dec_not.
      apply ancestor_decide.
      }
    }

    {
    apply self_ancestor_decide.
    }
  }

  {
  apply ancestor_finite.
  }
Qed.

Lemma time_received_defined :
  forall s x,
    member (global s) x
    -> honest (creator x)
    -> exists t,
         time_received s (global s) x t.
Proof.
intros s x Hsx Hhonest.
so (received_defined s x Hsx Hhonest) as (i & Hrec).
eapply received_impl_time_received; eauto.
apply ufwitness_finite_global.
Qed.

Theorem corder_antisym :
  forall s,
    antisymmetric event (corder s (global s)).
Proof.
intros s x y Hxy Hyx.
destruct Hxy as (i & j & t & u & Hi & Hj & Ht & Hu & Hxy).
destruct Hyx as (j' & i' & u' & t' & Hj' & Hi' & Hu' & Ht' & Hyx).
so (received_fun _#5 Hi Hi'); subst i'.
so (received_fun _#5 Hj Hj'); subst j'.
so (time_received_fun _#5 Ht Ht'); subst t'.
so (time_received_fun _#5 Hu Hu'); subst u'.
destruct Hxy as [Hij | [Htu | Hxy]]; destruct Hyx as [Hji | [Hut | Hyx]]; try (exfalso; omega).
destruct Hxy as (_ & _ & Hxy).
destruct Hyx as (_ & _ & Hyx).
apply (ord_antisym _ _ textorder_order); auto.
Qed.

Theorem corder_trans :
  forall s,
    transitive event (corder s (global s)).
Proof.
intros s.
intros x y z Hxy Hyz.
destruct Hxy as (i & j & t & u & Hi & Hj & Ht & Hu & Hxy).
destruct Hyz as (j' & k & u' & v & Hj' & Hk & Hu' & Hv & Hyz).
so (received_fun _#5 Hj Hj'); subst j'.
so (time_received_fun _#5 Hu Hu'); subst u'.
destruct Hxy as [Hij | [(Hij & Htu) | (Hij & Htu & Hxy)]]; destruct Hyz as [Hjk | [(Hjk & Huv) | (Hjk & Huv & Hyz)]];
exists i, k, t, v;
do2 4 split; auto;
try (left; omega);
try (right; left; omega).
right; right.
subst j k u v.
do2 2 split; auto.
eapply (ord_trans _ _ textorder_order); eauto.
Qed.

Theorem corder_total :
  forall s x y,
    member (global s) x
    -> member (global s) y
    -> honest (creator x)
    -> honest (creator y)
    -> corder s (global s) x y \/ corder s (global s) y x.
Proof.
intros s x y Hsx Hsy Hhonestx Hhonesty.
so (received_defined _ _ Hsx Hhonestx) as (i & Hrecx).
so (received_defined _ _ Hsy Hhonesty) as (j & Hrecy).
so (time_received_defined _ _ Hsx Hhonestx) as (t & Htimex).
so (time_received_defined _ _ Hsy Hhonesty) as (u & Htimey).
so (lt_eq_lt_dec i j) as [[Hij | Heq] | Hji].
  {
  left.
  exists i, j, t, u.
  do2 4 split; auto.
  }

2:{
  right.
  exists j, i, u, t.
  do2 4 split; auto.
  }
subst j.
so (lt_eq_lt_dec t u) as [[Htu | Heq] | Hut].
  {
  left.
  exists i, i, t, u.
  do2 4 split; auto.
  }

2:{
  right.
  exists i, i, u, t.
  do2 4 split; auto.
  }
subst u.
so (textorder_total x y) as [Hxy | Hyx].
  {
  left.
  exists i, i, t, t.
  do2 4 split; auto.
  }

  {
  right.
  exists i, i, t, t.
  do2 4 split; auto.
  }
Qed.

(** Theorem 5.19 *)
Corollary corder_refl :
  forall s x,
    member (global s) x
    -> honest (creator x)
    -> corder s (global s) x x.
Proof.
intros s x Hsx Hhonest.
so (corder_total _#3 Hsx Hsx Hhonest Hhonest) as H.
destruct H; auto.
Qed.

Lemma fwitness_stable :
  forall s W W' i y,
    extends W W'
    -> (forall x, decidable (member W x))
    -> nonempty W
    -> received_by s W i y
    -> forall x, fwitness s W i x <-> fwitness s W' i x.
Proof.
intros s V W i q Hextends Hdec Hne Hrb w.
so (received_by_inhabited _#4 Hne Hrb) as Hinh.
destruct Hrb as (Hsettled & _).
clear q.
split.
  {
  intros (Hwit & Hfamous).
  split; eauto using extends_famous.
  }

  {
  intros (Hwit & Hfamous).
  assert (member V w) as Vw.
    {
    so (Hdec w) as [| Vnw]; auto.
    exfalso.
    so Hinh as (y & Vy & Hroundy).
    so (ancestor_witness _#3 (le_refl _) Hroundy) as (z & Hzy & Hwitz).
    so (Hsettled i z (le_refl _) (world_closed _#3 Hzy Vy) Hwitz) as (v & b & Vv & Hdecisionz).
    so (no_late_fame_world _#7 Vv Vnw Hwitz Hwit Hdecisionz) as Hdecision.
    destruct Hfamous as (u & Wu & Hdecision').
    so (decision_consistent _#7 (Hextends _ Vv) Wu Hdecision Hdecision') as H.
    discriminate H.
    }
  split; auto.
  so (Hsettled i w (le_refl _) Vw Hwit) as (y & b & Vy & Hdecision).
  destruct Hfamous as (z & Wz & Hdecision').
  so (decision_consistent _#7 (Hextends _ Vy) Wz Hdecision Hdecision'); subst b.
  exists y.
  split; auto.
  }
Qed.

Lemma ufwitness_stable :
  forall s W W' i y,
    extends W W'
    -> (forall x, decidable (member W x))
    -> nonempty W
    -> received_by s W i y
    -> forall x, ufwitness s W i x <-> ufwitness s W' i x.
Proof.
intros s V W i q Hextends Hdec Hne Hrb w.
split.
  {
  intro Hw.
  destruct Hw as (Hw & Hmin).
  split.
    {
    exact (fwitness_stable _#5 Hextends Hdec Hne Hrb _ andel Hw).
    }
  intros y Hy Heqcr.
  apply Hmin; auto.
  exact (fwitness_stable _#5 Hextends Hdec Hne Hrb _ ander Hy).
  }

  {
  intro Hw.
  destruct Hw as (Hw & Hmin).
  split.
    {
    exact (fwitness_stable _#5 Hextends Hdec Hne Hrb _ ander Hw).
    }
  intros y Hy Heqcr.
  apply Hmin; auto.
  exact (fwitness_stable _#5 Hextends Hdec Hne Hrb _ andel Hy).
  }
Qed.

Lemma time_received_consistent :
  forall s W W' x t,
    extends W W'
    -> (forall x, decidable (member W x))
    -> nonempty W
    -> time_received s W x t
    -> time_received s W' x t.
Proof.
intros s V W x t Hextends Hdec Hne Htr.
destruct Htr as (i & l & Hrec & Hdist & Hl & ->).
exists i, l.
do2 3 split; auto.
  {
  eapply received_consistent; eauto.
  }
so (ufwitness_stable _#5 Hextends Hdec Hne (Hrec andel)) as Hfiff.
intros y.
rewrite <- Hl.
split.
  {
  intros (w & H).
  exists w.
  rewrite -> Hfiff.
  exact H.
  }

  {
  intros (w & H).
  exists w.
  rewrite <- Hfiff.
  exact H.
  }
Qed.

(** A hashgraph cannot later discover new predecessors in the consensus order. *)
Theorem corder_stable :
  forall s W W' x y,
    extends W W'
    -> (forall x, decidable (member W x))
    -> nonempty W
    -> corder s W y y
    -> corder s W' x y
    -> corder s W x y.
Proof.
intros s V W x y Hextends Hdec Hne HVy HWxy.
destruct HVy as (i & _ & t & _ & Hi & _ & Ht & _).
destruct HWxy as (j & i' & u & t' & Hj & Hi' & Hu & Ht' & Hxy).
so (received_consistent _#5 Hextends Hdec Hne Hi) as Hi''.
so (received_fun _#5 Hi' Hi''); subst i'.
clear Hi''.
so (time_received_consistent _#5 Hextends Hdec Hne Ht) as Ht''.
so (time_received_fun _#5 Ht' Ht''); subst t'.
clear Ht''.
exists j, i, u, t.
assert (received s V j x) as Hrec.
  {
  eapply received_cumulative; eauto.
  omega.
  }
do2 4 split; auto.
destruct Hu as (j' & l & Hrec' & Hdist & Hl & Hu).
so (received_fun _#5 (received_consistent _#5 Hextends Hdec Hne Hrec) Hrec'); subst j'.
exists j, l.
do2 3 split; auto.
intro z.
rewrite <- Hl.
so (ufwitness_stable _#5 Hextends Hdec Hne (Hrec andel)) as Hfiff.
split.
  {
  intros (w & H).
  exists w.
  rewrite <- Hfiff.
  exact H.
  }

  {
  intros (w & H).
  exists w.
  rewrite -> Hfiff.
  exact H.
  }
Qed.

(** A hashgraph eventually places every (honest) event into the consensus order. *)
Theorem corder_support :
  forall s W x,
    extends W (global s)
    -> (forall x, decidable (member W x))
    -> nonempty W
    -> (forall i, finite (ufwitness s W i))
    -> member (global s) x
    -> honest (creator x)
    -> exists j,
         (exists y, member W y /\ round j y)
         -> corder s W x x.
Proof.
intros s W x Hextends Hdec Hne Hfinf Hsx Hhonest.
so (received_defined _ _ Hsx Hhonest) as (i & Hrec).
so (received_support _#4 Hextends Hdec Hne Hrec) as (j & Hj).
exists j.
intro Hinh.
so (Hj Hinh) as Hrec'.
so (received_impl_time_received _#4 Hrec' (Hfinf i)) as (t & Htr).
exists i, i, t, t.
do2 4 split; auto.
right; right.
do2 2 split; auto.
apply (ord_refl _ _ textorder_order).
Qed.

Corollary corder_support_finite :
  forall s W x,
    extends W (global s)
    -> finite (member W)
    -> nonempty W
    -> member (global s) x
    -> honest (creator x)
    -> exists j,
         (exists y, member W y /\ round j y)
         -> corder s W x x.
Proof.
intros s W x Hextends Hfin Hne Hsx Hhonest.
apply corder_support; auto.
  {
  intro y.
  apply finite_decide; auto.
  exact eq_event_decide.
  }

  {
  apply ufwitness_finite_finite; auto.
  }
Qed.